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
Silence time64.c build warning
[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>
748a9306 29#include <atrdef.h>
a0d0e21e 30#include <chpdef.h>
8fde5078 31#include <clidef.h>
a3e9d8c9 32#include <climsgdef.h>
cd1191f1 33#include <dcdef.h>
a0d0e21e 34#include <descrip.h>
22d4bb9c 35#include <devdef.h>
a0d0e21e 36#include <dvidef.h>
748a9306 37#include <fibdef.h>
a0d0e21e
LW		 38#include <float.h>
39#include <fscndef.h>
40#include <iodef.h>
41#include <jpidef.h>
61bb5906 42#include <kgbdef.h>
f675dbe5 43#include <libclidef.h>
a0d0e21e
LW		 44#include <libdef.h>
45#include <lib$routines.h>
46#include <lnmdef.h>
aeb5cf3c 47#include <msgdef.h>
4fdf8f88 48#include <ossdef.h>
f7ddb74a
JM		 49#if __CRTL_VER >= 70301000 && !defined(__VAX)
50#include <ppropdef.h>
51#endif
748a9306 52#include <prvdef.h>
a0d0e21e
LW		 53#include <psldef.h>
54#include <rms.h>
55#include <shrdef.h>
56#include <ssdef.h>
57#include <starlet.h>
f86702cc 58#include <strdef.h>
59#include <str$routines.h>
a0d0e21e 60#include <syidef.h>
748a9306
LW		 61#include <uaidef.h>
62#include <uicdef.h>
2fbb330f
JM		 63#include <stsdef.h>
64#include <rmsdef.h>
cd1191f1 65#include <smgdef.h>
cfcfe586
JM		 66#if __CRTL_VER >= 70000000 /* FIXME to earliest version */
67#include <efndef.h>
68#define NO_EFN EFN$C_ENF
69#else
70#define NO_EFN 0;
71#endif
a0d0e21e 72
f7ddb74a
JM		 73#if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
74int decc$feature_get_index(const char *name);
75char* decc$feature_get_name(int index);
76int decc$feature_get_value(int index, int mode);
77int decc$feature_set_value(int index, int mode, int value);
78#else
79#include <unixlib.h>
80#endif
81
cfcfe586
JM		 82#pragma member_alignment save
83#pragma nomember_alignment longword
84struct item_list_3 {
85 unsigned short len;
86 unsigned short code;
87 void * bufadr;
88 unsigned short * retadr;
89};
90#pragma member_alignment restore
91
92/* More specific prototype than in starlet_c.h makes programming errors
93 more visible.
94 */
95#ifdef sys$getdviw
96#undef sys$getdviw
cfcfe586
JM		 97int sys$getdviw
98 (unsigned long efn,
99 unsigned short chan,
100 const struct dsc$descriptor_s * devnam,
101 const struct item_list_3 * itmlst,
102 void * iosb,
103 void * (astadr)(unsigned long),
104 void * astprm,
105 void * nullarg);
7566800d 106#endif
cfcfe586 107
4fdf8f88
JM		 108#ifdef sys$get_security
109#undef sys$get_security
110int sys$get_security
111 (const struct dsc$descriptor_s * clsnam,
112 const struct dsc$descriptor_s * objnam,
113 const unsigned int *objhan,
114 unsigned int flags,
115 const struct item_list_3 * itmlst,
116 unsigned int * contxt,
117 const unsigned int * acmode);
118#endif
119
120#ifdef sys$set_security
121#undef sys$set_security
122int sys$set_security
123 (const struct dsc$descriptor_s * clsnam,
124 const struct dsc$descriptor_s * objnam,
125 const unsigned int *objhan,
126 unsigned int flags,
127 const struct item_list_3 * itmlst,
128 unsigned int * contxt,
129 const unsigned int * acmode);
130#endif
131
8cb5d3d5
JM		 132#ifdef lib$find_image_symbol
133#undef lib$find_image_symbol
134int lib$find_image_symbol
135 (const struct dsc$descriptor_s * imgname,
136 const struct dsc$descriptor_s * symname,
137 void * symval,
138 const struct dsc$descriptor_s * defspec,
139 unsigned long flag);
4fdf8f88 140#endif
8cb5d3d5 141
4fdf8f88
JM		 142#ifdef lib$rename_file
143#undef lib$rename_file
144int lib$rename_file
145 (const struct dsc$descriptor_s * old_file_dsc,
146 const struct dsc$descriptor_s * new_file_dsc,
147 const struct dsc$descriptor_s * default_file_dsc,
148 const struct dsc$descriptor_s * related_file_dsc,
149 const unsigned long * flags,
150 void * (success)(const struct dsc$descriptor_s * old_dsc,
151 const struct dsc$descriptor_s * new_dsc,
152 const void *),
153 void * (error)(const struct dsc$descriptor_s * old_dsc,
154 const struct dsc$descriptor_s * new_dsc,
155 const int * rms_sts,
156 const int * rms_stv,
157 const int * error_src,
158 const void * usr_arg),
159 int (confirm)(const struct dsc$descriptor_s * old_dsc,
160 const struct dsc$descriptor_s * new_dsc,
161 const void * old_fab,
162 const void * usr_arg),
163 void * user_arg,
164 struct dsc$descriptor_s * old_result_name_dsc,
165 struct dsc$descriptor_s * new_result_name_dsc,
166 unsigned long * file_scan_context);
8cb5d3d5
JM		 167#endif
168
7a7fd8e0 169#if __CRTL_VER >= 70300000 && !defined(__VAX)
f7ddb74a
JM		 170
171static int set_feature_default(const char *name, int value)
172{
173 int status;
174 int index;
175
176 index = decc$feature_get_index(name);
177
178 status = decc$feature_set_value(index, 1, value);
179 if (index == -1 || (status == -1)) {
180 return -1;
181 }
182
183 status = decc$feature_get_value(index, 1);
184 if (status != value) {
185 return -1;
186 }
187
188return 0;
189}
190#endif
f7ddb74a 191
740ce14c 192/* Older versions of ssdef.h don't have these */
193#ifndef SS$_INVFILFOROP
194# define SS$_INVFILFOROP 3930
195#endif
196#ifndef SS$_NOSUCHOBJECT
b7ae7a0d 197# define SS$_NOSUCHOBJECT 2696
198#endif
199
a15cef0c
CB		 200/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
201#define PERLIO_NOT_STDIO 0
202
2497a41f 203/* Don't replace system definitions of vfork, getenv, lstat, and stat,
aa689395 204 * code below needs to get to the underlying CRTL routines. */
205#define DONT_MASK_RTL_CALLS
a0d0e21e
LW		 206#include "EXTERN.h"
207#include "perl.h"
748a9306 208#include "XSUB.h"
3eeba6fb
CB		 209/* Anticipating future expansion in lexical warnings . . . */
210#ifndef WARN_INTERNAL
211# define WARN_INTERNAL WARN_MISC
212#endif
a0d0e21e 213
988c775c
JM		 214#ifdef VMS_LONGNAME_SUPPORT
215#include <libfildef.h>
216#endif
217
22d4bb9c
CB		 218#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
219# define RTL_USES_UTC 1
220#endif
221
5f1992ed
CB		 222/* Routine to create a decterm for use with the Perl debugger */
223/* No headers, this information was found in the Programming Concepts Manual */
224
8cb5d3d5 225static int (*decw_term_port)
5f1992ed
CB		 226 (const struct dsc$descriptor_s * display,
227 const struct dsc$descriptor_s * setup_file,
228 const struct dsc$descriptor_s * customization,
229 struct dsc$descriptor_s * result_device_name,
230 unsigned short * result_device_name_length,
231 void * controller,
232 void * char_buffer,
8cb5d3d5 233 void * char_change_buffer) = 0;
22d4bb9c 234
c07a80fd 235/* gcc's header files don't #define direct access macros
236 * corresponding to VAXC's variant structs */
237#ifdef __GNUC__
482b294c 238# define uic$v_format uic$r_uic_form.uic$v_format
239# define uic$v_group uic$r_uic_form.uic$v_group
240# define uic$v_member uic$r_uic_form.uic$v_member
c07a80fd 241# define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
242# define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
243# define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
244# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
245#endif
246
c645ec3f
GS		 247#if defined(NEED_AN_H_ERRNO)
248dEXT int h_errno;
249#endif
c07a80fd 250
f7ddb74a
JM		 251#ifdef __DECC
252#pragma message disable pragma
253#pragma member_alignment save
254#pragma nomember_alignment longword
255#pragma message save
256#pragma message disable misalgndmem
257#endif
a0d0e21e
LW		 258struct itmlst_3 {
259 unsigned short int buflen;
260 unsigned short int itmcode;
261 void *bufadr;
748a9306 262 unsigned short int *retlen;
a0d0e21e 263};
657054d4
JM		 264
265struct filescan_itmlst_2 {
266 unsigned short length;
267 unsigned short itmcode;
268 char * component;
269};
270
dca5a913
JM		 271struct vs_str_st {
272 unsigned short length;
273 char str[65536];
274};
275
f7ddb74a
JM		 276#ifdef __DECC
277#pragma message restore
278#pragma member_alignment restore
279#endif
a0d0e21e 280
360732b5
JM		 281#define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
282#define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
283#define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
284#define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
285#define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
286#define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
b1a8dcd7 287#define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
360732b5
JM		 288#define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
289#define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
f7ddb74a 290#define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
4b19af01
CB		 291#define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
292#define getredirection(a,b) mp_getredirection(aTHX_ a,b)
293
360732b5
JM		 294static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
295static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
296static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
297static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
f7ddb74a 298
df278665
JM		 299static char *int_tovmsspec
300 (const char *path, char *buf, int dir_flag, int * utf8_flag);
0e5ce2c7 301static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
df278665 302
0e06870b
CB		 303/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
304#define PERL_LNM_MAX_ALLOWED_INDEX 127
305
2d9f3838
CB		 306/* OpenVMS User's Guide says at least 9 iterative translations will be performed,
307 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
308 * the Perl facility.
309 */
310#define PERL_LNM_MAX_ITER 10
311
2497a41f
JM		 312 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
313#if __CRTL_VER >= 70302000 && !defined(__VAX)
314#define MAX_DCL_SYMBOL (8192)
315#define MAX_DCL_LINE_LENGTH (4096 - 4)
316#else
317#define MAX_DCL_SYMBOL (1024)
318#define MAX_DCL_LINE_LENGTH (1024 - 4)
319#endif
ff7adb52 320
01b8edb6 321static char *__mystrtolower(char *str)
322{
323 if (str) for (; *str; ++str) *str= tolower(*str);
324 return str;
325}
326
f675dbe5
CB		 327static struct dsc$descriptor_s fildevdsc =
328 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
329static struct dsc$descriptor_s crtlenvdsc =
330 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
331static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
332static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
333static struct dsc$descriptor_s **env_tables = defenv;
334static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
335
93948341
CB		 336/* True if we shouldn't treat barewords as logicals during directory */
337/* munching */
338static int no_translate_barewords;
339
22d4bb9c
CB		 340#ifndef RTL_USES_UTC
341static int tz_updated = 1;
342#endif
343
f7ddb74a
JM		 344/* DECC Features that may need to affect how Perl interprets
345 * displays filename information
346 */
347static int decc_disable_to_vms_logname_translation = 1;
348static int decc_disable_posix_root = 1;
349int decc_efs_case_preserve = 0;
350static int decc_efs_charset = 0;
b53f3677 351static int decc_efs_charset_index = -1;
f7ddb74a
JM		 352static int decc_filename_unix_no_version = 0;
353static int decc_filename_unix_only = 0;
354int decc_filename_unix_report = 0;
355int decc_posix_compliant_pathnames = 0;
356int decc_readdir_dropdotnotype = 0;
357static int vms_process_case_tolerant = 1;
360732b5
JM		 358int vms_vtf7_filenames = 0;
359int gnv_unix_shell = 0;
e0e5e8d6 360static int vms_unlink_all_versions = 0;
1a3aec58 361static int vms_posix_exit = 0;
f7ddb74a 362
2497a41f 363/* bug workarounds if needed */
682e4b71 364int decc_bug_devnull = 1;
2497a41f 365int decc_dir_barename = 0;
b53f3677 366int vms_bug_stat_filename = 0;
2497a41f 367
9c1171d1 368static int vms_debug_on_exception = 0;
b53f3677
JM		 369static int vms_debug_fileify = 0;
370
371/* Simple logical name translation */
372static int simple_trnlnm
373 (const char * logname,
374 char * value,
375 int value_len)
376{
377 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
378 const unsigned long attr = LNM$M_CASE_BLIND;
379 struct dsc$descriptor_s name_dsc;
380 int status;
381 unsigned short result;
382 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
383 {0, 0, 0, 0}};
384
385 name_dsc.dsc$w_length = strlen(logname);
386 name_dsc.dsc$a_pointer = (char *)logname;
387 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
388 name_dsc.dsc$b_class = DSC$K_CLASS_S;
389
390 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
391
392 if ($VMS_STATUS_SUCCESS(status)) {
393
394 /* Null terminate and return the string */
395 /*--------------------------------------*/
396 value[result] = 0;
397 return result;
398 }
399
400 return 0;
401}
402
9c1171d1 403
f7ddb74a
JM		 404/* Is this a UNIX file specification?
405 * No longer a simple check with EFS file specs
406 * For now, not a full check, but need to
407 * handle POSIX ^UP^ specifications
408 * Fixing to handle ^/ cases would require
409 * changes to many other conversion routines.
410 */
411
657054d4 412static int is_unix_filespec(const char *path)
f7ddb74a
JM		 413{
414int ret_val;
415const char * pch1;
416
417 ret_val = 0;
418 if (strncmp(path,"\"^UP^",5) != 0) {
419 pch1 = strchr(path, '/');
420 if (pch1 != NULL)
421 ret_val = 1;
422 else {
423
424 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
425 if (decc_filename_unix_report || decc_filename_unix_only) {
426 if (strcmp(path,".") == 0)
427 ret_val = 1;
428 }
429 }
430 }
431 return ret_val;
432}
433
360732b5
JM		 434/* This routine converts a UCS-2 character to be VTF-7 encoded.
435 */
436
437static void ucs2_to_vtf7
438 (char *outspec,
439 unsigned long ucs2_char,
440 int * output_cnt)
441{
442unsigned char * ucs_ptr;
443int hex;
444
445 ucs_ptr = (unsigned char *)&ucs2_char;
446
447 outspec[0] = '^';
448 outspec[1] = 'U';
449 hex = (ucs_ptr[1] >> 4) & 0xf;
450 if (hex < 0xA)
451 outspec[2] = hex + '0';
452 else
453 outspec[2] = (hex - 9) + 'A';
454 hex = ucs_ptr[1] & 0xF;
455 if (hex < 0xA)
456 outspec[3] = hex + '0';
457 else {
458 outspec[3] = (hex - 9) + 'A';
459 }
460 hex = (ucs_ptr[0] >> 4) & 0xf;
461 if (hex < 0xA)
462 outspec[4] = hex + '0';
463 else
464 outspec[4] = (hex - 9) + 'A';
465 hex = ucs_ptr[1] & 0xF;
466 if (hex < 0xA)
467 outspec[5] = hex + '0';
468 else {
469 outspec[5] = (hex - 9) + 'A';
470 }
471 *output_cnt = 6;
472}
473
474
475/* This handles the conversion of a UNIX extended character set to a ^
476 * escaped VMS character.
477 * in a UNIX file specification.
478 *
479 * The output count variable contains the number of characters added
480 * to the output string.
481 *
482 * The return value is the number of characters read from the input string
483 */
484static int copy_expand_unix_filename_escape
485 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
486{
487int count;
488int scnt;
489int utf8_flag;
490
491 utf8_flag = 0;
492 if (utf8_fl)
493 utf8_flag = *utf8_fl;
494
495 count = 0;
496 *output_cnt = 0;
497 if (*inspec >= 0x80) {
498 if (utf8_fl && vms_vtf7_filenames) {
499 unsigned long ucs_char;
500
501 ucs_char = 0;
502
503 if ((*inspec & 0xE0) == 0xC0) {
504 /* 2 byte Unicode */
505 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
506 if (ucs_char >= 0x80) {
507 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
508 return 2;
509 }
510 } else if ((*inspec & 0xF0) == 0xE0) {
511 /* 3 byte Unicode */
512 ucs_char = ((inspec[0] & 0xF) << 12) +
513 ((inspec[1] & 0x3f) << 6) +
514 (inspec[2] & 0x3f);
515 if (ucs_char >= 0x800) {
516 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
517 return 3;
518 }
519
520#if 0 /* I do not see longer sequences supported by OpenVMS */
521 /* Maybe some one can fix this later */
522 } else if ((*inspec & 0xF8) == 0xF0) {
523 /* 4 byte Unicode */
524 /* UCS-4 to UCS-2 */
525 } else if ((*inspec & 0xFC) == 0xF8) {
526 /* 5 byte Unicode */
527 /* UCS-4 to UCS-2 */
528 } else if ((*inspec & 0xFE) == 0xFC) {
529 /* 6 byte Unicode */
530 /* UCS-4 to UCS-2 */
531#endif
532 }
533 }
534
38a44b82 535 /* High bit set, but not a Unicode character! */
360732b5
JM		 536
537 /* Non printing DECMCS or ISO Latin-1 character? */
538 if (*inspec <= 0x9F) {
539 int hex;
540 outspec[0] = '^';
541 outspec++;
542 hex = (*inspec >> 4) & 0xF;
543 if (hex < 0xA)
544 outspec[1] = hex + '0';
545 else {
546 outspec[1] = (hex - 9) + 'A';
547 }
548 hex = *inspec & 0xF;
549 if (hex < 0xA)
550 outspec[2] = hex + '0';
551 else {
552 outspec[2] = (hex - 9) + 'A';
553 }
554 *output_cnt = 3;
555 return 1;
556 } else if (*inspec == 0xA0) {
557 outspec[0] = '^';
558 outspec[1] = 'A';
559 outspec[2] = '0';
560 *output_cnt = 3;
561 return 1;
562 } else if (*inspec == 0xFF) {
563 outspec[0] = '^';
564 outspec[1] = 'F';
565 outspec[2] = 'F';
566 *output_cnt = 3;
567 return 1;
568 }
569 *outspec = *inspec;
570 *output_cnt = 1;
571 return 1;
572 }
573
574 /* Is this a macro that needs to be passed through?
575 * Macros start with $( and an alpha character, followed
576 * by a string of alpha numeric characters ending with a )
577 * If this does not match, then encode it as ODS-5.
578 */
579 if ((inspec[0] == '$') && (inspec[1] == '(')) {
580 int tcnt;
581
582 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
583 tcnt = 3;
584 outspec[0] = inspec[0];
585 outspec[1] = inspec[1];
586 outspec[2] = inspec[2];
587
588 while(isalnum(inspec[tcnt]) ||
589 (inspec[2] == '.') || (inspec[2] == '_')) {
590 outspec[tcnt] = inspec[tcnt];
591 tcnt++;
592 }
593 if (inspec[tcnt] == ')') {
594 outspec[tcnt] = inspec[tcnt];
595 tcnt++;
596 *output_cnt = tcnt;
597 return tcnt;
598 }
599 }
600 }
601
602 switch (*inspec) {
603 case 0x7f:
604 outspec[0] = '^';
605 outspec[1] = '7';
606 outspec[2] = 'F';
607 *output_cnt = 3;
608 return 1;
609 break;
610 case '?':
611 if (decc_efs_charset == 0)
612 outspec[0] = '%';
613 else
614 outspec[0] = '?';
615 *output_cnt = 1;
616 return 1;
617 break;
618 case '.':
619 case '~':
620 case '!':
621 case '#':
622 case '&':
623 case '\'':
624 case '`':
625 case '(':
626 case ')':
627 case '+':
628 case '@':
629 case '{':
630 case '}':
631 case ',':
632 case ';':
633 case '[':
634 case ']':
635 case '%':
636 case '^':
449de3c2 637 case '\\':
adc11f0b
CB		 638 /* Don't escape again if following character is
639 * already something we escape.
640 */
449de3c2 641 if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
adc11f0b
CB		 642 *outspec = *inspec;
643 *output_cnt = 1;
644 return 1;
645 break;
646 }
647 /* But otherwise fall through and escape it. */
360732b5
JM		 648 case '=':
649 /* Assume that this is to be escaped */
650 outspec[0] = '^';
651 outspec[1] = *inspec;
652 *output_cnt = 2;
653 return 1;
654 break;
655 case ' ': /* space */
656 /* Assume that this is to be escaped */
657 outspec[0] = '^';
658 outspec[1] = '_';
659 *output_cnt = 2;
660 return 1;
661 break;
662 default:
663 *outspec = *inspec;
664 *output_cnt = 1;
665 return 1;
666 break;
667 }
668}
669
670
657054d4
JM		 671/* This handles the expansion of a '^' prefix to the proper character
672 * in a UNIX file specification.
673 *
674 * The output count variable contains the number of characters added
675 * to the output string.
676 *
677 * The return value is the number of characters read from the input
678 * string
679 */
680static int copy_expand_vms_filename_escape
681 (char *outspec, const char *inspec, int *output_cnt)
682{
683int count;
684int scnt;
685
686 count = 0;
687 *output_cnt = 0;
688 if (*inspec == '^') {
689 inspec++;
690 switch (*inspec) {
adc11f0b
CB		 691 /* Spaces and non-trailing dots should just be passed through,
692 * but eat the escape character.
693 */
657054d4 694 case '.':
657054d4 695 *outspec = *inspec;
adc11f0b
CB		 696 count += 2;
697 (*output_cnt)++;
657054d4
JM		 698 break;
699 case '_': /* space */
700 *outspec = ' ';
adc11f0b 701 count += 2;
657054d4
JM		 702 (*output_cnt)++;
703 break;
adc11f0b
CB		 704 case '^':
705 /* Hmm. Better leave the escape escaped. */
706 outspec[0] = '^';
707 outspec[1] = '^';
708 count += 2;
709 (*output_cnt) += 2;
710 break;
360732b5 711 case 'U': /* Unicode - FIX-ME this is wrong. */
657054d4
JM		 712 inspec++;
713 count++;
714 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
715 if (scnt == 4) {
2f4077ca
JM		 716 unsigned int c1, c2;
717 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
718 outspec[0] == c1 & 0xff;
719 outspec[1] == c2 & 0xff;
657054d4
JM		 720 if (scnt > 1) {
721 (*output_cnt) += 2;
722 count += 4;
723 }
724 }
725 else {
726 /* Error - do best we can to continue */
727 *outspec = 'U';
728 outspec++;
729 (*output_cnt++);
730 *outspec = *inspec;
731 count++;
732 (*output_cnt++);
733 }
734 break;
735 default:
736 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
737 if (scnt == 2) {
738 /* Hex encoded */
2f4077ca
JM		 739 unsigned int c1;
740 scnt = sscanf(inspec, "%2x", &c1);
741 outspec[0] = c1 & 0xff;
657054d4
JM		 742 if (scnt > 0) {
743 (*output_cnt++);
744 count += 2;
745 }
746 }
747 else {
748 *outspec = *inspec;
749 count++;
750 (*output_cnt++);
751 }
752 }
753 }
754 else {
755 *outspec = *inspec;
756 count++;
757 (*output_cnt)++;
758 }
759 return count;
760}
761
7566800d
CB		 762#ifdef sys$filescan
763#undef sys$filescan
764int sys$filescan
657054d4
JM		 765 (const struct dsc$descriptor_s * srcstr,
766 struct filescan_itmlst_2 * valuelist,
767 unsigned long * fldflags,
768 struct dsc$descriptor_s *auxout,
769 unsigned short * retlen);
7566800d 770#endif
657054d4
JM		 771
772/* vms_split_path - Verify that the input file specification is a
773 * VMS format file specification, and provide pointers to the components of
774 * it. With EFS format filenames, this is virtually the only way to
775 * parse a VMS path specification into components.
776 *
777 * If the sum of the components do not add up to the length of the
778 * string, then the passed file specification is probably a UNIX style
779 * path.
780 */
781static int vms_split_path
360732b5 782 (const char * path,
dca5a913 783 char * * volume,
657054d4 784 int * vol_len,
dca5a913 785 char * * root,
657054d4 786 int * root_len,
dca5a913 787 char * * dir,
657054d4 788 int * dir_len,
dca5a913 789 char * * name,
657054d4 790 int * name_len,
dca5a913 791 char * * ext,
657054d4 792 int * ext_len,
dca5a913 793 char * * version,
657054d4
JM		 794 int * ver_len)
795{
796struct dsc$descriptor path_desc;
797int status;
798unsigned long flags;
799int ret_stat;
800struct filescan_itmlst_2 item_list[9];
801const int filespec = 0;
802const int nodespec = 1;
803const int devspec = 2;
804const int rootspec = 3;
805const int dirspec = 4;
806const int namespec = 5;
807const int typespec = 6;
808const int verspec = 7;
809
810 /* Assume the worst for an easy exit */
811 ret_stat = -1;
812 *volume = NULL;
813 *vol_len = 0;
814 *root = NULL;
815 *root_len = 0;
816 *dir = NULL;
817 *dir_len;
818 *name = NULL;
819 *name_len = 0;
820 *ext = NULL;
821 *ext_len = 0;
822 *version = NULL;
823 *ver_len = 0;
824
825 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
826 path_desc.dsc$w_length = strlen(path);
827 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
828 path_desc.dsc$b_class = DSC$K_CLASS_S;
829
830 /* Get the total length, if it is shorter than the string passed
831 * then this was probably not a VMS formatted file specification
832 */
833 item_list[filespec].itmcode = FSCN$_FILESPEC;
834 item_list[filespec].length = 0;
835 item_list[filespec].component = NULL;
836
837 /* If the node is present, then it gets considered as part of the
838 * volume name to hopefully make things simple.
839 */
840 item_list[nodespec].itmcode = FSCN$_NODE;
841 item_list[nodespec].length = 0;
842 item_list[nodespec].component = NULL;
843
844 item_list[devspec].itmcode = FSCN$_DEVICE;
845 item_list[devspec].length = 0;
846 item_list[devspec].component = NULL;
847
848 /* root is a special case, adding it to either the directory or
849 * the device components will probalby complicate things for the
850 * callers of this routine, so leave it separate.
851 */
852 item_list[rootspec].itmcode = FSCN$_ROOT;
853 item_list[rootspec].length = 0;
854 item_list[rootspec].component = NULL;
855
856 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
857 item_list[dirspec].length = 0;
858 item_list[dirspec].component = NULL;
859
860 item_list[namespec].itmcode = FSCN$_NAME;
861 item_list[namespec].length = 0;
862 item_list[namespec].component = NULL;
863
864 item_list[typespec].itmcode = FSCN$_TYPE;
865 item_list[typespec].length = 0;
866 item_list[typespec].component = NULL;
867
868 item_list[verspec].itmcode = FSCN$_VERSION;
869 item_list[verspec].length = 0;
870 item_list[verspec].component = NULL;
871
872 item_list[8].itmcode = 0;
873 item_list[8].length = 0;
874 item_list[8].component = NULL;
875
7566800d 876 status = sys$filescan
657054d4
JM		 877 ((const struct dsc$descriptor_s *)&path_desc, item_list,
878 &flags, NULL, NULL);
360732b5 879 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
657054d4
JM		 880
881 /* If we parsed it successfully these two lengths should be the same */
882 if (path_desc.dsc$w_length != item_list[filespec].length)
883 return ret_stat;
884
885 /* If we got here, then it is a VMS file specification */
886 ret_stat = 0;
887
888 /* set the volume name */
889 if (item_list[nodespec].length > 0) {
890 *volume = item_list[nodespec].component;
891 *vol_len = item_list[nodespec].length + item_list[devspec].length;
892 }
893 else {
894 *volume = item_list[devspec].component;
895 *vol_len = item_list[devspec].length;
896 }
897
898 *root = item_list[rootspec].component;
899 *root_len = item_list[rootspec].length;
900
901 *dir = item_list[dirspec].component;
902 *dir_len = item_list[dirspec].length;
903
904 /* Now fun with versions and EFS file specifications
905 * The parser can not tell the difference when a "." is a version
906 * delimiter or a part of the file specification.
907 */
908 if ((decc_efs_charset) &&
909 (item_list[verspec].length > 0) &&
910 (item_list[verspec].component[0] == '.')) {
911 *name = item_list[namespec].component;
912 *name_len = item_list[namespec].length + item_list[typespec].length;
913 *ext = item_list[verspec].component;
914 *ext_len = item_list[verspec].length;
915 *version = NULL;
916 *ver_len = 0;
917 }
918 else {
919 *name = item_list[namespec].component;
920 *name_len = item_list[namespec].length;
921 *ext = item_list[typespec].component;
922 *ext_len = item_list[typespec].length;
923 *version = item_list[verspec].component;
924 *ver_len = item_list[verspec].length;
925 }
926 return ret_stat;
927}
928
df278665
JM		 929/* Routine to determine if the file specification ends with .dir */
930static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
931
932 /* e_len must be 4, and version must be <= 2 characters */
933 if (e_len != 4 || vs_len > 2)
934 return 0;
935
936 /* If a version number is present, it needs to be one */
937 if ((vs_len == 2) && (vs_spec[1] != '1'))
938 return 0;
939
940 /* Look for the DIR on the extension */
941 if (vms_process_case_tolerant) {
942 if ((toupper(e_spec[1]) == 'D') &&
943 (toupper(e_spec[2]) == 'I') &&
944 (toupper(e_spec[3]) == 'R')) {
945 return 1;
946 }
947 } else {
948 /* Directory extensions are supposed to be in upper case only */
949 /* I would not be surprised if this rule can not be enforced */
950 /* if and when someone fully debugs the case sensitive mode */
951 if ((e_spec[1] == 'D') &&
952 (e_spec[2] == 'I') &&
953 (e_spec[3] == 'R')) {
954 return 1;
955 }
956 }
957 return 0;
958}
959
f7ddb74a 960
fa537f88
CB		 961/* my_maxidx
962 * Routine to retrieve the maximum equivalence index for an input
963 * logical name. Some calls to this routine have no knowledge if
964 * the variable is a logical or not. So on error we return a max
965 * index of zero.
966 */
f7ddb74a 967/*{{{int my_maxidx(const char *lnm) */
fa537f88 968static int
f7ddb74a 969my_maxidx(const char *lnm)
fa537f88
CB		 970{
971 int status;
972 int midx;
973 int attr = LNM$M_CASE_BLIND;
974 struct dsc$descriptor lnmdsc;
975 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
976 {0, 0, 0, 0}};
977
978 lnmdsc.dsc$w_length = strlen(lnm);
979 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
980 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 981 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
fa537f88
CB		 982
983 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
984 if ((status & 1) == 0)
985 midx = 0;
986
987 return (midx);
988}
989/*}}}*/
990
f675dbe5 991/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
c07a80fd 992int
fd8cd3a3 993Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
f675dbe5 994 struct dsc$descriptor_s **tabvec, unsigned long int flags)
748a9306 995{
f7ddb74a
JM		 996 const char *cp1;
997 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
f675dbe5 998 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
748a9306 999 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
fa537f88 1000 int midx;
f675dbe5
CB		 1001 unsigned char acmode;
1002 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1003 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1004 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
1005 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
748a9306 1006 {0, 0, 0, 0}};
f675dbe5 1007 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
fd8cd3a3
DS		 1008#if defined(PERL_IMPLICIT_CONTEXT)
1009 pTHX = NULL;
fd8cd3a3
DS		 1010 if (PL_curinterp) {
1011 aTHX = PERL_GET_INTERP;
cc077a9f 1012 } else {
fd8cd3a3 1013 aTHX = NULL;
cc077a9f
HM		 1014 }
1015#endif
748a9306 1016
fa537f88 1017 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
b7ae7a0d 1018 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
1019 }
f7ddb74a 1020 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 1021 *cp2 = _toupper(*cp1);
1022 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1023 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1024 return 0;
1025 }
1026 }
1027 lnmdsc.dsc$w_length = cp1 - lnm;
1028 lnmdsc.dsc$a_pointer = uplnm;
fd7385b9 1029 uplnm[lnmdsc.dsc$w_length] = '\0';
f675dbe5
CB		 1030 secure = flags & PERL__TRNENV_SECURE;
1031 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
1032 if (!tabvec || !*tabvec) tabvec = env_tables;
1033
1034 for (curtab = 0; tabvec[curtab]; curtab++) {
1035 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1036 if (!ivenv && !secure) {
1037 char *eq, *end;
1038 int i;
1039 if (!environ) {
1040 ivenv = 1;
ebd4d70b
JM		 1041#if defined(PERL_IMPLICIT_CONTEXT)
1042 if (aTHX == NULL) {
1043 fprintf(stderr,
1044 "%%PERL-W-VMS_INIT Can't read CRTL environ\n");
1045 } else
1046#endif
1047 Perl_warn(aTHX_ "Can't read CRTL environ\n");
f675dbe5
CB		 1048 continue;
1049 }
1050 retsts = SS$_NOLOGNAM;
1051 for (i = 0; environ[i]; i++) {
1052 if ((eq = strchr(environ[i],'=')) &&
299d126a 1053 lnmdsc.dsc$w_length == (eq - environ[i]) &&
f675dbe5
CB		 1054 !strncmp(environ[i],uplnm,eq - environ[i])) {
1055 eq++;
1056 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
1057 if (!eqvlen) continue;
1058 retsts = SS$_NORMAL;
1059 break;
1060 }
1061 }
1062 if (retsts != SS$_NOLOGNAM) break;
1063 }
1064 }
1065 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1066 !str$case_blind_compare(&tmpdsc,&clisym)) {
1067 if (!ivsym && !secure) {
1068 unsigned short int deflen = LNM$C_NAMLENGTH;
1069 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1070 /* dynamic dsc to accomodate possible long value */
ebd4d70b 1071 _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
f675dbe5
CB		 1072 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1073 if (retsts & 1) {
2497a41f 1074 if (eqvlen > MAX_DCL_SYMBOL) {
f675dbe5 1075 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
2497a41f 1076 eqvlen = MAX_DCL_SYMBOL;
cc077a9f
HM		 1077 /* Special hack--we might be called before the interpreter's */
1078 /* fully initialized, in which case either thr or PL_curcop */
1079 /* might be bogus. We have to check, since ckWARN needs them */
1080 /* both to be valid if running threaded */
8a646e0b
JM		 1081#if defined(PERL_IMPLICIT_CONTEXT)
1082 if (aTHX == NULL) {
1083 fprintf(stderr,
1084 "%Perl-VMS-Init, Value of CLI symbol \"%s\" too long",lnm);
1085 } else
1086#endif
cc077a9f 1087 if (ckWARN(WARN_MISC)) {
f98bc0c6 1088 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
cc077a9f 1089 }
f675dbe5
CB		 1090 }
1091 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1092 }
ebd4d70b 1093 _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
f675dbe5
CB		 1094 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1095 if (retsts == LIB$_NOSUCHSYM) continue;
1096 break;
1097 }
1098 }
1099 else if (!ivlnm) {
843027b0 1100 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
f7ddb74a
JM		 1101 midx = my_maxidx(lnm);
1102 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1103 lnmlst[1].bufadr = cp2;
fa537f88
CB		 1104 eqvlen = 0;
1105 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1106 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1107 if (retsts == SS$_NOLOGNAM) break;
1108 /* PPFs have a prefix */
1109 if (
fd7385b9 1110#if INTSIZE == 4
fa537f88 1111 *((int *)uplnm) == *((int *)"SYS$") &&
fd7385b9 1112#endif
fa537f88
CB		 1113 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1114 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1115 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1116 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1117 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
18a3d61e 1118 memmove(eqv,eqv+4,eqvlen-4);
fa537f88
CB		 1119 eqvlen -= 4;
1120 }
f7ddb74a
JM		 1121 cp2 += eqvlen;
1122 *cp2 = '\0';
fa537f88
CB		 1123 }
1124 if ((retsts == SS$_IVLOGNAM) ||
1125 (retsts == SS$_NOLOGNAM)) { continue; }
fd7385b9 1126 }
fa537f88 1127 else {
fa537f88
CB		 1128 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1129 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1130 if (retsts == SS$_NOLOGNAM) continue;
1131 eqv[eqvlen] = '\0';
1132 }
1133 eqvlen = strlen(eqv);
f675dbe5
CB		 1134 break;
1135 }
c07a80fd 1136 }
f675dbe5
CB		 1137 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1138 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1139 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1140 retsts == SS$_NOLOGNAM) {
1141 set_errno(EINVAL); set_vaxc_errno(retsts);
748a9306 1142 }
ebd4d70b 1143 else _ckvmssts_noperl(retsts);
f675dbe5
CB		 1144 return 0;
1145} /* end of vmstrnenv */
1146/*}}}*/
c07a80fd 1147
f675dbe5
CB		 1148/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1149/* Define as a function so we can access statics. */
4b19af01 1150int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
f675dbe5 1151{
8a646e0b
JM		 1152 int flags = 0;
1153
1154#if defined(PERL_IMPLICIT_CONTEXT)
1155 if (aTHX != NULL)
1156#endif
f675dbe5 1157#ifdef SECURE_INTERNAL_GETENV
8a646e0b
JM		 1158 flags = (PL_curinterp ? PL_tainting : will_taint) ?
1159 PERL__TRNENV_SECURE : 0;
f675dbe5 1160#endif
8a646e0b
JM		 1161
1162 return vmstrnenv(lnm, eqv, idx, fildev, flags);
f675dbe5
CB		 1163}
1164/*}}}*/
a0d0e21e
LW		 1165
1166/* my_getenv
61bb5906
CB		 1167 * Note: Uses Perl temp to store result so char * can be returned to
1168 * caller; this pointer will be invalidated at next Perl statement
1169 * transition.
a6c40364 1170 * We define this as a function rather than a macro in terms of my_getenv_len()
f675dbe5
CB		 1171 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1172 * allocate SVs).
a0d0e21e 1173 */
f675dbe5 1174/*{{{ char *my_getenv(const char *lnm, bool sys)*/
a0d0e21e 1175char *
5c84aa53 1176Perl_my_getenv(pTHX_ const char *lnm, bool sys)
a0d0e21e 1177{
f7ddb74a 1178 const char *cp1;
fa537f88 1179 static char *__my_getenv_eqv = NULL;
f7ddb74a 1180 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
c07a80fd 1181 unsigned long int idx = 0;
bc10a425 1182 int trnsuccess, success, secure, saverr, savvmserr;
843027b0 1183 int midx, flags;
61bb5906 1184 SV *tmpsv;
a0d0e21e 1185
f7ddb74a 1186 midx = my_maxidx(lnm) + 1;
fa537f88 1187
6b88bc9c 1188 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
61bb5906
CB		 1189 /* Set up a temporary buffer for the return value; Perl will
1190 * clean it up at the next statement transition */
fa537f88 1191 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
61bb5906
CB		 1192 if (!tmpsv) return NULL;
1193 eqv = SvPVX(tmpsv);
1194 }
fa537f88
CB		 1195 else {
1196 /* Assume no interpreter ==> single thread */
1197 if (__my_getenv_eqv != NULL) {
1198 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1199 }
1200 else {
a02a5408 1201 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1202 }
1203 eqv = __my_getenv_eqv;
1204 }
1205
f7ddb74a 1206 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1207 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
2497a41f 1208 int len;
61bb5906 1209 getcwd(eqv,LNM$C_NAMLENGTH);
2497a41f
JM		 1210
1211 len = strlen(eqv);
1212
1213 /* Get rid of "000000/ in rooted filespecs */
1214 if (len > 7) {
1215 char * zeros;
1216 zeros = strstr(eqv, "/000000/");
1217 if (zeros != NULL) {
1218 int mlen;
1219 mlen = len - (zeros - eqv) - 7;
1220 memmove(zeros, &zeros[7], mlen);
1221 len = len - 7;
1222 eqv[len] = '\0';
1223 }
1224 }
61bb5906 1225 return eqv;
748a9306 1226 }
a0d0e21e 1227 else {
2512681b 1228 /* Impose security constraints only if tainting */
bc10a425
CB		 1229 if (sys) {
1230 /* Impose security constraints only if tainting */
1231 secure = PL_curinterp ? PL_tainting : will_taint;
1232 saverr = errno; savvmserr = vaxc$errno;
1233 }
843027b0
CB		 1234 else {
1235 secure = 0;
1236 }
1237
1238 flags =
f675dbe5 1239#ifdef SECURE_INTERNAL_GETENV
843027b0 1240 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1241#else
843027b0 1242 0
f675dbe5 1243#endif
843027b0
CB		 1244 ;
1245
1246 /* For the getenv interface we combine all the equivalence names
1247 * of a search list logical into one value to acquire a maximum
1248 * value length of 255*128 (assuming %ENV is using logicals).
1249 */
1250 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1251
1252 /* If the name contains a semicolon-delimited index, parse it
1253 * off and make sure we only retrieve the equivalence name for
1254 * that index. */
1255 if ((cp2 = strchr(lnm,';')) != NULL) {
1256 strcpy(uplnm,lnm);
1257 uplnm[cp2-lnm] = '\0';
1258 idx = strtoul(cp2+1,NULL,0);
1259 lnm = uplnm;
1260 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1261 }
1262
1263 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1264
bc10a425
CB		 1265 /* Discard NOLOGNAM on internal calls since we're often looking
1266 * for an optional name, and this "error" often shows up as the
1267 * (bogus) exit status for a die() call later on. */
1268 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
4e205ed6 1269 return success ? eqv : NULL;
a0d0e21e 1270 }
a0d0e21e
LW		 1271
1272} /* end of my_getenv() */
1273/*}}}*/
1274
f675dbe5 1275
a6c40364
GS		 1276/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1277char *
fd8cd3a3 1278Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
f675dbe5 1279{
f7ddb74a
JM		 1280 const char *cp1;
1281 char *buf, *cp2;
a6c40364 1282 unsigned long idx = 0;
843027b0 1283 int midx, flags;
fa537f88 1284 static char *__my_getenv_len_eqv = NULL;
bc10a425 1285 int secure, saverr, savvmserr;
cc077a9f
HM		 1286 SV *tmpsv;
1287
f7ddb74a 1288 midx = my_maxidx(lnm) + 1;
fa537f88 1289
cc077a9f
HM		 1290 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1291 /* Set up a temporary buffer for the return value; Perl will
1292 * clean it up at the next statement transition */
fa537f88 1293 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
cc077a9f
HM		 1294 if (!tmpsv) return NULL;
1295 buf = SvPVX(tmpsv);
1296 }
fa537f88
CB		 1297 else {
1298 /* Assume no interpreter ==> single thread */
1299 if (__my_getenv_len_eqv != NULL) {
1300 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1301 }
1302 else {
a02a5408 1303 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1304 }
1305 buf = __my_getenv_len_eqv;
1306 }
1307
f7ddb74a 1308 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1309 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
f7ddb74a
JM		 1310 char * zeros;
1311
f675dbe5 1312 getcwd(buf,LNM$C_NAMLENGTH);
a6c40364 1313 *len = strlen(buf);
f7ddb74a
JM		 1314
1315 /* Get rid of "000000/ in rooted filespecs */
1316 if (*len > 7) {
1317 zeros = strstr(buf, "/000000/");
1318 if (zeros != NULL) {
1319 int mlen;
1320 mlen = *len - (zeros - buf) - 7;
1321 memmove(zeros, &zeros[7], mlen);
1322 *len = *len - 7;
1323 buf[*len] = '\0';
1324 }
1325 }
a6c40364 1326 return buf;
f675dbe5
CB		 1327 }
1328 else {
bc10a425
CB		 1329 if (sys) {
1330 /* Impose security constraints only if tainting */
1331 secure = PL_curinterp ? PL_tainting : will_taint;
1332 saverr = errno; savvmserr = vaxc$errno;
1333 }
843027b0
CB		 1334 else {
1335 secure = 0;
1336 }
1337
1338 flags =
f675dbe5 1339#ifdef SECURE_INTERNAL_GETENV
843027b0 1340 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1341#else
843027b0 1342 0
f675dbe5 1343#endif
843027b0
CB		 1344 ;
1345
1346 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1347
1348 if ((cp2 = strchr(lnm,';')) != NULL) {
1349 strcpy(buf,lnm);
1350 buf[cp2-lnm] = '\0';
1351 idx = strtoul(cp2+1,NULL,0);
1352 lnm = buf;
1353 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1354 }
1355
1356 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1357
f7ddb74a
JM		 1358 /* Get rid of "000000/ in rooted filespecs */
1359 if (*len > 7) {
1360 char * zeros;
1361 zeros = strstr(buf, "/000000/");
1362 if (zeros != NULL) {
1363 int mlen;
1364 mlen = *len - (zeros - buf) - 7;
1365 memmove(zeros, &zeros[7], mlen);
1366 *len = *len - 7;
1367 buf[*len] = '\0';
1368 }
1369 }
1370
bc10a425
CB		 1371 /* Discard NOLOGNAM on internal calls since we're often looking
1372 * for an optional name, and this "error" often shows up as the
1373 * (bogus) exit status for a die() call later on. */
1374 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
4e205ed6 1375 return *len ? buf : NULL;
f675dbe5
CB		 1376 }
1377
a6c40364 1378} /* end of my_getenv_len() */
f675dbe5
CB		 1379/*}}}*/
1380
8a646e0b 1381static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
8fde5078
CB		 1382
1383static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1e422769 1384
740ce14c 1385/*{{{ void prime_env_iter() */
1386void
1387prime_env_iter(void)
1388/* Fill the %ENV associative array with all logical names we can
1389 * find, in preparation for iterating over it.
1390 */
1391{
17f28c40 1392 static int primed = 0;
3eeba6fb 1393 HV *seenhv = NULL, *envhv;
22be8b3c 1394 SV *sv = NULL;
4e205ed6 1395 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
8fde5078
CB		 1396 unsigned short int chan;
1397#ifndef CLI$M_TRUSTED
1398# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1399#endif
f675dbe5
CB		 1400 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1401 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1402 long int i;
1403 bool have_sym = FALSE, have_lnm = FALSE;
1404 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1405 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1406 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1407 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1408 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
fd8cd3a3
DS		 1409#if defined(PERL_IMPLICIT_CONTEXT)
1410 pTHX;
1411#endif
3db8f154 1412#if defined(USE_ITHREADS)
b2b3adea
HM		 1413 static perl_mutex primenv_mutex;
1414 MUTEX_INIT(&primenv_mutex);
61bb5906 1415#endif
740ce14c 1416
fd8cd3a3
DS		 1417#if defined(PERL_IMPLICIT_CONTEXT)
1418 /* We jump through these hoops because we can be called at */
1419 /* platform-specific initialization time, which is before anything is */
1420 /* set up--we can't even do a plain dTHX since that relies on the */
1421 /* interpreter structure to be initialized */
fd8cd3a3
DS		 1422 if (PL_curinterp) {
1423 aTHX = PERL_GET_INTERP;
1424 } else {
ebd4d70b
JM		 1425 /* we never get here because the NULL pointer will cause the */
1426 /* several of the routines called by this routine to access violate */
1427
1428 /* This routine is only called by hv.c/hv_iterinit which has a */
1429 /* context, so the real fix may be to pass it through instead of */
1430 /* the hoops above */
fd8cd3a3
DS		 1431 aTHX = NULL;
1432 }
1433#endif
fd8cd3a3 1434
3eeba6fb 1435 if (primed || !PL_envgv) return;
61bb5906
CB		 1436 MUTEX_LOCK(&primenv_mutex);
1437 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
3eeba6fb 1438 envhv = GvHVn(PL_envgv);
740ce14c 1439 /* Perform a dummy fetch as an lval to insure that the hash table is
8fde5078 1440 * set up. Otherwise, the hv_store() will turn into a nullop. */
740ce14c 1441 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
740ce14c 1442
f675dbe5
CB		 1443 for (i = 0; env_tables[i]; i++) {
1444 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1445 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
f02a1854 1446 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
8fde5078 1447 }
f675dbe5
CB		 1448 if (have_sym || have_lnm) {
1449 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1450 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1451 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1452 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
61bb5906 1453 }
f675dbe5
CB		 1454
1455 for (i--; i >= 0; i--) {
1456 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1457 char *start;
1458 int j;
1459 for (j = 0; environ[j]; j++) {
1460 if (!(start = strchr(environ[j],'='))) {
3eeba6fb 1461 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1462 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
f675dbe5
CB		 1463 }
1464 else {
1465 start++;
22be8b3c
CB		 1466 sv = newSVpv(start,0);
1467 SvTAINTED_on(sv);
1468 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
f675dbe5
CB		 1469 }
1470 }
1471 continue;
740ce14c 1472 }
f675dbe5
CB		 1473 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1474 !str$case_blind_compare(&tmpdsc,&clisym)) {
1475 strcpy(cmd,"Show Symbol/Global *");
1476 cmddsc.dsc$w_length = 20;
1477 if (env_tables[i]->dsc$w_length == 12 &&
1478 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1479 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1480 flags = defflags | CLI$M_NOLOGNAM;
1481 }
1482 else {
1483 strcpy(cmd,"Show Logical *");
1484 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1485 strcat(cmd," /Table=");
1486 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1487 cmddsc.dsc$w_length = strlen(cmd);
1488 }
1489 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1490 flags = defflags | CLI$M_NOCLISYM;
1491 }
1492
1493 /* Create a new subprocess to execute each command, to exclude the
1494 * remote possibility that someone could subvert a mbx or file used
1495 * to write multiple commands to a single subprocess.
1496 */
1497 do {
1498 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1499 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1500 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1501 defflags &= ~CLI$M_TRUSTED;
1502 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1503 _ckvmssts(retsts);
a02a5408 1504 if (!buf) Newx(buf,mbxbufsiz + 1,char);
f675dbe5
CB		 1505 if (seenhv) SvREFCNT_dec(seenhv);
1506 seenhv = newHV();
1507 while (1) {
1508 char *cp1, *cp2, *key;
1509 unsigned long int sts, iosb[2], retlen, keylen;
1510 register U32 hash;
1511
1512 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1513 if (sts & 1) sts = iosb[0] & 0xffff;
1514 if (sts == SS$_ENDOFFILE) {
1515 int wakect = 0;
1516 while (substs == 0) { sys$hiber(); wakect++;}
1517 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1518 _ckvmssts(substs);
1519 break;
1520 }
1521 _ckvmssts(sts);
1522 retlen = iosb[0] >> 16;
1523 if (!retlen) continue; /* blank line */
1524 buf[retlen] = '\0';
1525 if (iosb[1] != subpid) {
1526 if (iosb[1]) {
5c84aa53 1527 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
f675dbe5
CB		 1528 }
1529 continue;
1530 }
3eeba6fb 1531 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
f98bc0c6 1532 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
f675dbe5
CB		 1533
1534 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1535 if (*cp1 == '(' || /* Logical name table name */
1536 *cp1 == '=' /* Next eqv of searchlist */) continue;
1537 if (*cp1 == '"') cp1++;
1538 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1539 key = cp1; keylen = cp2 - cp1;
1540 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1541 while (*cp2 && *cp2 != '=') cp2++;
1f47e8e2
CB		 1542 while (*cp2 && *cp2 == '=') cp2++;
1543 while (*cp2 && *cp2 == ' ') cp2++;
1544 if (*cp2 == '"') { /* String translation; may embed "" */
1545 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1546 cp2++; cp1--; /* Skip "" surrounding translation */
1547 }
1548 else { /* Numeric translation */
1549 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1550 cp1--; /* stop on last non-space char */
1551 }
1552 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
f98bc0c6 1553 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
edc7bc49
CB		 1554 continue;
1555 }
5afd6d42 1556 PERL_HASH(hash,key,keylen);
ff79d39d
CB		 1557
1558 if (cp1 == cp2 && *cp2 == '.') {
1559 /* A single dot usually means an unprintable character, such as a null
1560 * to indicate a zero-length value. Get the actual value to make sure.
1561 */
1562 char lnm[LNM$C_NAMLENGTH+1];
2497a41f 1563 char eqv[MAX_DCL_SYMBOL+1];
0faef845 1564 int trnlen;
ff79d39d 1565 strncpy(lnm, key, keylen);
0faef845 1566 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
ff79d39d
CB		 1567 sv = newSVpvn(eqv, strlen(eqv));
1568 }
1569 else {
1570 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1571 }
1572
22be8b3c
CB		 1573 SvTAINTED_on(sv);
1574 hv_store(envhv,key,keylen,sv,hash);
f675dbe5 1575 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
edc7bc49 1576 }
f675dbe5
CB		 1577 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1578 /* get the PPFs for this process, not the subprocess */
f7ddb74a 1579 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
f675dbe5
CB		 1580 char eqv[LNM$C_NAMLENGTH+1];
1581 int trnlen, i;
1582 for (i = 0; ppfs[i]; i++) {
1583 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
22be8b3c
CB		 1584 sv = newSVpv(eqv,trnlen);
1585 SvTAINTED_on(sv);
1586 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
f675dbe5 1587 }
740ce14c 1588 }
1589 }
f675dbe5
CB		 1590 primed = 1;
1591 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1592 if (buf) Safefree(buf);
1593 if (seenhv) SvREFCNT_dec(seenhv);
1594 MUTEX_UNLOCK(&primenv_mutex);
1595 return;
1596
740ce14c 1597} /* end of prime_env_iter */
1598/*}}}*/
740ce14c 1599
f675dbe5 1600
2c590a56 1601/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1602/* Define or delete an element in the same "environment" as
1603 * vmstrnenv(). If an element is to be deleted, it's removed from
1604 * the first place it's found. If it's to be set, it's set in the
1605 * place designated by the first element of the table vector.
3eeba6fb 1606 * Like setenv() returns 0 for success, non-zero on error.
a0d0e21e 1607 */
f675dbe5 1608int
2c590a56 1609Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
a0d0e21e 1610{
f7ddb74a
JM		 1611 const char *cp1;
1612 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
f675dbe5 1613 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
fa537f88 1614 int nseg = 0, j;
a0d0e21e 1615 unsigned long int retsts, usermode = PSL$C_USER;
fa537f88 1616 struct itmlst_3 *ile, *ilist;
a0d0e21e 1617 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
f675dbe5
CB		 1618 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1619 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1620 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1621 $DESCRIPTOR(local,"_LOCAL");
1622
ed253963
CB		 1623 if (!lnm) {
1624 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1625 return SS$_IVLOGNAM;
1626 }
1627
f7ddb74a 1628 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 1629 *cp2 = _toupper(*cp1);
1630 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1631 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1632 return SS$_IVLOGNAM;
1633 }
1634 }
a0d0e21e 1635 lnmdsc.dsc$w_length = cp1 - lnm;
f675dbe5
CB		 1636 if (!tabvec || !*tabvec) tabvec = env_tables;
1637
3eeba6fb 1638 if (!eqv) { /* we're deleting n element */
f675dbe5
CB		 1639 for (curtab = 0; tabvec[curtab]; curtab++) {
1640 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1641 int i;
299d126a 1642 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
f675dbe5 1643 if ((cp1 = strchr(environ[i],'=')) &&
299d126a 1644 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
f675dbe5 1645 !strncmp(environ[i],lnm,cp1 - environ[i])) {
3eeba6fb 1646#ifdef HAS_SETENV
0e06870b 1647 return setenv(lnm,"",1) ? vaxc$errno : 0;
f675dbe5
CB		 1648 }
1649 }
1650 ivenv = 1; retsts = SS$_NOLOGNAM;
1651#else
3eeba6fb 1652 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1653 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
3eeba6fb
CB		 1654 ivenv = 1; retsts = SS$_NOSUCHPGM;
1655 break;
1656 }
1657 }
f675dbe5
CB		 1658#endif
1659 }
1660 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1661 !str$case_blind_compare(&tmpdsc,&clisym)) {
1662 unsigned int symtype;
1663 if (tabvec[curtab]->dsc$w_length == 12 &&
1664 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1665 !str$case_blind_compare(&tmpdsc,&local))
1666 symtype = LIB$K_CLI_LOCAL_SYM;
1667 else symtype = LIB$K_CLI_GLOBAL_SYM;
1668 retsts = lib$delete_symbol(&lnmdsc,&symtype);
3eeba6fb
CB		 1669 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1670 if (retsts == LIB$_NOSUCHSYM) continue;
f675dbe5
CB		 1671 break;
1672 }
1673 else if (!ivlnm) {
1674 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1675 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1676 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1677 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1678 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1679 }
a0d0e21e
LW		 1680 }
1681 }
f675dbe5
CB		 1682 else { /* we're defining a value */
1683 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1684#ifdef HAS_SETENV
3eeba6fb 1685 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
f675dbe5 1686#else
3eeba6fb 1687 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1688 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
f675dbe5
CB		 1689 retsts = SS$_NOSUCHPGM;
1690#endif
1691 }
1692 else {
f7ddb74a 1693 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
f675dbe5
CB		 1694 eqvdsc.dsc$w_length = strlen(eqv);
1695 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1696 !str$case_blind_compare(&tmpdsc,&clisym)) {
1697 unsigned int symtype;
1698 if (tabvec[0]->dsc$w_length == 12 &&
1699 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1700 !str$case_blind_compare(&tmpdsc,&local))
1701 symtype = LIB$K_CLI_LOCAL_SYM;
1702 else symtype = LIB$K_CLI_GLOBAL_SYM;
1703 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1704 }
3eeba6fb
CB		 1705 else {
1706 if (!*eqv) eqvdsc.dsc$w_length = 1;
a1dfe751 1707 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
fa537f88
CB		 1708
1709 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1710 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1711 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1712 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1713 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1714 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1715 }
1716
a02a5408 1717 Newx(ilist,nseg+1,struct itmlst_3);
fa537f88
CB		 1718 ile = ilist;
1719 if (!ile) {
1720 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1721 return SS$_INSFMEM;
a1dfe751 1722 }
fa537f88
CB		 1723 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1724
1725 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1726 ile->itmcode = LNM$_STRING;
1727 ile->bufadr = c;
1728 if ((j+1) == nseg) {
1729 ile->buflen = strlen(c);
1730 /* in case we are truncating one that's too long */
1731 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1732 }
1733 else {
1734 ile->buflen = LNM$C_NAMLENGTH;
1735 }
1736 }
1737
1738 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1739 Safefree (ilist);
1740 }
1741 else {
1742 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
a1dfe751 1743 }
3eeba6fb 1744 }
f675dbe5
CB		 1745 }
1746 }
1747 if (!(retsts & 1)) {
1748 switch (retsts) {
1749 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1750 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1751 set_errno(EVMSERR); break;
1752 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1753 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1754 set_errno(EINVAL); break;
1755 case SS$_NOPRIV:
7d2497bf 1756 set_errno(EACCES); break;
f675dbe5
CB		 1757 default:
1758 _ckvmssts(retsts);
1759 set_errno(EVMSERR);
1760 }
1761 set_vaxc_errno(retsts);
1762 return (int) retsts || 44; /* retsts should never be 0, but just in case */
a0d0e21e 1763 }
3eeba6fb
CB		 1764 else {
1765 /* We reset error values on success because Perl does an hv_fetch()
1766 * before each hv_store(), and if the thing we're setting didn't
1767 * previously exist, we've got a leftover error message. (Of course,
1768 * this fails in the face of
1769 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1770 * in that the error reported in $! isn't spurious,
1771 * but it's right more often than not.)
1772 */
f675dbe5
CB		 1773 set_errno(0); set_vaxc_errno(retsts);
1774 return 0;
1775 }
1776
1777} /* end of vmssetenv() */
1778/*}}}*/
a0d0e21e 1779
2c590a56 1780/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1781/* This has to be a function since there's a prototype for it in proto.h */
1782void
2c590a56 1783Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
f675dbe5 1784{
bc10a425
CB		 1785 if (lnm && *lnm) {
1786 int len = strlen(lnm);
1787 if (len == 7) {
1788 char uplnm[8];
22d4bb9c
CB		 1789 int i;
1790 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
bc10a425 1791 if (!strcmp(uplnm,"DEFAULT")) {
7ded3206 1792 if (eqv && *eqv) my_chdir(eqv);
bc10a425
CB		 1793 return;
1794 }
1795 }
1796#ifndef RTL_USES_UTC
1797 if (len == 6 || len == 2) {
1798 char uplnm[7];
1799 int i;
1800 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1801 uplnm[len] = '\0';
1802 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1803 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
22d4bb9c
CB		 1804 }
1805#endif
1806 }
f675dbe5
CB		 1807 (void) vmssetenv(lnm,eqv,NULL);
1808}
a0d0e21e
LW		 1809/*}}}*/
1810
27c67b75 1811/*{{{static void vmssetuserlnm(char *name, char *eqv); */
0e06870b
CB		 1812/* vmssetuserlnm
1813 * sets a user-mode logical in the process logical name table
1814 * used for redirection of sys$error
1815 */
1816void
2fbb330f 1817Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
0e06870b
CB		 1818{
1819 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1820 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
2d5e9e5d 1821 unsigned long int iss, attr = LNM$M_CONFINE;
0e06870b
CB		 1822 unsigned char acmode = PSL$C_USER;
1823 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1824 {0, 0, 0, 0}};
2fbb330f 1825 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
0e06870b
CB		 1826 d_name.dsc$w_length = strlen(name);
1827
1828 lnmlst[0].buflen = strlen(eqv);
2fbb330f 1829 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
0e06870b
CB		 1830
1831 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1832 if (!(iss&1)) lib$signal(iss);
1833}
1834/*}}}*/
c07a80fd 1835
f675dbe5 1836
c07a80fd 1837/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1838/* my_crypt - VMS password hashing
1839 * my_crypt() provides an interface compatible with the Unix crypt()
1840 * C library function, and uses sys$hash_password() to perform VMS
1841 * password hashing. The quadword hashed password value is returned
1842 * as a NUL-terminated 8 character string. my_crypt() does not change
1843 * the case of its string arguments; in order to match the behavior
1844 * of LOGINOUT et al., alphabetic characters in both arguments must
1845 * be upcased by the caller.
2497a41f
JM		 1846 *
1847 * - fix me to call ACM services when available
c07a80fd 1848 */
1849char *
fd8cd3a3 1850Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd 1851{
1852# ifndef UAI$C_PREFERRED_ALGORITHM
1853# define UAI$C_PREFERRED_ALGORITHM 127
1854# endif
1855 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1856 unsigned short int salt = 0;
1857 unsigned long int sts;
1858 struct const_dsc {
1859 unsigned short int dsc$w_length;
1860 unsigned char dsc$b_type;
1861 unsigned char dsc$b_class;
1862 const char * dsc$a_pointer;
1863 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1864 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1865 struct itmlst_3 uailst[3] = {
1866 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1867 { sizeof salt, UAI$_SALT, &salt, 0},
1868 { 0, 0, NULL, NULL}};
1869 static char hash[9];
1870
1871 usrdsc.dsc$w_length = strlen(usrname);
1872 usrdsc.dsc$a_pointer = usrname;
1873 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1874 switch (sts) {
f282b18d 1875 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
c07a80fd 1876 set_errno(EACCES);
1877 break;
1878 case RMS$_RNF:
1879 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1880 break;
1881 default:
1882 set_errno(EVMSERR);
1883 }
1884 set_vaxc_errno(sts);
1885 if (sts != RMS$_RNF) return NULL;
1886 }
1887
1888 txtdsc.dsc$w_length = strlen(textpasswd);
1889 txtdsc.dsc$a_pointer = textpasswd;
1890 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1891 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1892 }
1893
1894 return (char *) hash;
1895
1896} /* end of my_crypt() */
1897/*}}}*/
1898
1899
360732b5
JM		 1900static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1901static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1902static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
a0d0e21e 1903
2497a41f
JM		 1904/* fixup barenames that are directories for internal use.
1905 * There have been problems with the consistent handling of UNIX
1906 * style directory names when routines are presented with a name that
1907 * has no directory delimitors at all. So this routine will eventually
1908 * fix the issue.
1909 */
1910static char * fixup_bare_dirnames(const char * name)
1911{
1912 if (decc_disable_to_vms_logname_translation) {
1913/* fix me */
1914 }
1915 return NULL;
1916}
1917
e0e5e8d6
JM		 1918/* 8.3, remove() is now broken on symbolic links */
1919static int rms_erase(const char * vmsname);
1920
1921
2497a41f
JM		 1922/* mp_do_kill_file
1923 * A little hack to get around a bug in some implemenation of remove()
1924 * that do not know how to delete a directory
1925 *
1926 * Delete any file to which user has control access, regardless of whether
1927 * delete access is explicitly allowed.
1928 * Limitations: User must have write access to parent directory.
1929 * Does not block signals or ASTs; if interrupted in midstream
1930 * may leave file with an altered ACL.
1931 * HANDLE WITH CARE!
1932 */
1933/*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1934static int
1935mp_do_kill_file(pTHX_ const char *name, int dirflag)
1936{
e0e5e8d6
JM		 1937 char *vmsname;
1938 char *rslt;
2497a41f
JM		 1939 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1940 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1941 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1942 struct myacedef {
1943 unsigned char myace$b_length;
1944 unsigned char myace$b_type;
1945 unsigned short int myace$w_flags;
1946 unsigned long int myace$l_access;
1947 unsigned long int myace$l_ident;
1948 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1949 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1950 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1951 struct itmlst_3
1952 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1953 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1954 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1955 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1956 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1957 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1958
1959 /* Expand the input spec using RMS, since the CRTL remove() and
1960 * system services won't do this by themselves, so we may miss
1961 * a file "hiding" behind a logical name or search list. */
c5375c28 1962 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
ebd4d70b 1963 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 1964
e0e5e8d6
JM		 1965 rslt = do_rmsexpand(name,
1966 vmsname,
1967 0,
1968 NULL,
1969 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1970 NULL,
1971 NULL);
1972 if (rslt == NULL) {
c5375c28 1973 PerlMem_free(vmsname);
2497a41f
JM		 1974 return -1;
1975 }
c5375c28 1976
e0e5e8d6
JM		 1977 /* Erase the file */
1978 rmsts = rms_erase(vmsname);
2497a41f 1979
e0e5e8d6
JM		 1980 /* Did it succeed */
1981 if ($VMS_STATUS_SUCCESS(rmsts)) {
1982 PerlMem_free(vmsname);
1983 return 0;
2497a41f
JM		 1984 }
1985
1986 /* If not, can changing protections help? */
e0e5e8d6
JM		 1987 if (rmsts != RMS$_PRV) {
1988 set_vaxc_errno(rmsts);
1989 PerlMem_free(vmsname);
2497a41f
JM		 1990 return -1;
1991 }
1992
1993 /* No, so we get our own UIC to use as a rights identifier,
1994 * and the insert an ACE at the head of the ACL which allows us
1995 * to delete the file.
1996 */
ebd4d70b 1997 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
e0e5e8d6
JM		 1998 fildsc.dsc$w_length = strlen(vmsname);
1999 fildsc.dsc$a_pointer = vmsname;
2497a41f
JM		 2000 cxt = 0;
2001 newace.myace$l_ident = oldace.myace$l_ident;
e0e5e8d6 2002 rmsts = -1;
2497a41f
JM		 2003 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2004 switch (aclsts) {
2005 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2006 set_errno(ENOENT); break;
2007 case RMS$_DIR:
2008 set_errno(ENOTDIR); break;
2009 case RMS$_DEV:
2010 set_errno(ENODEV); break;
2011 case RMS$_SYN: case SS$_INVFILFOROP:
2012 set_errno(EINVAL); break;
2013 case RMS$_PRV:
2014 set_errno(EACCES); break;
2015 default:
ebd4d70b 2016 _ckvmssts_noperl(aclsts);
2497a41f
JM		 2017 }
2018 set_vaxc_errno(aclsts);
e0e5e8d6 2019 PerlMem_free(vmsname);
2497a41f
JM		 2020 return -1;
2021 }
2022 /* Grab any existing ACEs with this identifier in case we fail */
2023 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2024 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2025 || fndsts == SS$_NOMOREACE ) {
2026 /* Add the new ACE . . . */
2027 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2028 goto yourroom;
2029
e0e5e8d6
JM		 2030 rmsts = rms_erase(vmsname);
2031 if ($VMS_STATUS_SUCCESS(rmsts)) {
2032 rmsts = 0;
2497a41f
JM		 2033 }
2034 else {
e0e5e8d6 2035 rmsts = -1;
2497a41f
JM		 2036 /* We blew it - dir with files in it, no write priv for
2037 * parent directory, etc. Put things back the way they were. */
2038 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2039 goto yourroom;
2040 if (fndsts & 1) {
2041 addlst[0].bufadr = &oldace;
2042 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2043 goto yourroom;
2044 }
2045 }
2046 }
2047
2048 yourroom:
2049 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2050 /* We just deleted it, so of course it's not there. Some versions of
2051 * VMS seem to return success on the unlock operation anyhow (after all
2052 * the unlock is successful), but others don't.
2053 */
2054 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2055 if (aclsts & 1) aclsts = fndsts;
2056 if (!(aclsts & 1)) {
2057 set_errno(EVMSERR);
2058 set_vaxc_errno(aclsts);
2497a41f
JM		 2059 }
2060
e0e5e8d6 2061 PerlMem_free(vmsname);
2497a41f
JM		 2062 return rmsts;
2063
2064} /* end of kill_file() */
2065/*}}}*/
2066
2067
a0d0e21e
LW		 2068/*{{{int do_rmdir(char *name)*/
2069int
b8ffc8df 2070Perl_do_rmdir(pTHX_ const char *name)
a0d0e21e 2071{
e0e5e8d6 2072 char * dirfile;
a0d0e21e 2073 int retval;
61bb5906 2074 Stat_t st;
a0d0e21e 2075
e0e5e8d6
JM		 2076 dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
2077 if (dirfile == NULL)
2078 _ckvmssts(SS$_INSFMEM);
2079
2080 /* Force to a directory specification */
2081 if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
2082 PerlMem_free(dirfile);
2083 return -1;
2084 }
dffb32cf 2085 if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
e0e5e8d6
JM		 2086 errno = ENOTDIR;
2087 retval = -1;
2088 }
2089 else
2090 retval = mp_do_kill_file(aTHX_ dirfile, 1);
2091
2092 PerlMem_free(dirfile);
a0d0e21e
LW		 2093 return retval;
2094
2095} /* end of do_rmdir */
2096/*}}}*/
2097
2098/* kill_file
2099 * Delete any file to which user has control access, regardless of whether
2100 * delete access is explicitly allowed.
2101 * Limitations: User must have write access to parent directory.
2102 * Does not block signals or ASTs; if interrupted in midstream
2103 * may leave file with an altered ACL.
2104 * HANDLE WITH CARE!
2105 */
2106/*{{{int kill_file(char *name)*/
2107int
b8ffc8df 2108Perl_kill_file(pTHX_ const char *name)
a0d0e21e 2109{
2f4077ca
JM		 2110 char rspec[NAM$C_MAXRSS+1];
2111 char *tspec;
e0e5e8d6
JM		 2112 Stat_t st;
2113 int rmsts;
a0d0e21e 2114
e0e5e8d6
JM		 2115 /* Remove() is allowed to delete directories, according to the X/Open
2116 * specifications.
4fdf8f88 2117 * This may need special handling to work with the ACL hacks.
a0d0e21e 2118 */
4fdf8f88 2119 if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
dffb32cf 2120 rmsts = Perl_do_rmdir(aTHX_ name);
e0e5e8d6 2121 return rmsts;
a0d0e21e
LW		 2122 }
2123
e0e5e8d6 2124 rmsts = mp_do_kill_file(aTHX_ name, 0);
a0d0e21e
LW		 2125
2126 return rmsts;
2127
2128} /* end of kill_file() */
2129/*}}}*/
2130
8cc95fdb 2131
84902520 2132/*{{{int my_mkdir(char *,Mode_t)*/
8cc95fdb 2133int
b8ffc8df 2134Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
8cc95fdb 2135{
2136 STRLEN dirlen = strlen(dir);
2137
a2a90019
CB		 2138 /* zero length string sometimes gives ACCVIO */
2139 if (dirlen == 0) return -1;
2140
8cc95fdb 2141 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2142 * null file name/type. However, it's commonplace under Unix,
2143 * so we'll allow it for a gain in portability.
2144 */
2145 if (dir[dirlen-1] == '/') {
2146 char *newdir = savepvn(dir,dirlen-1);
2147 int ret = mkdir(newdir,mode);
2148 Safefree(newdir);
2149 return ret;
2150 }
2151 else return mkdir(dir,mode);
2152} /* end of my_mkdir */
2153/*}}}*/
2154
ee8c7f54
CB		 2155/*{{{int my_chdir(char *)*/
2156int
b8ffc8df 2157Perl_my_chdir(pTHX_ const char *dir)
ee8c7f54
CB		 2158{
2159 STRLEN dirlen = strlen(dir);
ee8c7f54
CB		 2160
2161 /* zero length string sometimes gives ACCVIO */
2162 if (dirlen == 0) return -1;
f7ddb74a
JM		 2163 const char *dir1;
2164
2165 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2166 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2167 * so that existing scripts do not need to be changed.
2168 */
2169 dir1 = dir;
2170 while ((dirlen > 0) && (*dir1 == ' ')) {
2171 dir1++;
2172 dirlen--;
2173 }
ee8c7f54
CB		 2174
2175 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2176 * that implies
2177 * null file name/type. However, it's commonplace under Unix,
2178 * so we'll allow it for a gain in portability.
f7ddb74a
JM		 2179 *
2180 * - Preview- '/' will be valid soon on VMS
ee8c7f54 2181 */
f7ddb74a 2182 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
dca5a913 2183 char *newdir = savepvn(dir1,dirlen-1);
ee8c7f54
CB		 2184 int ret = chdir(newdir);
2185 Safefree(newdir);
2186 return ret;
2187 }
dca5a913 2188 else return chdir(dir1);
ee8c7f54
CB		 2189} /* end of my_chdir */
2190/*}}}*/
8cc95fdb 2191
674d6c38 2192
f1db9cda
JM		 2193/*{{{int my_chmod(char *, mode_t)*/
2194int
2195Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2196{
2197 STRLEN speclen = strlen(file_spec);
2198
2199 /* zero length string sometimes gives ACCVIO */
2200 if (speclen == 0) return -1;
2201
2202 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2203 * that implies null file name/type. However, it's commonplace under Unix,
2204 * so we'll allow it for a gain in portability.
2205 *
2206 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2207 * in VMS file.dir notation.
2208 */
2209 if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2210 char *vms_src, *vms_dir, *rslt;
2211 int ret = -1;
2212 errno = EIO;
2213
2214 /* First convert this to a VMS format specification */
2215 vms_src = PerlMem_malloc(VMS_MAXRSS);
2216 if (vms_src == NULL)
ebd4d70b 2217 _ckvmssts_noperl(SS$_INSFMEM);
f1db9cda
JM		 2218
2219 rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2220 if (rslt == NULL) {
2221 /* If we fail, then not a file specification */
2222 PerlMem_free(vms_src);
2223 errno = EIO;
2224 return -1;
2225 }
2226
2227 /* Now make it a directory spec so chmod is happy */
2228 vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2229 if (vms_dir == NULL)
ebd4d70b 2230 _ckvmssts_noperl(SS$_INSFMEM);
f1db9cda
JM		 2231 rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2232 PerlMem_free(vms_src);
2233
2234 /* Now do it */
2235 if (rslt != NULL) {
2236 ret = chmod(vms_dir, mode);
2237 } else {
2238 errno = EIO;
2239 }
2240 PerlMem_free(vms_dir);
2241 return ret;
2242 }
2243 else return chmod(file_spec, mode);
2244} /* end of my_chmod */
2245/*}}}*/
2246
2247
674d6c38
CB		 2248/*{{{FILE *my_tmpfile()*/
2249FILE *
2250my_tmpfile(void)
2251{
2252 FILE *fp;
2253 char *cp;
674d6c38
CB		 2254
2255 if ((fp = tmpfile())) return fp;
2256
c5375c28
JM		 2257 cp = PerlMem_malloc(L_tmpnam+24);
2258 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2259
2497a41f
JM		 2260 if (decc_filename_unix_only == 0)
2261 strcpy(cp,"Sys$Scratch:");
2262 else
2263 strcpy(cp,"/tmp/");
674d6c38
CB		 2264 tmpnam(cp+strlen(cp));
2265 strcat(cp,".Perltmp");
2266 fp = fopen(cp,"w+","fop=dlt");
c5375c28 2267 PerlMem_free(cp);
674d6c38
CB		 2268 return fp;
2269}
2270/*}}}*/
2271
5c2d7af2
CB		 2272
2273#ifndef HOMEGROWN_POSIX_SIGNALS
2274/*
2275 * The C RTL's sigaction fails to check for invalid signal numbers so we
2276 * help it out a bit. The docs are correct, but the actual routine doesn't
2277 * do what the docs say it will.
2278 */
2279/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2280int
2281Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2282 struct sigaction* oact)
2283{
2284 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2285 SETERRNO(EINVAL, SS$_INVARG);
2286 return -1;
2287 }
2288 return sigaction(sig, act, oact);
2289}
2290/*}}}*/
2291#endif
2292
f2610a60
CL		 2293#ifdef KILL_BY_SIGPRC
2294#include <errnodef.h>
2295
05c058bc
CB		 2296/* We implement our own kill() using the undocumented system service
2297 sys$sigprc for one of two reasons:
2298
2299 1.) If the kill() in an older CRTL uses sys$forcex, causing the
f2610a60
CL		 2300 target process to do a sys$exit, which usually can't be handled
2301 gracefully...certainly not by Perl and the %SIG{} mechanism.
2302
05c058bc
CB		 2303 2.) If the kill() in the CRTL can't be called from a signal
2304 handler without disappearing into the ether, i.e., the signal
2305 it purportedly sends is never trapped. Still true as of VMS 7.3.
2306
2307 sys$sigprc has the same parameters as sys$forcex, but throws an exception
f2610a60
CL		 2308 in the target process rather than calling sys$exit.
2309
2310 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2311 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2312 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2313 with condition codes C$_SIG0+nsig*8, catching the exception on the
2314 target process and resignaling with appropriate arguments.
2315
2316 But we don't have that VMS 7.0+ exception handler, so if you
2317 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2318
2319 Also note that SIGTERM is listed in the docs as being "unimplemented",
2320 yet always seems to be signaled with a VMS condition code of 4 (and
2321 correctly handled for that code). So we hardwire it in.
2322
2323 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2324 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2325 than signalling with an unrecognized (and unhandled by CRTL) code.
2326*/
2327
fe1de8ce 2328#define _MY_SIG_MAX 28
f2610a60 2329
9c1171d1
JM		 2330static unsigned int
2331Perl_sig_to_vmscondition_int(int sig)
f2610a60 2332{
2e34cc90 2333 static unsigned int sig_code[_MY_SIG_MAX+1] =
f2610a60
CL		 2334 {
2335 0, /* 0 ZERO */
2336 SS$_HANGUP, /* 1 SIGHUP */
2337 SS$_CONTROLC, /* 2 SIGINT */
2338 SS$_CONTROLY, /* 3 SIGQUIT */
2339 SS$_RADRMOD, /* 4 SIGILL */
2340 SS$_BREAK, /* 5 SIGTRAP */
2341 SS$_OPCCUS, /* 6 SIGABRT */
2342 SS$_COMPAT, /* 7 SIGEMT */
2343#ifdef __VAX
2344 SS$_FLTOVF, /* 8 SIGFPE VAX */
2345#else
2346 SS$_HPARITH, /* 8 SIGFPE AXP */
2347#endif
2348 SS$_ABORT, /* 9 SIGKILL */
2349 SS$_ACCVIO, /* 10 SIGBUS */
2350 SS$_ACCVIO, /* 11 SIGSEGV */
2351 SS$_BADPARAM, /* 12 SIGSYS */
2352 SS$_NOMBX, /* 13 SIGPIPE */
2353 SS$_ASTFLT, /* 14 SIGALRM */
2354 4, /* 15 SIGTERM */
2355 0, /* 16 SIGUSR1 */
fe1de8ce
CB		 2356 0, /* 17 SIGUSR2 */
2357 0, /* 18 */
2358 0, /* 19 */
2359 0, /* 20 SIGCHLD */
2360 0, /* 21 SIGCONT */
2361 0, /* 22 SIGSTOP */
2362 0, /* 23 SIGTSTP */
2363 0, /* 24 SIGTTIN */
2364 0, /* 25 SIGTTOU */
2365 0, /* 26 */
2366 0, /* 27 */
2367 0 /* 28 SIGWINCH */
f2610a60
CL		 2368 };
2369
2370#if __VMS_VER >= 60200000
2371 static int initted = 0;
2372 if (!initted) {
2373 initted = 1;
2374 sig_code[16] = C$_SIGUSR1;
2375 sig_code[17] = C$_SIGUSR2;
fe1de8ce
CB		 2376#if __CRTL_VER >= 70000000
2377 sig_code[20] = C$_SIGCHLD;
2378#endif
2379#if __CRTL_VER >= 70300000
2380 sig_code[28] = C$_SIGWINCH;
2381#endif
f2610a60
CL		 2382 }
2383#endif
2384
2e34cc90
CL		 2385 if (sig < _SIG_MIN) return 0;
2386 if (sig > _MY_SIG_MAX) return 0;
2387 return sig_code[sig];
2388}
2389
9c1171d1
JM		 2390unsigned int
2391Perl_sig_to_vmscondition(int sig)
2392{
2393#ifdef SS$_DEBUG
2394 if (vms_debug_on_exception != 0)
2395 lib$signal(SS$_DEBUG);
2396#endif
2397 return Perl_sig_to_vmscondition_int(sig);
2398}
2399
2400
2e34cc90
CL		 2401int
2402Perl_my_kill(int pid, int sig)
2403{
218fdd94 2404 dTHX;
2e34cc90
CL		 2405 int iss;
2406 unsigned int code;
2407 int sys$sigprc(unsigned int *pidadr,
2408 struct dsc$descriptor_s *prcname,
2409 unsigned int code);
2410
7a7fd8e0
JM		 2411 /* sig 0 means validate the PID */
2412 /*------------------------------*/
2413 if (sig == 0) {
2414 const unsigned long int jpicode = JPI$_PID;
2415 pid_t ret_pid;
2416 int status;
2417 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2418 if ($VMS_STATUS_SUCCESS(status))
2419 return 0;
2420 switch (status) {
2421 case SS$_NOSUCHNODE:
2422 case SS$_UNREACHABLE:
2423 case SS$_NONEXPR:
2424 errno = ESRCH;
2425 break;
2426 case SS$_NOPRIV:
2427 errno = EPERM;
2428 break;
2429 default:
2430 errno = EVMSERR;
2431 }
2432 vaxc$errno=status;
2433 return -1;
2434 }
2435
9c1171d1 2436 code = Perl_sig_to_vmscondition_int(sig);
2e34cc90 2437
7a7fd8e0
JM		 2438 if (!code) {
2439 SETERRNO(EINVAL, SS$_BADPARAM);
2440 return -1;
2441 }
2442
2443 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2444 * signals are to be sent to multiple processes.
2445 * pid = 0 - all processes in group except ones that the system exempts
2446 * pid = -1 - all processes except ones that the system exempts
2447 * pid = -n - all processes in group (abs(n)) except ...
2448 * For now, just report as not supported.
2449 */
2450
2451 if (pid <= 0) {
2452 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
f2610a60
CL		 2453 return -1;
2454 }
2455
2e34cc90 2456 iss = sys$sigprc((unsigned int *)&pid,0,code);
f2610a60
CL		 2457 if (iss&1) return 0;
2458
2459 switch (iss) {
2460 case SS$_NOPRIV:
2461 set_errno(EPERM); break;
2462 case SS$_NONEXPR:
2463 case SS$_NOSUCHNODE:
2464 case SS$_UNREACHABLE:
2465 set_errno(ESRCH); break;
2466 case SS$_INSFMEM:
2467 set_errno(ENOMEM); break;
2468 default:
ebd4d70b 2469 _ckvmssts_noperl(iss);
f2610a60
CL		 2470 set_errno(EVMSERR);
2471 }
2472 set_vaxc_errno(iss);
2473
2474 return -1;
2475}
2476#endif
2477
2fbb330f
JM		 2478/* Routine to convert a VMS status code to a UNIX status code.
2479** More tricky than it appears because of conflicting conventions with
2480** existing code.
2481**
2482** VMS status codes are a bit mask, with the least significant bit set for
2483** success.
2484**
2485** Special UNIX status of EVMSERR indicates that no translation is currently
2486** available, and programs should check the VMS status code.
2487**
2488** Programs compiled with _POSIX_EXIT have a special encoding that requires
2489** decoding.
2490*/
2491
2492#ifndef C_FACILITY_NO
2493#define C_FACILITY_NO 0x350000
2494#endif
2495#ifndef DCL_IVVERB
2496#define DCL_IVVERB 0x38090
2497#endif
2498
7a7fd8e0 2499int Perl_vms_status_to_unix(int vms_status, int child_flag)
2fbb330f
JM		 2500{
2501int facility;
2502int fac_sp;
2503int msg_no;
2504int msg_status;
2505int unix_status;
2506
2507 /* Assume the best or the worst */
2508 if (vms_status & STS$M_SUCCESS)
2509 unix_status = 0;
2510 else
2511 unix_status = EVMSERR;
2512
2513 msg_status = vms_status & ~STS$M_CONTROL;
2514
2515 facility = vms_status & STS$M_FAC_NO;
2516 fac_sp = vms_status & STS$M_FAC_SP;
2517 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2518
0968cdad 2519 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2fbb330f
JM		 2520 switch(msg_no) {
2521 case SS$_NORMAL:
2522 unix_status = 0;
2523 break;
2524 case SS$_ACCVIO:
2525 unix_status = EFAULT;
2526 break;
7a7fd8e0
JM		 2527 case SS$_DEVOFFLINE:
2528 unix_status = EBUSY;
2529 break;
2530 case SS$_CLEARED:
2531 unix_status = ENOTCONN;
2532 break;
2533 case SS$_IVCHAN:
2fbb330f
JM		 2534 case SS$_IVLOGNAM:
2535 case SS$_BADPARAM:
2536 case SS$_IVLOGTAB:
2537 case SS$_NOLOGNAM:
2538 case SS$_NOLOGTAB:
2539 case SS$_INVFILFOROP:
2540 case SS$_INVARG:
2541 case SS$_NOSUCHID:
2542 case SS$_IVIDENT:
2543 unix_status = EINVAL;
2544 break;
7a7fd8e0
JM		 2545 case SS$_UNSUPPORTED:
2546 unix_status = ENOTSUP;
2547 break;
2fbb330f
JM		 2548 case SS$_FILACCERR:
2549 case SS$_NOGRPPRV:
2550 case SS$_NOSYSPRV:
2551 unix_status = EACCES;
2552 break;
2553 case SS$_DEVICEFULL:
2554 unix_status = ENOSPC;
2555 break;
2556 case SS$_NOSUCHDEV:
2557 unix_status = ENODEV;
2558 break;
2559 case SS$_NOSUCHFILE:
2560 case SS$_NOSUCHOBJECT:
2561 unix_status = ENOENT;
2562 break;
fb38d079
JM		 2563 case SS$_ABORT: /* Fatal case */
2564 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2565 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2fbb330f
JM		 2566 unix_status = EINTR;
2567 break;
2568 case SS$_BUFFEROVF:
2569 unix_status = E2BIG;
2570 break;
2571 case SS$_INSFMEM:
2572 unix_status = ENOMEM;
2573 break;
2574 case SS$_NOPRIV:
2575 unix_status = EPERM;
2576 break;
2577 case SS$_NOSUCHNODE:
2578 case SS$_UNREACHABLE:
2579 unix_status = ESRCH;
2580 break;
2581 case SS$_NONEXPR:
2582 unix_status = ECHILD;
2583 break;
2584 default:
2585 if ((facility == 0) && (msg_no < 8)) {
2586 /* These are not real VMS status codes so assume that they are
2587 ** already UNIX status codes
2588 */
2589 unix_status = msg_no;
2590 break;
2591 }
2592 }
2593 }
2594 else {
2595 /* Translate a POSIX exit code to a UNIX exit code */
2596 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
7a7fd8e0 2597 unix_status = (msg_no & 0x07F8) >> 3;
2fbb330f
JM		 2598 }
2599 else {
7a7fd8e0
JM		 2600
2601 /* Documented traditional behavior for handling VMS child exits */
2602 /*--------------------------------------------------------------*/
2603 if (child_flag != 0) {
2604
2605 /* Success / Informational return 0 */
2606 /*----------------------------------*/
2607 if (msg_no & STS$K_SUCCESS)
2608 return 0;
2609
2610 /* Warning returns 1 */
2611 /*-------------------*/
2612 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2613 return 1;
2614
2615 /* Everything else pass through the severity bits */
2616 /*------------------------------------------------*/
2617 return (msg_no & STS$M_SEVERITY);
2618 }
2619
2620 /* Normal VMS status to ERRNO mapping attempt */
2621 /*--------------------------------------------*/
2fbb330f
JM		 2622 switch(msg_status) {
2623 /* case RMS$_EOF: */ /* End of File */
2624 case RMS$_FNF: /* File Not Found */
2625 case RMS$_DNF: /* Dir Not Found */
2626 unix_status = ENOENT;
2627 break;
2628 case RMS$_RNF: /* Record Not Found */
2629 unix_status = ESRCH;
2630 break;
2631 case RMS$_DIR:
2632 unix_status = ENOTDIR;
2633 break;
2634 case RMS$_DEV:
2635 unix_status = ENODEV;
2636 break;
7a7fd8e0
JM		 2637 case RMS$_IFI:
2638 case RMS$_FAC:
2639 case RMS$_ISI:
2640 unix_status = EBADF;
2641 break;
2642 case RMS$_FEX:
2643 unix_status = EEXIST;
2644 break;
2fbb330f
JM		 2645 case RMS$_SYN:
2646 case RMS$_FNM:
2647 case LIB$_INVSTRDES:
2648 case LIB$_INVARG:
2649 case LIB$_NOSUCHSYM:
2650 case LIB$_INVSYMNAM:
2651 case DCL_IVVERB:
2652 unix_status = EINVAL;
2653 break;
2654 case CLI$_BUFOVF:
2655 case RMS$_RTB:
2656 case CLI$_TKNOVF:
2657 case CLI$_RSLOVF:
2658 unix_status = E2BIG;
2659 break;
2660 case RMS$_PRV: /* No privilege */
2661 case RMS$_ACC: /* ACP file access failed */
2662 case RMS$_WLK: /* Device write locked */
2663 unix_status = EACCES;
2664 break;
ed1b9de0
JM		 2665 case RMS$_MKD: /* Failed to mark for delete */
2666 unix_status = EPERM;
2667 break;
2fbb330f
JM		 2668 /* case RMS$_NMF: */ /* No more files */
2669 }
2670 }
2671 }
2672
2673 return unix_status;
2674}
2675
7a7fd8e0
JM		 2676/* Try to guess at what VMS error status should go with a UNIX errno
2677 * value. This is hard to do as there could be many possible VMS
2678 * error statuses that caused the errno value to be set.
2679 */
2680
2681int Perl_unix_status_to_vms(int unix_status)
2682{
2683int test_unix_status;
2684
2685 /* Trivial cases first */
2686 /*---------------------*/
2687 if (unix_status == EVMSERR)
2688 return vaxc$errno;
2689
2690 /* Is vaxc$errno sane? */
2691 /*---------------------*/
2692 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2693 if (test_unix_status == unix_status)
2694 return vaxc$errno;
2695
2696 /* If way out of range, must be VMS code already */
2697 /*-----------------------------------------------*/
2698 if (unix_status > EVMSERR)
2699 return unix_status;
2700
2701 /* If out of range, punt */
2702 /*-----------------------*/
2703 if (unix_status > __ERRNO_MAX)
2704 return SS$_ABORT;
2705
2706
2707 /* Ok, now we have to do it the hard way. */
2708 /*----------------------------------------*/
2709 switch(unix_status) {
2710 case 0: return SS$_NORMAL;
2711 case EPERM: return SS$_NOPRIV;
2712 case ENOENT: return SS$_NOSUCHOBJECT;
2713 case ESRCH: return SS$_UNREACHABLE;
2714 case EINTR: return SS$_ABORT;
2715 /* case EIO: */
2716 /* case ENXIO: */
2717 case E2BIG: return SS$_BUFFEROVF;
2718 /* case ENOEXEC */
2719 case EBADF: return RMS$_IFI;
2720 case ECHILD: return SS$_NONEXPR;
2721 /* case EAGAIN */
2722 case ENOMEM: return SS$_INSFMEM;
2723 case EACCES: return SS$_FILACCERR;
2724 case EFAULT: return SS$_ACCVIO;
2725 /* case ENOTBLK */
0968cdad 2726 case EBUSY: return SS$_DEVOFFLINE;
7a7fd8e0
JM		 2727 case EEXIST: return RMS$_FEX;
2728 /* case EXDEV */
2729 case ENODEV: return SS$_NOSUCHDEV;
2730 case ENOTDIR: return RMS$_DIR;
2731 /* case EISDIR */
2732 case EINVAL: return SS$_INVARG;
2733 /* case ENFILE */
2734 /* case EMFILE */
2735 /* case ENOTTY */
2736 /* case ETXTBSY */
2737 /* case EFBIG */
2738 case ENOSPC: return SS$_DEVICEFULL;
2739 case ESPIPE: return LIB$_INVARG;
2740 /* case EROFS: */
2741 /* case EMLINK: */
2742 /* case EPIPE: */
2743 /* case EDOM */
2744 case ERANGE: return LIB$_INVARG;
2745 /* case EWOULDBLOCK */
2746 /* case EINPROGRESS */
2747 /* case EALREADY */
2748 /* case ENOTSOCK */
2749 /* case EDESTADDRREQ */
2750 /* case EMSGSIZE */
2751 /* case EPROTOTYPE */
2752 /* case ENOPROTOOPT */
2753 /* case EPROTONOSUPPORT */
2754 /* case ESOCKTNOSUPPORT */
2755 /* case EOPNOTSUPP */
2756 /* case EPFNOSUPPORT */
2757 /* case EAFNOSUPPORT */
2758 /* case EADDRINUSE */
2759 /* case EADDRNOTAVAIL */
2760 /* case ENETDOWN */
2761 /* case ENETUNREACH */
2762 /* case ENETRESET */
2763 /* case ECONNABORTED */
2764 /* case ECONNRESET */
2765 /* case ENOBUFS */
2766 /* case EISCONN */
2767 case ENOTCONN: return SS$_CLEARED;
2768 /* case ESHUTDOWN */
2769 /* case ETOOMANYREFS */
2770 /* case ETIMEDOUT */
2771 /* case ECONNREFUSED */
2772 /* case ELOOP */
2773 /* case ENAMETOOLONG */
2774 /* case EHOSTDOWN */
2775 /* case EHOSTUNREACH */
2776 /* case ENOTEMPTY */
2777 /* case EPROCLIM */
2778 /* case EUSERS */
2779 /* case EDQUOT */
2780 /* case ENOMSG */
2781 /* case EIDRM */
2782 /* case EALIGN */
2783 /* case ESTALE */
2784 /* case EREMOTE */
2785 /* case ENOLCK */
2786 /* case ENOSYS */
2787 /* case EFTYPE */
2788 /* case ECANCELED */
2789 /* case EFAIL */
2790 /* case EINPROG */
2791 case ENOTSUP:
2792 return SS$_UNSUPPORTED;
2793 /* case EDEADLK */
2794 /* case ENWAIT */
2795 /* case EILSEQ */
2796 /* case EBADCAT */
2797 /* case EBADMSG */
2798 /* case EABANDONED */
2799 default:
2800 return SS$_ABORT; /* punt */
2801 }
2802
2803 return SS$_ABORT; /* Should not get here */
2804}
2fbb330f
JM		 2805
2806
22d4bb9c
CB		 2807/* default piping mailbox size */
2808#define PERL_BUFSIZ 512
2809
674d6c38 2810
a0d0e21e 2811static void
8a646e0b 2812create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 2813{
22d4bb9c
CB		 2814 unsigned long int mbxbufsiz;
2815 static unsigned long int syssize = 0;
2816 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 2817 char csize[LNM$C_NAMLENGTH+1];
f7ddb74a
JM		 2818 int sts;
2819
22d4bb9c
CB		 2820 if (!syssize) {
2821 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 2822 /*
22d4bb9c
CB		 2823 * Get the SYSGEN parameter MAXBUF
2824 *
2825 * If the logical 'PERL_MBX_SIZE' is defined
2826 * use the value of the logical instead of PERL_BUFSIZ, but
2827 * keep the size between 128 and MAXBUF.
2828 *
a0d0e21e 2829 */
ebd4d70b 2830 _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
22d4bb9c
CB		 2831 }
2832
2833 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2834 mbxbufsiz = atoi(csize);
2835 } else {
2836 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 2837 }
22d4bb9c
CB		 2838 if (mbxbufsiz < 128) mbxbufsiz = 128;
2839 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2840
ebd4d70b 2841 _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 2842
ebd4d70b
JM		 2843 sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2844 _ckvmssts_noperl(sts);
a0d0e21e
LW		 2845 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2846
2847} /* end of create_mbx() */
2848
22d4bb9c 2849
a0d0e21e 2850/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 2851
2852typedef struct _iosb IOSB;
2853typedef struct _iosb* pIOSB;
2854typedef struct _pipe Pipe;
2855typedef struct _pipe* pPipe;
2856typedef struct pipe_details Info;
2857typedef struct pipe_details* pInfo;
2858typedef struct _srqp RQE;
2859typedef struct _srqp* pRQE;
2860typedef struct _tochildbuf CBuf;
2861typedef struct _tochildbuf* pCBuf;
2862
2863struct _iosb {
2864 unsigned short status;
2865 unsigned short count;
2866 unsigned long dvispec;
2867};
2868
2869#pragma member_alignment save
2870#pragma nomember_alignment quadword
2871struct _srqp { /* VMS self-relative queue entry */
2872 unsigned long qptr[2];
2873};
2874#pragma member_alignment restore
2875static RQE RQE_ZERO = {0,0};
2876
2877struct _tochildbuf {
2878 RQE q;
2879 int eof;
2880 unsigned short size;
2881 char *buf;
2882};
2883
2884struct _pipe {
2885 RQE free;
2886 RQE wait;
2887 int fd_out;
2888 unsigned short chan_in;
2889 unsigned short chan_out;
2890 char *buf;
2891 unsigned int bufsize;
2892 IOSB iosb;
2893 IOSB iosb2;
2894 int *pipe_done;
2895 int retry;
2896 int type;
2897 int shut_on_empty;
2898 int need_wake;
2899 pPipe *home;
2900 pInfo info;
2901 pCBuf curr;
2902 pCBuf curr2;
fd8cd3a3
DS		 2903#if defined(PERL_IMPLICIT_CONTEXT)
2904 void *thx; /* Either a thread or an interpreter */
2905 /* pointer, depending on how we're built */
2906#endif
22d4bb9c
CB		 2907};
2908
2909
a0d0e21e
LW		 2910struct pipe_details
2911{
22d4bb9c 2912 pInfo next;
ff7adb52
CL		 2913 PerlIO *fp; /* file pointer to pipe mailbox */
2914 int useFILE; /* using stdio, not perlio */
748a9306
LW		 2915 int pid; /* PID of subprocess */
2916 int mode; /* == 'r' if pipe open for reading */
2917 int done; /* subprocess has completed */
ff7adb52 2918 int waiting; /* waiting for completion/closure */
22d4bb9c
CB		 2919 int closing; /* my_pclose is closing this pipe */
2920 unsigned long completion; /* termination status of subprocess */
2921 pPipe in; /* pipe in to sub */
2922 pPipe out; /* pipe out of sub */
2923 pPipe err; /* pipe of sub's sys$error */
2924 int in_done; /* true when in pipe finished */
2925 int out_done;
2926 int err_done;
cd1191f1
CB		 2927 unsigned short xchan; /* channel to debug xterm */
2928 unsigned short xchan_valid; /* channel is assigned */
a0d0e21e
LW		 2929};
2930
748a9306
LW		 2931struct exit_control_block
2932{
2933 struct exit_control_block *flink;
2934 unsigned long int (*exit_routine)();
2935 unsigned long int arg_count;
2936 unsigned long int *status_address;
2937 unsigned long int exit_status;
2938};
2939
d85f548a
JH		 2940typedef struct _closed_pipes Xpipe;
2941typedef struct _closed_pipes* pXpipe;
2942
2943struct _closed_pipes {
2944 int pid; /* PID of subprocess */
2945 unsigned long completion; /* termination status of subprocess */
2946};
2947#define NKEEPCLOSED 50
2948static Xpipe closed_list[NKEEPCLOSED];
2949static int closed_index = 0;
2950static int closed_num = 0;
2951
22d4bb9c
CB		 2952#define RETRY_DELAY "0 ::0.20"
2953#define MAX_RETRY 50
a0d0e21e 2954
22d4bb9c
CB		 2955static int pipe_ef = 0; /* first call to safe_popen inits these*/
2956static unsigned long mypid;
2957static unsigned long delaytime[2];
2958
2959static pInfo open_pipes = NULL;
2960static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 2961
ff7adb52
CL		 2962#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2963
2964
3eeba6fb 2965
748a9306 2966static unsigned long int
ebd4d70b 2967pipe_exit_routine()
748a9306 2968{
22d4bb9c 2969 pInfo info;
1e422769 2970 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
ff7adb52
CL		 2971 int sts, did_stuff, need_eof, j;
2972
5ce486e0
CB		 2973 /*
2974 * Flush any pending i/o, but since we are in process run-down, be
2975 * careful about referencing PerlIO structures that may already have
2976 * been deallocated. We may not even have an interpreter anymore.
ff7adb52
CL		 2977 */
2978 info = open_pipes;
2979 while (info) {
2980 if (info->fp) {
ebd4d70b
JM		 2981#if defined(PERL_IMPLICIT_CONTEXT)
2982 /* We need to use the Perl context of the thread that created */
2983 /* the pipe. */
2984 pTHX;
2985 if (info->err)
2986 aTHX = info->err->thx;
2987 else if (info->out)
2988 aTHX = info->out->thx;
2989 else if (info->in)
2990 aTHX = info->in->thx;
2991#endif
5ce486e0
CB		 2992 if (!info->useFILE
2993#if defined(USE_ITHREADS)
2994 && my_perl
2995#endif
2996 && PL_perlio_fd_refcnt)
2997 PerlIO_flush(info->fp);
ff7adb52
CL		 2998 else
2999 fflush((FILE *)info->fp);
3000 }
3001 info = info->next;
3002 }
3eeba6fb
CB		 3003
3004 /*
ff7adb52 3005 next we try sending an EOF...ignore if doesn't work, make sure we
3eeba6fb
CB		 3006 don't hang
3007 */
3008 did_stuff = 0;
3009 info = open_pipes;
748a9306 3010
3eeba6fb 3011 while (info) {
b2b89246 3012 int need_eof;
d4c83939 3013 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 3014 if (info->in && !info->in->shut_on_empty) {
d4c83939 3015 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
ebd4d70b 3016 0, 0, 0, 0, 0, 0));
ff7adb52 3017 info->waiting = 1;
22d4bb9c 3018 did_stuff = 1;
748a9306 3019 }
d4c83939 3020 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3021 info = info->next;
3022 }
ff7adb52
CL		 3023
3024 /* wait for EOF to have effect, up to ~ 30 sec [default] */
3025
3026 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3027 int nwait = 0;
3028
3029 info = open_pipes;
3030 while (info) {
d4c83939 3031 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 3032 if (info->waiting && info->done)
3033 info->waiting = 0;
3034 nwait += info->waiting;
d4c83939 3035 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 3036 info = info->next;
3037 }
3038 if (!nwait) break;
3039 sleep(1);
3040 }
3eeba6fb
CB		 3041
3042 did_stuff = 0;
3043 info = open_pipes;
3044 while (info) {
d4c83939 3045 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 3046 if (!info->done) { /* Tap them gently on the shoulder . . .*/
3047 sts = sys$forcex(&info->pid,0,&abort);
d4c83939 3048 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3eeba6fb
CB		 3049 did_stuff = 1;
3050 }
d4c83939 3051 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3052 info = info->next;
3053 }
ff7adb52
CL		 3054
3055 /* again, wait for effect */
3056
3057 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3058 int nwait = 0;
3059
3060 info = open_pipes;
3061 while (info) {
d4c83939 3062 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 3063 if (info->waiting && info->done)
3064 info->waiting = 0;
3065 nwait += info->waiting;
d4c83939 3066 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 3067 info = info->next;
3068 }
3069 if (!nwait) break;
3070 sleep(1);
3071 }
3eeba6fb
CB		 3072
3073 info = open_pipes;
3074 while (info) {
d4c83939 3075 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 3076 if (!info->done) { /* We tried to be nice . . . */
3077 sts = sys$delprc(&info->pid,0);
d4c83939 3078 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2f1dcba4 3079 info->done = 1; /* sys$delprc is as done as we're going to get. */
3eeba6fb 3080 }
d4c83939 3081 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3082 info = info->next;
3083 }
3084
3085 while(open_pipes) {
ebd4d70b
JM		 3086
3087#if defined(PERL_IMPLICIT_CONTEXT)
3088 /* We need to use the Perl context of the thread that created */
3089 /* the pipe. */
3090 pTHX;
36b6faa8
CB		 3091 if (open_pipes->err)
3092 aTHX = open_pipes->err->thx;
3093 else if (open_pipes->out)
3094 aTHX = open_pipes->out->thx;
3095 else if (open_pipes->in)
3096 aTHX = open_pipes->in->thx;
ebd4d70b 3097#endif
1e422769 3098 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3099 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 3100 }
3101 return retsts;
3102}
3103
3104static struct exit_control_block pipe_exitblock =
3105 {(struct exit_control_block *) 0,
3106 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3107
22d4bb9c
CB		 3108static void pipe_mbxtofd_ast(pPipe p);
3109static void pipe_tochild1_ast(pPipe p);
3110static void pipe_tochild2_ast(pPipe p);
748a9306 3111
a0d0e21e 3112static void
22d4bb9c 3113popen_completion_ast(pInfo info)
a0d0e21e 3114{
22d4bb9c
CB		 3115 pInfo i = open_pipes;
3116 int iss;
f7ddb74a 3117 int sts;
d85f548a
JH		 3118 pXpipe x;
3119
3120 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3121 closed_list[closed_index].pid = info->pid;
3122 closed_list[closed_index].completion = info->completion;
3123 closed_index++;
3124 if (closed_index == NKEEPCLOSED)
3125 closed_index = 0;
3126 closed_num++;
22d4bb9c
CB		 3127
3128 while (i) {
3129 if (i == info) break;
3130 i = i->next;
3131 }
3132 if (!i) return; /* unlinked, probably freed too */
3133
22d4bb9c
CB		 3134 info->done = TRUE;
3135
3136/*
3137 Writing to subprocess ...
3138 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3139
3140 chan_out may be waiting for "done" flag, or hung waiting
3141 for i/o completion to child...cancel the i/o. This will
3142 put it into "snarf mode" (done but no EOF yet) that discards
3143 input.
3144
3145 Output from subprocess (stdout, stderr) needs to be flushed and
3146 shut down. We try sending an EOF, but if the mbx is full the pipe
3147 routine should still catch the "shut_on_empty" flag, telling it to
3148 use immediate-style reads so that "mbx empty" -> EOF.
3149
3150
3151*/
3152 if (info->in && !info->in_done) { /* only for mode=w */
3153 if (info->in->shut_on_empty && info->in->need_wake) {
3154 info->in->need_wake = FALSE;
fd8cd3a3 3155 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 3156 } else {
fd8cd3a3 3157 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 3158 }
3159 }
3160
3161 if (info->out && !info->out_done) { /* were we also piping output? */
3162 info->out->shut_on_empty = TRUE;
3163 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3164 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3165 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3166 }
3167
3168 if (info->err && !info->err_done) { /* we were piping stderr */
3169 info->err->shut_on_empty = TRUE;
3170 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3171 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3172 _ckvmssts_noperl(iss);
a0d0e21e 3173 }
fd8cd3a3 3174 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3175
a0d0e21e
LW		 3176}
3177
2fbb330f 3178static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
218fdd94 3179static void vms_execfree(struct dsc$descriptor_s *vmscmd);
aa779de1 3180
22d4bb9c
CB		 3181/*
3182 we actually differ from vmstrnenv since we use this to
3183 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3184 are pointing to the same thing
3185*/
3186
3187static unsigned short
fd8cd3a3 3188popen_translate(pTHX_ char *logical, char *result)
22d4bb9c
CB		 3189{
3190 int iss;
3191 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3192 $DESCRIPTOR(d_log,"");
3193 struct _il3 {
3194 unsigned short length;
3195 unsigned short code;
3196 char * buffer_addr;
3197 unsigned short *retlenaddr;
3198 } itmlst[2];
3199 unsigned short l, ifi;
3200
3201 d_log.dsc$a_pointer = logical;
3202 d_log.dsc$w_length = strlen(logical);
3203
3204 itmlst[0].code = LNM$_STRING;
3205 itmlst[0].length = 255;
3206 itmlst[0].buffer_addr = result;
3207 itmlst[0].retlenaddr = &l;
3208
3209 itmlst[1].code = 0;
3210 itmlst[1].length = 0;
3211 itmlst[1].buffer_addr = 0;
3212 itmlst[1].retlenaddr = 0;
3213
3214 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3215 if (iss == SS$_NOLOGNAM) {
3216 iss = SS$_NORMAL;
3217 l = 0;
3218 }
3219 if (!(iss&1)) lib$signal(iss);
3220 result[l] = '\0';
3221/*
3222 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3223 strip it off and return the ifi, if any
3224*/
3225 ifi = 0;
3226 if (result[0] == 0x1b && result[1] == 0x00) {
18a3d61e 3227 memmove(&ifi,result+2,2);
22d4bb9c
CB		 3228 strcpy(result,result+4);
3229 }
3230 return ifi; /* this is the RMS internal file id */
3231}
3232
22d4bb9c
CB		 3233static void pipe_infromchild_ast(pPipe p);
3234
3235/*
3236 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3237 inside an AST routine without worrying about reentrancy and which Perl
3238 memory allocator is being used.
3239
3240 We read data and queue up the buffers, then spit them out one at a
3241 time to the output mailbox when the output mailbox is ready for one.
3242
3243*/
3244#define INITIAL_TOCHILDQUEUE 2
3245
3246static pPipe
fd8cd3a3 3247pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3248{
22d4bb9c
CB		 3249 pPipe p;
3250 pCBuf b;
3251 char mbx1[64], mbx2[64];
3252 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3253 DSC$K_CLASS_S, mbx1},
3254 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3255 DSC$K_CLASS_S, mbx2};
3256 unsigned int dviitm = DVI$_DEVBUFSIZ;
3257 int j, n;
3258
d4c83939 3259 n = sizeof(Pipe);
ebd4d70b 3260 _ckvmssts_noperl(lib$get_vm(&n, &p));
22d4bb9c 3261
8a646e0b
JM		 3262 create_mbx(&p->chan_in , &d_mbx1);
3263 create_mbx(&p->chan_out, &d_mbx2);
ebd4d70b 3264 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
22d4bb9c
CB		 3265
3266 p->buf = 0;
3267 p->shut_on_empty = FALSE;
3268 p->need_wake = FALSE;
3269 p->type = 0;
3270 p->retry = 0;
3271 p->iosb.status = SS$_NORMAL;
3272 p->iosb2.status = SS$_NORMAL;
3273 p->free = RQE_ZERO;
3274 p->wait = RQE_ZERO;
3275 p->curr = 0;
3276 p->curr2 = 0;
3277 p->info = 0;
fd8cd3a3
DS		 3278#ifdef PERL_IMPLICIT_CONTEXT
3279 p->thx = aTHX;
3280#endif
22d4bb9c
CB		 3281
3282 n = sizeof(CBuf) + p->bufsize;
3283
3284 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
ebd4d70b 3285 _ckvmssts_noperl(lib$get_vm(&n, &b));
22d4bb9c 3286 b->buf = (char *) b + sizeof(CBuf);
ebd4d70b 3287 _ckvmssts_noperl(lib$insqhi(b, &p->free));
22d4bb9c
CB		 3288 }
3289
3290 pipe_tochild2_ast(p);
3291 pipe_tochild1_ast(p);
3292 strcpy(wmbx, mbx1);
3293 strcpy(rmbx, mbx2);
3294 return p;
3295}
3296
3297/* reads the MBX Perl is writing, and queues */
3298
3299static void
3300pipe_tochild1_ast(pPipe p)
3301{
22d4bb9c
CB		 3302 pCBuf b = p->curr;
3303 int iss = p->iosb.status;
3304 int eof = (iss == SS$_ENDOFFILE);
f7ddb74a 3305 int sts;
fd8cd3a3
DS		 3306#ifdef PERL_IMPLICIT_CONTEXT
3307 pTHX = p->thx;
3308#endif
22d4bb9c
CB		 3309
3310 if (p->retry) {
3311 if (eof) {
3312 p->shut_on_empty = TRUE;
3313 b->eof = TRUE;
ebd4d70b 3314 _ckvmssts_noperl(sys$dassgn(p->chan_in));
22d4bb9c 3315 } else {
ebd4d70b 3316 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3317 }
3318
3319 b->eof = eof;
3320 b->size = p->iosb.count;
ebd4d70b 3321 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
22d4bb9c
CB		 3322 if (p->need_wake) {
3323 p->need_wake = FALSE;
ebd4d70b 3324 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
22d4bb9c
CB		 3325 }
3326 } else {
3327 p->retry = 1; /* initial call */
3328 }
3329
3330 if (eof) { /* flush the free queue, return when done */
3331 int n = sizeof(CBuf) + p->bufsize;
3332 while (1) {
3333 iss = lib$remqti(&p->free, &b);
3334 if (iss == LIB$_QUEWASEMP) return;
ebd4d70b
JM		 3335 _ckvmssts_noperl(iss);
3336 _ckvmssts_noperl(lib$free_vm(&n, &b));
22d4bb9c
CB		 3337 }
3338 }
3339
3340 iss = lib$remqti(&p->free, &b);
3341 if (iss == LIB$_QUEWASEMP) {
3342 int n = sizeof(CBuf) + p->bufsize;
ebd4d70b 3343 _ckvmssts_noperl(lib$get_vm(&n, &b));
22d4bb9c
CB		 3344 b->buf = (char *) b + sizeof(CBuf);
3345 } else {
ebd4d70b 3346 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3347 }
3348
3349 p->curr = b;
3350 iss = sys$qio(0,p->chan_in,
3351 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3352 &p->iosb,
3353 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3354 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
ebd4d70b 3355 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3356}
3357
3358
3359/* writes queued buffers to output, waits for each to complete before
3360 doing the next */
3361
3362static void
3363pipe_tochild2_ast(pPipe p)
3364{
22d4bb9c
CB		 3365 pCBuf b = p->curr2;
3366 int iss = p->iosb2.status;
3367 int n = sizeof(CBuf) + p->bufsize;
3368 int done = (p->info && p->info->done) ||
3369 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 3370#if defined(PERL_IMPLICIT_CONTEXT)
3371 pTHX = p->thx;
3372#endif
22d4bb9c
CB		 3373
3374 do {
3375 if (p->type) { /* type=1 has old buffer, dispose */
3376 if (p->shut_on_empty) {
ebd4d70b 3377 _ckvmssts_noperl(lib$free_vm(&n, &b));
22d4bb9c 3378 } else {
ebd4d70b 3379 _ckvmssts_noperl(lib$insqhi(b, &p->free));
22d4bb9c
CB		 3380 }
3381 p->type = 0;
3382 }
3383
3384 iss = lib$remqti(&p->wait, &b);
3385 if (iss == LIB$_QUEWASEMP) {
3386 if (p->shut_on_empty) {
3387 if (done) {
ebd4d70b 3388 _ckvmssts_noperl(sys$dassgn(p->chan_out));
22d4bb9c 3389 *p->pipe_done = TRUE;
ebd4d70b 3390 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3391 } else {
ebd4d70b 3392 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
22d4bb9c
CB		 3393 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3394 }
3395 return;
3396 }
3397 p->need_wake = TRUE;
3398 return;
3399 }
ebd4d70b 3400 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3401 p->type = 1;
3402 } while (done);
3403
3404
3405 p->curr2 = b;
3406 if (b->eof) {
ebd4d70b 3407 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
22d4bb9c
CB		 3408 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3409 } else {
ebd4d70b 3410 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
22d4bb9c
CB		 3411 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3412 }
3413
3414 return;
3415
3416}
3417
3418
3419static pPipe
fd8cd3a3 3420pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3421{
22d4bb9c
CB		 3422 pPipe p;
3423 char mbx1[64], mbx2[64];
3424 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3425 DSC$K_CLASS_S, mbx1},
3426 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3427 DSC$K_CLASS_S, mbx2};
3428 unsigned int dviitm = DVI$_DEVBUFSIZ;
3429
d4c83939 3430 int n = sizeof(Pipe);
ebd4d70b 3431 _ckvmssts_noperl(lib$get_vm(&n, &p));
8a646e0b
JM		 3432 create_mbx(&p->chan_in , &d_mbx1);
3433 create_mbx(&p->chan_out, &d_mbx2);
22d4bb9c 3434
ebd4d70b 3435 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939 3436 n = p->bufsize * sizeof(char);
ebd4d70b 3437 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3438 p->shut_on_empty = FALSE;
3439 p->info = 0;
3440 p->type = 0;
3441 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 3442#if defined(PERL_IMPLICIT_CONTEXT)
3443 p->thx = aTHX;
3444#endif
22d4bb9c
CB		 3445 pipe_infromchild_ast(p);
3446
3447 strcpy(wmbx, mbx1);
3448 strcpy(rmbx, mbx2);
3449 return p;
3450}
3451
3452static void
3453pipe_infromchild_ast(pPipe p)
3454{
22d4bb9c
CB		 3455 int iss = p->iosb.status;
3456 int eof = (iss == SS$_ENDOFFILE);
3457 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3458 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 3459#if defined(PERL_IMPLICIT_CONTEXT)
3460 pTHX = p->thx;
3461#endif
22d4bb9c
CB		 3462
3463 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
ebd4d70b 3464 _ckvmssts_noperl(sys$dassgn(p->chan_out));
22d4bb9c
CB		 3465 p->chan_out = 0;
3466 }
3467
3468 /* read completed:
3469 input shutdown if EOF from self (done or shut_on_empty)
3470 output shutdown if closing flag set (my_pclose)
3471 send data/eof from child or eof from self
3472 otherwise, re-read (snarf of data from child)
3473 */
3474
3475 if (p->type == 1) {
3476 p->type = 0;
3477 if (myeof && p->chan_in) { /* input shutdown */
ebd4d70b 3478 _ckvmssts_noperl(sys$dassgn(p->chan_in));
22d4bb9c
CB		 3479 p->chan_in = 0;
3480 }
3481
3482 if (p->chan_out) {
3483 if (myeof || kideof) { /* pass EOF to parent */
ebd4d70b
JM		 3484 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3485 pipe_infromchild_ast, p,
3486 0, 0, 0, 0, 0, 0));
22d4bb9c
CB		 3487 return;
3488 } else if (eof) { /* eat EOF --- fall through to read*/
3489
3490 } else { /* transmit data */
ebd4d70b
JM		 3491 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3492 pipe_infromchild_ast,p,
3493 p->buf, p->iosb.count, 0, 0, 0, 0));
22d4bb9c
CB		 3494 return;
3495 }
3496 }
3497 }
3498
3499 /* everything shut? flag as done */
3500
3501 if (!p->chan_in && !p->chan_out) {
3502 *p->pipe_done = TRUE;
ebd4d70b 3503 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c
CB		 3504 return;
3505 }
3506
3507 /* write completed (or read, if snarfing from child)
3508 if still have input active,
3509 queue read...immediate mode if shut_on_empty so we get EOF if empty
3510 otherwise,
3511 check if Perl reading, generate EOFs as needed
3512 */
3513
3514 if (p->type == 0) {
3515 p->type = 1;
3516 if (p->chan_in) {
3517 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3518 pipe_infromchild_ast,p,
3519 p->buf, p->bufsize, 0, 0, 0, 0);
3520 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
ebd4d70b 3521 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3522 } else { /* send EOFs for extra reads */
3523 p->iosb.status = SS$_ENDOFFILE;
3524 p->iosb.dvispec = 0;
ebd4d70b
JM		 3525 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3526 0, 0, 0,
3527 pipe_infromchild_ast, p, 0, 0, 0, 0));
22d4bb9c
CB		 3528 }
3529 }
3530}
3531
3532static pPipe
fd8cd3a3 3533pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 3534{
22d4bb9c
CB		 3535 pPipe p;
3536 char mbx[64];
3537 unsigned long dviitm = DVI$_DEVBUFSIZ;
3538 struct stat s;
3539 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3540 DSC$K_CLASS_S, mbx};
a480973c 3541 int n = sizeof(Pipe);
22d4bb9c
CB		 3542
3543 /* things like terminals and mbx's don't need this filter */
3544 if (fd && fstat(fd,&s) == 0) {
3545 unsigned long dviitm = DVI$_DEVCHAR, devchar;
cfcfe586
JM		 3546 char device[65];
3547 unsigned short dev_len;
3548 struct dsc$descriptor_s d_dev;
3549 char * cptr;
3550 struct item_list_3 items[3];
3551 int status;
3552 unsigned short dvi_iosb[4];
3553
3554 cptr = getname(fd, out, 1);
ebd4d70b 3555 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
cfcfe586
JM		 3556 d_dev.dsc$a_pointer = out;
3557 d_dev.dsc$w_length = strlen(out);
3558 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3559 d_dev.dsc$b_class = DSC$K_CLASS_S;
3560
3561 items[0].len = 4;
3562 items[0].code = DVI$_DEVCHAR;
3563 items[0].bufadr = &devchar;
3564 items[0].retadr = NULL;
3565 items[1].len = 64;
3566 items[1].code = DVI$_FULLDEVNAM;
3567 items[1].bufadr = device;
3568 items[1].retadr = &dev_len;
3569 items[2].len = 0;
3570 items[2].code = 0;
3571
3572 status = sys$getdviw
3573 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
ebd4d70b 3574 _ckvmssts_noperl(status);
cfcfe586
JM		 3575 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3576 device[dev_len] = 0;
3577
3578 if (!(devchar & DEV$M_DIR)) {
3579 strcpy(out, device);
3580 return 0;
3581 }
3582 }
22d4bb9c
CB		 3583 }
3584
ebd4d70b 3585 _ckvmssts_noperl(lib$get_vm(&n, &p));
22d4bb9c 3586 p->fd_out = dup(fd);
8a646e0b 3587 create_mbx(&p->chan_in, &d_mbx);
ebd4d70b 3588 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939 3589 n = (p->bufsize+1) * sizeof(char);
ebd4d70b 3590 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3591 p->shut_on_empty = FALSE;
3592 p->retry = 0;
3593 p->info = 0;
3594 strcpy(out, mbx);
3595
ebd4d70b
JM		 3596 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3597 pipe_mbxtofd_ast, p,
3598 p->buf, p->bufsize, 0, 0, 0, 0));
22d4bb9c
CB		 3599
3600 return p;
3601}
3602
3603static void
3604pipe_mbxtofd_ast(pPipe p)
3605{
22d4bb9c
CB		 3606 int iss = p->iosb.status;
3607 int done = p->info->done;
3608 int iss2;
3609 int eof = (iss == SS$_ENDOFFILE);
3610 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3611 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 3612#if defined(PERL_IMPLICIT_CONTEXT)
3613 pTHX = p->thx;
3614#endif
22d4bb9c
CB		 3615
3616 if (done && myeof) { /* end piping */
3617 close(p->fd_out);
3618 sys$dassgn(p->chan_in);
3619 *p->pipe_done = TRUE;
ebd4d70b 3620 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c
CB		 3621 return;
3622 }
3623
3624 if (!err && !eof) { /* good data to send to file */
3625 p->buf[p->iosb.count] = '\n';
3626 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3627 if (iss2 < 0) {
3628 p->retry++;
3629 if (p->retry < MAX_RETRY) {
ebd4d70b 3630 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
22d4bb9c
CB		 3631 return;
3632 }
3633 }
3634 p->retry = 0;
3635 } else if (err) {
ebd4d70b 3636 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3637 }
3638
3639
3640 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3641 pipe_mbxtofd_ast, p,
3642 p->buf, p->bufsize, 0, 0, 0, 0);
3643 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
ebd4d70b 3644 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3645}
3646
3647
3648typedef struct _pipeloc PLOC;
3649typedef struct _pipeloc* pPLOC;
3650
3651struct _pipeloc {
3652 pPLOC next;
3653 char dir[NAM$C_MAXRSS+1];
3654};
3655static pPLOC head_PLOC = 0;
3656
5c0ae288 3657void
fd8cd3a3 3658free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 3659{
3660 pPLOC p, pnext;
ff7adb52 3661 pPLOC *pHead = (pPLOC *)head;
5c0ae288 3662
ff7adb52 3663 p = *pHead;
5c0ae288
CL		 3664 while (p) {
3665 pnext = p->next;
e0ef6b43 3666 PerlMem_free(p);
5c0ae288
CL		 3667 p = pnext;
3668 }
ff7adb52 3669 *pHead = 0;
5c0ae288 3670}
22d4bb9c
CB		 3671
3672static void
fd8cd3a3 3673store_pipelocs(pTHX)
22d4bb9c
CB		 3674{
3675 int i;
3676 pPLOC p;
ff7adb52 3677 AV *av = 0;
22d4bb9c
CB		 3678 SV *dirsv;
3679 GV *gv;
3680 char *dir, *x;
3681 char *unixdir;
3682 char temp[NAM$C_MAXRSS+1];
3683 STRLEN n_a;
3684
ff7adb52 3685 if (head_PLOC)
218fdd94 3686 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 3687
22d4bb9c
CB		 3688/* the . directory from @INC comes last */
3689
e0ef6b43 3690 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3691 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3692 p->next = head_PLOC;
3693 head_PLOC = p;
3694 strcpy(p->dir,"./");
3695
3696/* get the directory from $^X */
3697
c5375c28 3698 unixdir = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 3699 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 3700
218fdd94
CL		 3701#ifdef PERL_IMPLICIT_CONTEXT
3702 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3703#else
22d4bb9c 3704 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 3705#endif
22d4bb9c
CB		 3706 strcpy(temp, PL_origargv[0]);
3707 x = strrchr(temp,']');
2497a41f
JM		 3708 if (x == NULL) {
3709 x = strrchr(temp,'>');
3710 if (x == NULL) {
3711 /* It could be a UNIX path */
3712 x = strrchr(temp,'/');
3713 }
3714 }
3715 if (x)
3716 x[1] = '\0';
3717 else {
3718 /* Got a bare name, so use default directory */
3719 temp[0] = '.';
3720 temp[1] = '\0';
3721 }
22d4bb9c 3722
4e205ed6 3723 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
e0ef6b43 3724 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3725 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3726 p->next = head_PLOC;
3727 head_PLOC = p;
3728 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3729 p->dir[NAM$C_MAXRSS] = '\0';
c5375c28 3730 }
22d4bb9c
CB		 3731 }
3732
3733/* reverse order of @INC entries, skip "." since entered above */
3734
218fdd94
CL		 3735#ifdef PERL_IMPLICIT_CONTEXT
3736 if (aTHX)
3737#endif
ff7adb52
CL		 3738 if (PL_incgv) av = GvAVn(PL_incgv);
3739
3740 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB		 3741 dirsv = *av_fetch(av,i,TRUE);
3742
3743 if (SvROK(dirsv)) continue;
3744 dir = SvPVx(dirsv,n_a);
3745 if (strcmp(dir,".") == 0) continue;
4e205ed6 3746 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
22d4bb9c
CB		 3747 continue;
3748
e0ef6b43 3749 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 3750 p->next = head_PLOC;
3751 head_PLOC = p;
3752 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3753 p->dir[NAM$C_MAXRSS] = '\0';
3754 }
3755
3756/* most likely spot (ARCHLIB) put first in the list */
3757
3758#ifdef ARCHLIB_EXP
4e205ed6 3759 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
e0ef6b43 3760 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3761 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3762 p->next = head_PLOC;
3763 head_PLOC = p;
3764 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3765 p->dir[NAM$C_MAXRSS] = '\0';
3766 }
3767#endif
c5375c28 3768 PerlMem_free(unixdir);
22d4bb9c
CB		 3769}
3770
a1887106
JM		 3771static I32
3772Perl_cando_by_name_int
3773 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3774#if !defined(PERL_IMPLICIT_CONTEXT)
3775#define cando_by_name_int Perl_cando_by_name_int
3776#else
3777#define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3778#endif
22d4bb9c
CB		 3779
3780static char *
fd8cd3a3 3781find_vmspipe(pTHX)
22d4bb9c
CB		 3782{
3783 static int vmspipe_file_status = 0;
3784 static char vmspipe_file[NAM$C_MAXRSS+1];
3785
3786 /* already found? Check and use ... need read+execute permission */
3787
3788 if (vmspipe_file_status == 1) {
a1887106
JM		 3789 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3790 && cando_by_name_int
3791 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3792 return vmspipe_file;
3793 }
3794 vmspipe_file_status = 0;
3795 }
3796
3797 /* scan through stored @INC, $^X */
3798
3799 if (vmspipe_file_status == 0) {
3800 char file[NAM$C_MAXRSS+1];
3801 pPLOC p = head_PLOC;
3802
3803 while (p) {
2f4077ca 3804 char * exp_res;
4d743a9b 3805 int dirlen;
22d4bb9c 3806 strcpy(file, p->dir);
4d743a9b
JM		 3807 dirlen = strlen(file);
3808 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
22d4bb9c
CB		 3809 file[NAM$C_MAXRSS] = '\0';
3810 p = p->next;
3811
2f4077ca 3812 exp_res = do_rmsexpand
360732b5 3813 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
2f4077ca 3814 if (!exp_res) continue;
22d4bb9c 3815
a1887106
JM		 3816 if (cando_by_name_int
3817 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3818 && cando_by_name_int
3819 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3820 vmspipe_file_status = 1;
3821 return vmspipe_file;
3822 }
3823 }
3824 vmspipe_file_status = -1; /* failed, use tempfiles */
3825 }
3826
3827 return 0;
3828}
3829
3830static FILE *
fd8cd3a3 3831vmspipe_tempfile(pTHX)
22d4bb9c
CB		 3832{
3833 char file[NAM$C_MAXRSS+1];
3834 FILE *fp;
3835 static int index = 0;
2497a41f
JM		 3836 Stat_t s0, s1;
3837 int cmp_result;
22d4bb9c
CB		 3838
3839 /* create a tempfile */
3840
3841 /* we can't go from W, shr=get to R, shr=get without
3842 an intermediate vulnerable state, so don't bother trying...
3843
3844 and lib$spawn doesn't shr=put, so have to close the write
3845
3846 So... match up the creation date/time and the FID to
3847 make sure we're dealing with the same file
3848
3849 */
3850
3851 index++;
2497a41f
JM		 3852 if (!decc_filename_unix_only) {
3853 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3854 fp = fopen(file,"w");
3855 if (!fp) {
22d4bb9c
CB		 3856 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3857 fp = fopen(file,"w");
3858 if (!fp) {
3859 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3860 fp = fopen(file,"w");
2497a41f
JM		 3861 }
3862 }
3863 }
3864 else {
3865 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3866 fp = fopen(file,"w");
3867 if (!fp) {
3868 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3869 fp = fopen(file,"w");
3870 if (!fp) {
3871 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3872 fp = fopen(file,"w");
3873 }
3874 }
22d4bb9c
CB		 3875 }
3876 if (!fp) return 0; /* we're hosed */
3877
f9ecfa39 3878 fprintf(fp,"$! 'f$verify(0)'\n");
22d4bb9c
CB		 3879 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3880 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3881 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3882 fprintf(fp,"$ perl_on = \"set noon\"\n");
3883 fprintf(fp,"$ perl_exit = \"exit\"\n");
3884 fprintf(fp,"$ perl_del = \"delete\"\n");
3885 fprintf(fp,"$ pif = \"if\"\n");
3886 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 3887 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3888 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 3889 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL		 3890 fprintf(fp,"$! --- build command line to get max possible length\n");
3891 fprintf(fp,"$c=perl_popen_cmd0\n");
3892 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3893 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3894 fprintf(fp,"$x=perl_popen_cmd3\n");
3895 fprintf(fp,"$c=c+x\n");
22d4bb9c 3896 fprintf(fp,"$ perl_on\n");
f9ecfa39 3897 fprintf(fp,"$ 'c'\n");
22d4bb9c 3898 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 3899 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 3900 fprintf(fp,"$ perl_exit 'perl_status'\n");
3901 fsync(fileno(fp));
3902
3903 fgetname(fp, file, 1);
2497a41f 3904 fstat(fileno(fp), (struct stat *)&s0);
22d4bb9c
CB		 3905 fclose(fp);
3906
2497a41f 3907 if (decc_filename_unix_only)
0e5ce2c7 3908 int_tounixspec(file, file, NULL);
22d4bb9c
CB		 3909 fp = fopen(file,"r","shr=get");
3910 if (!fp) return 0;
2497a41f
JM		 3911 fstat(fileno(fp), (struct stat *)&s1);
3912
682e4b71 3913 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
2497a41f 3914 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
22d4bb9c
CB		 3915 fclose(fp);
3916 return 0;
3917 }
3918
3919 return fp;
3920}
3921
3922
cd1191f1
CB		 3923static int vms_is_syscommand_xterm(void)
3924{
3925 const static struct dsc$descriptor_s syscommand_dsc =
3926 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3927
3928 const static struct dsc$descriptor_s decwdisplay_dsc =
3929 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3930
3931 struct item_list_3 items[2];
3932 unsigned short dvi_iosb[4];
3933 unsigned long devchar;
3934 unsigned long devclass;
3935 int status;
3936
3937 /* Very simple check to guess if sys$command is a decterm? */
3938 /* First see if the DECW$DISPLAY: device exists */
3939 items[0].len = 4;
3940 items[0].code = DVI$_DEVCHAR;
3941 items[0].bufadr = &devchar;
3942 items[0].retadr = NULL;
3943 items[1].len = 0;
3944 items[1].code = 0;
3945
3946 status = sys$getdviw
3947 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3948
3949 if ($VMS_STATUS_SUCCESS(status)) {
3950 status = dvi_iosb[0];
3951 }
3952
3953 if (!$VMS_STATUS_SUCCESS(status)) {
3954 SETERRNO(EVMSERR, status);
3955 return -1;
3956 }
3957
3958 /* If it does, then for now assume that we are on a workstation */
3959 /* Now verify that SYS$COMMAND is a terminal */
3960 /* for creating the debugger DECTerm */
3961
3962 items[0].len = 4;
3963 items[0].code = DVI$_DEVCLASS;
3964 items[0].bufadr = &devclass;
3965 items[0].retadr = NULL;
3966 items[1].len = 0;
3967 items[1].code = 0;
3968
3969 status = sys$getdviw
3970 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3971
3972 if ($VMS_STATUS_SUCCESS(status)) {
3973 status = dvi_iosb[0];
3974 }
3975
3976 if (!$VMS_STATUS_SUCCESS(status)) {
3977 SETERRNO(EVMSERR, status);
3978 return -1;
3979 }
3980 else {
3981 if (devclass == DC$_TERM) {
3982 return 0;
3983 }
3984 }
3985 return -1;
3986}
3987
3988/* If we are on a DECTerm, we can pretend to fork xterms when requested */
3989static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3990{
3991 int status;
3992 int ret_stat;
3993 char * ret_char;
3994 char device_name[65];
3995 unsigned short device_name_len;
3996 struct dsc$descriptor_s customization_dsc;
3997 struct dsc$descriptor_s device_name_dsc;
3998 const char * cptr;
3999 char * tptr;
4000 char customization[200];
4001 char title[40];
4002 pInfo info = NULL;
4003 char mbx1[64];
4004 unsigned short p_chan;
4005 int n;
4006 unsigned short iosb[4];
4007 struct item_list_3 items[2];
4008 const char * cust_str =
4009 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4010 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4011 DSC$K_CLASS_S, mbx1};
4012
8cb5d3d5
JM		 4013 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4014 /*---------------------------------------*/
d30c1055 4015 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
8cb5d3d5
JM		 4016
4017
4018 /* Make sure that this is from the Perl debugger */
cd1191f1
CB		 4019 ret_char = strstr(cmd," xterm ");
4020 if (ret_char == NULL)
4021 return NULL;
4022 cptr = ret_char + 7;
4023 ret_char = strstr(cmd,"tty");
4024 if (ret_char == NULL)
4025 return NULL;
4026 ret_char = strstr(cmd,"sleep");
4027 if (ret_char == NULL)
4028 return NULL;
4029
8cb5d3d5
JM		 4030 if (decw_term_port == 0) {
4031 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4032 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4033 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4034
d30c1055 4035 status = lib$find_image_symbol
8cb5d3d5
JM		 4036 (&filename1_dsc,
4037 &decw_term_port_dsc,
4038 (void *)&decw_term_port,
4039 NULL,
4040 0);
4041
4042 /* Try again with the other image name */
4043 if (!$VMS_STATUS_SUCCESS(status)) {
4044
d30c1055 4045 status = lib$find_image_symbol
8cb5d3d5
JM		 4046 (&filename2_dsc,
4047 &decw_term_port_dsc,
4048 (void *)&decw_term_port,
4049 NULL,
4050 0);
4051
4052 }
4053
4054 }
4055
4056
4057 /* No decw$term_port, give it up */
4058 if (!$VMS_STATUS_SUCCESS(status))
4059 return NULL;
4060
cd1191f1
CB		 4061 /* Are we on a workstation? */
4062 /* to do: capture the rows / columns and pass their properties */
4063 ret_stat = vms_is_syscommand_xterm();
4064 if (ret_stat < 0)
4065 return NULL;
4066
4067 /* Make the title: */
4068 ret_char = strstr(cptr,"-title");
4069 if (ret_char != NULL) {
4070 while ((*cptr != 0) && (*cptr != '\"')) {
4071 cptr++;
4072 }
4073 if (*cptr == '\"')
4074 cptr++;
4075 n = 0;
4076 while ((*cptr != 0) && (*cptr != '\"')) {
4077 title[n] = *cptr;
4078 n++;
4079 if (n == 39) {
4080 title[39] == 0;
4081 break;
4082 }
4083 cptr++;
4084 }
4085 title[n] = 0;
4086 }
4087 else {
4088 /* Default title */
4089 strcpy(title,"Perl Debug DECTerm");
4090 }
4091 sprintf(customization, cust_str, title);
4092
4093 customization_dsc.dsc$a_pointer = customization;
4094 customization_dsc.dsc$w_length = strlen(customization);
4095 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4096 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4097
4098 device_name_dsc.dsc$a_pointer = device_name;
4099 device_name_dsc.dsc$w_length = sizeof device_name -1;
4100 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4101 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4102
4103 device_name_len = 0;
4104
4105 /* Try to create the window */
8cb5d3d5 4106 status = (*decw_term_port)
cd1191f1
CB		 4107 (NULL,
4108 NULL,
4109 &customization_dsc,
4110 &device_name_dsc,
4111 &device_name_len,
4112 NULL,
4113 NULL,
4114 NULL);
4115 if (!$VMS_STATUS_SUCCESS(status)) {
4116 SETERRNO(EVMSERR, status);
4117 return NULL;
4118 }
4119
4120 device_name[device_name_len] = '\0';
4121
4122 /* Need to set this up to look like a pipe for cleanup */
4123 n = sizeof(Info);
4124 status = lib$get_vm(&n, &info);
4125 if (!$VMS_STATUS_SUCCESS(status)) {
4126 SETERRNO(ENOMEM, status);
4127 return NULL;
4128 }
4129
4130 info->mode = *mode;
4131 info->done = FALSE;
4132 info->completion = 0;
4133 info->closing = FALSE;
4134 info->in = 0;
4135 info->out = 0;
4136 info->err = 0;
4e205ed6 4137 info->fp = NULL;
cd1191f1
CB		 4138 info->useFILE = 0;
4139 info->waiting = 0;
4140 info->in_done = TRUE;
4141 info->out_done = TRUE;
4142 info->err_done = TRUE;
4143
4144 /* Assign a channel on this so that it will persist, and not login */
4145 /* We stash this channel in the info structure for reference. */
4146 /* The created xterm self destructs when the last channel is removed */
4147 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4148 /* So leave this assigned. */
4149 device_name_dsc.dsc$w_length = device_name_len;
4150 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4151 if (!$VMS_STATUS_SUCCESS(status)) {
4152 SETERRNO(EVMSERR, status);
4153 return NULL;
4154 }
4155 info->xchan_valid = 1;
4156
4157 /* Now create a mailbox to be read by the application */
4158
8a646e0b 4159 create_mbx(&p_chan, &d_mbx1);
cd1191f1
CB		 4160
4161 /* write the name of the created terminal to the mailbox */
4162 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4163 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4164
4165 if (!$VMS_STATUS_SUCCESS(status)) {
4166 SETERRNO(EVMSERR, status);
4167 return NULL;
4168 }
4169
4170 info->fp = PerlIO_open(mbx1, mode);
4171
4172 /* Done with this channel */
4173 sys$dassgn(p_chan);
4174
4175 /* If any errors, then clean up */
4176 if (!info->fp) {
4177 n = sizeof(Info);
ebd4d70b 4178 _ckvmssts_noperl(lib$free_vm(&n, &info));
cd1191f1
CB		 4179 return NULL;
4180 }
4181
4182 /* All done */
4183 return info->fp;
4184}
22d4bb9c 4185
ebd4d70b
JM		 4186static I32 my_pclose_pinfo(pTHX_ pInfo info);
4187
8fde5078 4188static PerlIO *
2fbb330f 4189safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
a0d0e21e 4190{
748a9306 4191 static int handler_set_up = FALSE;
ebd4d70b 4192 PerlIO * ret_fp;
55f2b99c 4193 unsigned long int sts, flags = CLI$M_NOWAIT;
f9ecfa39
PP		 4194 /* The use of a GLOBAL table (as was done previously) rendered
4195 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4196 * environment. Hence we've switched to LOCAL symbol table.
4197 */
4198 unsigned int table = LIB$K_CLI_LOCAL_SYM;
d4c83939 4199 int j, wait = 0, n;
ff7adb52 4200 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
cfcfe586 4201 char *in, *out, *err, mbx[512];
22d4bb9c
CB		 4202 FILE *tpipe = 0;
4203 char tfilebuf[NAM$C_MAXRSS+1];
d4c83939 4204 pInfo info = NULL;
48b5a746 4205 char cmd_sym_name[20];
22d4bb9c
CB		 4206 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4207 DSC$K_CLASS_S, symbol};
22d4bb9c 4208 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
a0d0e21e 4209 DSC$K_CLASS_S, 0};
48b5a746
CL		 4210 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4211 DSC$K_CLASS_S, cmd_sym_name};
218fdd94 4212 struct dsc$descriptor_s *vmscmd;
22d4bb9c 4213 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
0e06870b 4214 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
22d4bb9c 4215 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
cd1191f1 4216
cd1191f1
CB		 4217 /* Check here for Xterm create request. This means looking for
4218 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4219 * is possible to create an xterm.
4220 */
4221 if (*in_mode == 'r') {
4222 PerlIO * xterm_fd;
4223
4224 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4e205ed6 4225 if (xterm_fd != NULL)
cd1191f1
CB		 4226 return xterm_fd;
4227 }
cd1191f1 4228
afd8f436
JH		 4229 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4230
22d4bb9c
CB		 4231 /* once-per-program initialization...
4232 note that the SETAST calls and the dual test of pipe_ef
4233 makes sure that only the FIRST thread through here does
4234 the initialization...all other threads wait until it's
4235 done.
4236
4237 Yeah, uglier than a pthread call, it's got all the stuff inline
4238 rather than in a separate routine.
4239 */
4240
4241 if (!pipe_ef) {
ebd4d70b 4242 _ckvmssts_noperl(sys$setast(0));
22d4bb9c
CB		 4243 if (!pipe_ef) {
4244 unsigned long int pidcode = JPI$_PID;
4245 $DESCRIPTOR(d_delay, RETRY_DELAY);
ebd4d70b
JM		 4246 _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4247 _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4248 _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
22d4bb9c
CB		 4249 }
4250 if (!handler_set_up) {
ebd4d70b 4251 _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
22d4bb9c
CB		 4252 handler_set_up = TRUE;
4253 }
ebd4d70b 4254 _ckvmssts_noperl(sys$setast(1));
22d4bb9c
CB		 4255 }
4256
4257 /* see if we can find a VMSPIPE.COM */
4258
4259 tfilebuf[0] = '@';
fd8cd3a3 4260 vmspipe = find_vmspipe(aTHX);
22d4bb9c
CB		 4261 if (vmspipe) {
4262 strcpy(tfilebuf+1,vmspipe);
4263 } else { /* uh, oh...we're in tempfile hell */
fd8cd3a3 4264 tpipe = vmspipe_tempfile(aTHX);
22d4bb9c
CB		 4265 if (!tpipe) { /* a fish popular in Boston */
4266 if (ckWARN(WARN_PIPE)) {
f98bc0c6 4267 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
22d4bb9c 4268 }
4e205ed6 4269 return NULL;
22d4bb9c
CB		 4270 }
4271 fgetname(tpipe,tfilebuf+1,1);
4272 }
4273 vmspipedsc.dsc$a_pointer = tfilebuf;
4274 vmspipedsc.dsc$w_length = strlen(tfilebuf);
a0d0e21e 4275
218fdd94 4276 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
a2669cfc
JH		 4277 if (!(sts & 1)) {
4278 switch (sts) {
4279 case RMS$_FNF: case RMS$_DNF:
4280 set_errno(ENOENT); break;
4281 case RMS$_DIR:
4282 set_errno(ENOTDIR); break;
4283 case RMS$_DEV:
4284 set_errno(ENODEV); break;
4285 case RMS$_PRV:
4286 set_errno(EACCES); break;
4287 case RMS$_SYN:
4288 set_errno(EINVAL); break;
4289 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4290 set_errno(E2BIG); break;
4291 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 4292 _ckvmssts_noperl(sts); /* fall through */
a2669cfc
JH		 4293 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4294 set_errno(EVMSERR);
4295 }
4296 set_vaxc_errno(sts);
cd1191f1 4297 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
f98bc0c6 4298 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
a2669cfc 4299 }
ff7adb52 4300 *psts = sts;
4e205ed6 4301 return NULL;
a2669cfc 4302 }
d4c83939 4303 n = sizeof(Info);
ebd4d70b 4304 _ckvmssts_noperl(lib$get_vm(&n, &info));
22d4bb9c 4305
ff7adb52 4306 strcpy(mode,in_mode);
22d4bb9c
CB		 4307 info->mode = *mode;
4308 info->done = FALSE;
4309 info->completion = 0;
4310 info->closing = FALSE;
4311 info->in = 0;
4312 info->out = 0;
4313 info->err = 0;
4e205ed6 4314 info->fp = NULL;
ff7adb52
CL		 4315 info->useFILE = 0;
4316 info->waiting = 0;
22d4bb9c
CB		 4317 info->in_done = TRUE;
4318 info->out_done = TRUE;
4319 info->err_done = TRUE;
cd1191f1
CB		 4320 info->xchan = 0;
4321 info->xchan_valid = 0;
cfcfe586
JM		 4322
4323 in = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4324 if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
cfcfe586 4325 out = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4326 if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
cfcfe586 4327 err = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4328 if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
cfcfe586 4329
0e06870b 4330 in[0] = out[0] = err[0] = '\0';
22d4bb9c 4331
ff7adb52
CL		 4332 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4333 info->useFILE = 1;
4334 strcpy(p,p+1);
4335 }
4336 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4337 wait = 1;
4338 strcpy(p,p+1);
4339 }
4340
22d4bb9c 4341 if (*mode == 'r') { /* piping from subroutine */
22d4bb9c 4342
fd8cd3a3 4343 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
22d4bb9c
CB		 4344 if (info->out) {
4345 info->out->pipe_done = &info->out_done;
4346 info->out_done = FALSE;
4347 info->out->info = info;
4348 }
ff7adb52 4349 if (!info->useFILE) {
cd1191f1 4350 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 4351 } else {
4352 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4353 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4354 }
4355
22d4bb9c
CB		 4356 if (!info->fp && info->out) {
4357 sys$cancel(info->out->chan_out);
4358
4359 while (!info->out_done) {
4360 int done;
ebd4d70b 4361 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 4362 done = info->out_done;
ebd4d70b
JM		 4363 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4364 _ckvmssts_noperl(sys$setast(1));
4365 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
0e06870b 4366 }
22d4bb9c 4367
d4c83939
CB		 4368 if (info->out->buf) {
4369 n = info->out->bufsize * sizeof(char);
ebd4d70b 4370 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
d4c83939
CB		 4371 }
4372 n = sizeof(Pipe);
ebd4d70b 4373 _ckvmssts_noperl(lib$free_vm(&n, &info->out));
d4c83939 4374 n = sizeof(Info);
ebd4d70b 4375 _ckvmssts_noperl(lib$free_vm(&n, &info));
ff7adb52 4376 *psts = RMS$_FNF;
4e205ed6 4377 return NULL;
0e06870b 4378 }
22d4bb9c 4379
fd8cd3a3 4380 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
22d4bb9c
CB		 4381 if (info->err) {
4382 info->err->pipe_done = &info->err_done;
4383 info->err_done = FALSE;
4384 info->err->info = info;
4385 }
a0d0e21e 4386
ff7adb52
CL		 4387 } else if (*mode == 'w') { /* piping to subroutine */
4388
4389 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4390 if (info->out) {
4391 info->out->pipe_done = &info->out_done;
4392 info->out_done = FALSE;
4393 info->out->info = info;
4394 }
4395
4396 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4397 if (info->err) {
4398 info->err->pipe_done = &info->err_done;
4399 info->err_done = FALSE;
4400 info->err->info = info;
4401 }
a0d0e21e 4402
fd8cd3a3 4403 info->in = pipe_tochild_setup(aTHX_ in,mbx);
ff7adb52 4404 if (!info->useFILE) {
a480973c 4405 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 4406 } else {
4407 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4408 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4409 }
4410
22d4bb9c
CB		 4411 if (info->in) {
4412 info->in->pipe_done = &info->in_done;
4413 info->in_done = FALSE;
4414 info->in->info = info;
4415 }
a0d0e21e 4416
22d4bb9c
CB		 4417 /* error cleanup */
4418 if (!info->fp && info->in) {
4419 info->done = TRUE;
ebd4d70b
JM		 4420 _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4421 0, 0, 0, 0, 0, 0, 0, 0));
22d4bb9c
CB		 4422
4423 while (!info->in_done) {
4424 int done;
ebd4d70b 4425 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 4426 done = info->in_done;
ebd4d70b
JM		 4427 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4428 _ckvmssts_noperl(sys$setast(1));
4429 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
22d4bb9c 4430 }
a0d0e21e 4431
d4c83939
CB		 4432 if (info->in->buf) {
4433 n = info->in->bufsize * sizeof(char);
ebd4d70b 4434 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
d4c83939
CB		 4435 }
4436 n = sizeof(Pipe);
ebd4d70b 4437 _ckvmssts_noperl(lib$free_vm(&n, &info->in));
d4c83939 4438 n = sizeof(Info);
ebd4d70b 4439 _ckvmssts_noperl(lib$free_vm(&n, &info));
ff7adb52 4440 *psts = RMS$_FNF;
4e205ed6 4441 return NULL;
22d4bb9c 4442 }
a0d0e21e 4443
22d4bb9c 4444
ff7adb52 4445 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
fd8cd3a3 4446 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
22d4bb9c
CB		 4447 if (info->out) {
4448 info->out->pipe_done = &info->out_done;
4449 info->out_done = FALSE;
4450 info->out->info = info;
4451 }
0e06870b 4452
fd8cd3a3 4453 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
0e06870b
CB		 4454 if (info->err) {
4455 info->err->pipe_done = &info->err_done;
4456 info->err_done = FALSE;
4457 info->err->info = info;
4458 }
748a9306 4459 }
22d4bb9c
CB		 4460
4461 symbol[MAX_DCL_SYMBOL] = '\0';
4462
4463 strncpy(symbol, in, MAX_DCL_SYMBOL);
4464 d_symbol.dsc$w_length = strlen(symbol);
ebd4d70b 4465 _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
22d4bb9c
CB		 4466
4467 strncpy(symbol, err, MAX_DCL_SYMBOL);
4468 d_symbol.dsc$w_length = strlen(symbol);
ebd4d70b 4469 _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
22d4bb9c 4470
0e06870b
CB		 4471 strncpy(symbol, out, MAX_DCL_SYMBOL);
4472 d_symbol.dsc$w_length = strlen(symbol);
ebd4d70b 4473 _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
22d4bb9c 4474
cfcfe586
JM		 4475 /* Done with the names for the pipes */
4476 PerlMem_free(err);
4477 PerlMem_free(out);
4478 PerlMem_free(in);
4479
218fdd94 4480 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB		 4481 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4482 if (*p == '$') p++; /* remove leading $ */
4483 while (*p == ' ' || *p == '\t') p++;
48b5a746
CL		 4484
4485 for (j = 0; j < 4; j++) {
4486 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4487 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4488
22d4bb9c
CB		 4489 strncpy(symbol, p, MAX_DCL_SYMBOL);
4490 d_symbol.dsc$w_length = strlen(symbol);
ebd4d70b 4491 _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
22d4bb9c 4492
48b5a746
CL		 4493 if (strlen(p) > MAX_DCL_SYMBOL) {
4494 p += MAX_DCL_SYMBOL;
4495 } else {
4496 p += strlen(p);
4497 }
4498 }
ebd4d70b 4499 _ckvmssts_noperl(sys$setast(0));
a0d0e21e
LW		 4500 info->next=open_pipes; /* prepend to list */
4501 open_pipes=info;
ebd4d70b 4502 _ckvmssts_noperl(sys$setast(1));
55f2b99c
CB		 4503 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4504 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4505 * have SYS$COMMAND if we need it.
4506 */
ebd4d70b 4507 _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
22d4bb9c
CB		 4508 0, &info->pid, &info->completion,
4509 0, popen_completion_ast,info,0,0,0));
4510
4511 /* if we were using a tempfile, close it now */
4512
4513 if (tpipe) fclose(tpipe);
4514
ff7adb52 4515 /* once the subprocess is spawned, it has copied the symbols and
22d4bb9c
CB		 4516 we can get rid of ours */
4517
48b5a746
CL		 4518 for (j = 0; j < 4; j++) {
4519 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4520 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
ebd4d70b 4521 _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
48b5a746 4522 }
ebd4d70b
JM		 4523 _ckvmssts_noperl(lib$delete_symbol(&d_sym_in, &table));
4524 _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4525 _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
218fdd94 4526 vms_execfree(vmscmd);
a0d0e21e 4527
218fdd94
CL		 4528#ifdef PERL_IMPLICIT_CONTEXT
4529 if (aTHX)
4530#endif
6b88bc9c 4531 PL_forkprocess = info->pid;
218fdd94 4532
ebd4d70b 4533 ret_fp = info->fp;
ff7adb52 4534 if (wait) {
ebd4d70b 4535 dSAVEDERRNO;
ff7adb52
CL		 4536 int done = 0;
4537 while (!done) {
ebd4d70b 4538 _ckvmssts_noperl(sys$setast(0));
ff7adb52 4539 done = info->done;
ebd4d70b
JM		 4540 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4541 _ckvmssts_noperl(sys$setast(1));
4542 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
ff7adb52
CL		 4543 }
4544 *psts = info->completion;
2fbb330f
JM		 4545/* Caller thinks it is open and tries to close it. */
4546/* This causes some problems, as it changes the error status */
4547/* my_pclose(info->fp); */
ebd4d70b
JM		 4548
4549 /* If we did not have a file pointer open, then we have to */
4550 /* clean up here or eventually we will run out of something */
4551 SAVE_ERRNO;
4552 if (info->fp == NULL) {
4553 my_pclose_pinfo(aTHX_ info);
4554 }
4555 RESTORE_ERRNO;
4556
ff7adb52 4557 } else {
eed5d6a1 4558 *psts = info->pid;
ff7adb52 4559 }
ebd4d70b 4560 return ret_fp;
1e422769 4561} /* end of safe_popen */
4562
4563
a15cef0c
CB		 4564/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4565PerlIO *
2fbb330f 4566Perl_my_popen(pTHX_ const char *cmd, const char *mode)
1e422769 4567{
ff7adb52 4568 int sts;
1e422769 4569 TAINT_ENV();
4570 TAINT_PROPER("popen");
45bc9206 4571 PERL_FLUSHALL_FOR_CHILD;
ff7adb52 4572 return safe_popen(aTHX_ cmd,mode,&sts);
a0d0e21e 4573}
1e422769 4574
a0d0e21e
LW		 4575/*}}}*/
4576
ebd4d70b
JM		 4577
4578/* Routine to close and cleanup a pipe info structure */
4579
4580static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4581
748a9306 4582 unsigned long int retsts;
d4c83939 4583 int done, iss, n;
cd1191f1 4584 int status;
ebd4d70b 4585 pInfo next, last;
748a9306 4586
bbce6d69 4587 /* If we were writing to a subprocess, insure that someone reading from
4588 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
22d4bb9c
CB		 4589 * produce an EOF record in the mailbox.
4590 *
4591 * well, at least sometimes it *does*, so we have to watch out for
4592 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4593 */
ff7adb52 4594 if (info->fp) {
5ce486e0
CB		 4595 if (!info->useFILE
4596#if defined(USE_ITHREADS)
4597 && my_perl
4598#endif
4599 && PL_perlio_fd_refcnt)
4600 PerlIO_flush(info->fp);
ff7adb52
CL		 4601 else
4602 fflush((FILE *)info->fp);
4603 }
22d4bb9c 4604
b08af3f0 4605 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 4606 info->closing = TRUE;
4607 done = info->done && info->in_done && info->out_done && info->err_done;
4608 /* hanging on write to Perl's input? cancel it */
4609 if (info->mode == 'r' && info->out && !info->out_done) {
4610 if (info->out->chan_out) {
4611 _ckvmssts(sys$cancel(info->out->chan_out));
4612 if (!info->out->chan_in) { /* EOF generation, need AST */
4613 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4614 }
4615 }
4616 }
4617 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4618 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4619 0, 0, 0, 0, 0, 0));
b08af3f0 4620 _ckvmssts(sys$setast(1));
ff7adb52 4621 if (info->fp) {
5ce486e0
CB		 4622 if (!info->useFILE
4623#if defined(USE_ITHREADS)
4624 && my_perl
4625#endif
4626 && PL_perlio_fd_refcnt)
d4c83939 4627 PerlIO_close(info->fp);
ff7adb52
CL		 4628 else
4629 fclose((FILE *)info->fp);
4630 }
22d4bb9c
CB		 4631 /*
4632 we have to wait until subprocess completes, but ALSO wait until all
4633 the i/o completes...otherwise we'll be freeing the "info" structure
4634 that the i/o ASTs could still be using...
4635 */
4636
4637 while (!done) {
4638 _ckvmssts(sys$setast(0));
4639 done = info->done && info->in_done && info->out_done && info->err_done;
4640 if (!done) _ckvmssts(sys$clref(pipe_ef));
4641 _ckvmssts(sys$setast(1));
4642 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4643 }
4644 retsts = info->completion;
a0d0e21e 4645
a0d0e21e 4646 /* remove from list of open pipes */
b08af3f0 4647 _ckvmssts(sys$setast(0));
ebd4d70b
JM		 4648 last = NULL;
4649 for (next = open_pipes; next != NULL; last = next, next = next->next) {
4650 if (next == info)
4651 break;
4652 }
4653
4654 if (last)
4655 last->next = info->next;
4656 else
4657 open_pipes = info->next;
b08af3f0 4658 _ckvmssts(sys$setast(1));
22d4bb9c
CB		 4659
4660 /* free buffers and structures */
4661
4662 if (info->in) {
d4c83939
CB		 4663 if (info->in->buf) {
4664 n = info->in->bufsize * sizeof(char);
4665 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4666 }
4667 n = sizeof(Pipe);
4668 _ckvmssts(lib$free_vm(&n, &info->in));
22d4bb9c
CB		 4669 }
4670 if (info->out) {
d4c83939
CB		 4671 if (info->out->buf) {
4672 n = info->out->bufsize * sizeof(char);
4673 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4674 }
4675 n = sizeof(Pipe);
4676 _ckvmssts(lib$free_vm(&n, &info->out));
22d4bb9c
CB		 4677 }
4678 if (info->err) {
d4c83939
CB		 4679 if (info->err->buf) {
4680 n = info->err->bufsize * sizeof(char);
4681 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4682 }
4683 n = sizeof(Pipe);
4684 _ckvmssts(lib$free_vm(&n, &info->err));
22d4bb9c 4685 }
d4c83939
CB		 4686 n = sizeof(Info);
4687 _ckvmssts(lib$free_vm(&n, &info));
a0d0e21e
LW		 4688
4689 return retsts;
ebd4d70b
JM		 4690}
4691
4692
4693/*{{{ I32 my_pclose(PerlIO *fp)*/
4694I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4695{
4696 pInfo info, last = NULL;
4697 I32 ret_status;
4698
4699 /* Fixme - need ast and mutex protection here */
4700 for (info = open_pipes; info != NULL; last = info, info = info->next)
4701 if (info->fp == fp) break;
4702
4703 if (info == NULL) { /* no such pipe open */
4704 set_errno(ECHILD); /* quoth POSIX */
4705 set_vaxc_errno(SS$_NONEXPR);
4706 return -1;
4707 }
4708
4709 ret_status = my_pclose_pinfo(aTHX_ info);
4710
4711 return ret_status;
748a9306 4712
a0d0e21e
LW		 4713} /* end of my_pclose() */
4714
119586db 4715#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB		 4716 /* Roll our own prototype because we want this regardless of whether
4717 * _VMS_WAIT is defined.
4718 */
4719 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4720#endif
4721/* sort-of waitpid; special handling of pipe clean-up for subprocesses
4722 created with popen(); otherwise partially emulate waitpid() unless
4723 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4724 Also check processes not considered by the CRTL waitpid().
4725 */
4fdae800 4726/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4727Pid_t
fd8cd3a3 4728Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
a0d0e21e 4729{
22d4bb9c
CB		 4730 pInfo info;
4731 int done;
aeb5cf3c 4732 int sts;
d85f548a 4733 int j;
aeb5cf3c
CB		 4734
4735 if (statusp) *statusp = 0;
a0d0e21e
LW		 4736
4737 for (info = open_pipes; info != NULL; info = info->next)
4738 if (info->pid == pid) break;
4739
4740 if (info != NULL) { /* we know about this child */
748a9306 4741 while (!info->done) {
22d4bb9c
CB		 4742 _ckvmssts(sys$setast(0));
4743 done = info->done;
4744 if (!done) _ckvmssts(sys$clref(pipe_ef));
4745 _ckvmssts(sys$setast(1));
4746 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
a0d0e21e
LW		 4747 }
4748
aeb5cf3c 4749 if (statusp) *statusp = info->completion;
a0d0e21e 4750 return pid;
d85f548a
JH		 4751 }
4752
4753 /* child that already terminated? */
aeb5cf3c 4754
d85f548a
JH		 4755 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4756 if (closed_list[j].pid == pid) {
4757 if (statusp) *statusp = closed_list[j].completion;
4758 return pid;
4759 }
a0d0e21e 4760 }
d85f548a
JH		 4761
4762 /* fall through if this child is not one of our own pipe children */
aeb5cf3c 4763
119586db 4764#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB		 4765
4766 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4767 * in 7.2 did we get a version that fills in the VMS completion
4768 * status as Perl has always tried to do.
4769 */
4770
4771 sts = __vms_waitpid( pid, statusp, flags );
4772
4773 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4774 return sts;
4775
4776 /* If the real waitpid tells us the child does not exist, we
4777 * fall through here to implement waiting for a child that
4778 * was created by some means other than exec() (say, spawned
4779 * from DCL) or to wait for a process that is not a subprocess
4780 * of the current process.
4781 */
4782
119586db 4783#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
aeb5cf3c 4784
21bc9d50 4785 {
a0d0e21e 4786 $DESCRIPTOR(intdsc,"0 00:00:01");
aeb5cf3c
CB		 4787 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4788 unsigned long int pidcode = JPI$_PID, mypid;
4789 unsigned long int interval[2];
aeb5cf3c 4790 unsigned int jpi_iosb[2];
d85f548a 4791 struct itmlst_3 jpilist[2] = {
aeb5cf3c 4792 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
aeb5cf3c
CB		 4793 { 0, 0, 0, 0}
4794 };
aeb5cf3c
CB		 4795
4796 if (pid <= 0) {
4797 /* Sorry folks, we don't presently implement rooting around for
4798 the first child we can find, and we definitely don't want to
4799 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4800 */
4801 set_errno(ENOTSUP);
4802 return -1;
4803 }
4804
d85f548a
JH		 4805 /* Get the owner of the child so I can warn if it's not mine. If the
4806 * process doesn't exist or I don't have the privs to look at it,
4807 * I can go home early.
aeb5cf3c
CB		 4808 */
4809 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4810 if (sts & 1) sts = jpi_iosb[0];
4811 if (!(sts & 1)) {
4812 switch (sts) {
4813 case SS$_NONEXPR:
4814 set_errno(ECHILD);
4815 break;
4816 case SS$_NOPRIV:
4817 set_errno(EACCES);
4818 break;
4819 default:
4820 _ckvmssts(sts);
4821 }
4822 set_vaxc_errno(sts);
4823 return -1;
4824 }
a0d0e21e 4825
3eeba6fb 4826 if (ckWARN(WARN_EXEC)) {
aeb5cf3c
CB		 4827 /* remind folks they are asking for non-standard waitpid behavior */
4828 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
748a9306 4829 if (ownerpid != mypid)
f98bc0c6 4830 Perl_warner(aTHX_ packWARN(WARN_EXEC),
aeb5cf3c
CB		 4831 "waitpid: process %x is not a child of process %x",
4832 pid,mypid);
748a9306 4833 }
a0d0e21e 4834
d85f548a
JH		 4835 /* simply check on it once a second until it's not there anymore. */
4836
4837 _ckvmssts(sys$bintim(&intdsc,interval));
4838 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
aeb5cf3c
CB		 4839 _ckvmssts(sys$schdwk(0,0,interval,0));
4840 _ckvmssts(sys$hiber());
d85f548a
JH		 4841 }
4842 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
aeb5cf3c
CB		 4843
4844 _ckvmssts(sts);
a0d0e21e 4845 return pid;
21bc9d50 4846 }
a0d0e21e 4847} /* end of waitpid() */
a0d0e21e
LW		 4848/*}}}*/
4849/*}}}*/
4850/*}}}*/
4851
4852/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4853char *
4854my_gconvert(double val, int ndig, int trail, char *buf)
4855{
4856 static char __gcvtbuf[DBL_DIG+1];
4857 char *loc;
4858
4859 loc = buf ? buf : __gcvtbuf;
71be2cbc 4860
4861#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4862 if (val < 1) {
4863 sprintf(loc,"%.*g",ndig,val);
4864 return loc;
4865 }
4866#endif
4867
a0d0e21e
LW		 4868 if (val) {
4869 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4870 return gcvt(val,ndig,loc);
4871 }
4872 else {
4873 loc[0] = '0'; loc[1] = '\0';
4874 return loc;
4875 }
4876
4877}
4878/*}}}*/
4879
988c775c 4880#if defined(__VAX) || !defined(NAML$C_MAXRSS)
a480973c
JM		 4881static int rms_free_search_context(struct FAB * fab)
4882{
4883struct NAM * nam;
4884
4885 nam = fab->fab$l_nam;
4886 nam->nam$b_nop |= NAM$M_SYNCHK;
4887 nam->nam$l_rlf = NULL;
4888 fab->fab$b_dns = 0;
4889 return sys$parse(fab, NULL, NULL);
4890}
4891
4892#define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4d743a9b 4893#define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
a480973c
JM		 4894#define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4895#define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4896#define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4897#define rms_nam_esll(nam) nam.nam$b_esl
4898#define rms_nam_esl(nam) nam.nam$b_esl
4899#define rms_nam_name(nam) nam.nam$l_name
4900#define rms_nam_namel(nam) nam.nam$l_name
4901#define rms_nam_type(nam) nam.nam$l_type
4902#define rms_nam_typel(nam) nam.nam$l_type
4903#define rms_nam_ver(nam) nam.nam$l_ver
4904#define rms_nam_verl(nam) nam.nam$l_ver
4905#define rms_nam_rsll(nam) nam.nam$b_rsl
4906#define rms_nam_rsl(nam) nam.nam$b_rsl
4907#define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4908#define rms_set_fna(fab, nam, name, size) \
a1887106 4909 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
a480973c
JM		 4910#define rms_get_fna(fab, nam) fab.fab$l_fna
4911#define rms_set_dna(fab, nam, name, size) \
a1887106
JM		 4912 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4913#define rms_nam_dns(fab, nam) fab.fab$b_dns
d584a1c6 4914#define rms_set_esa(nam, name, size) \
a1887106 4915 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
a480973c 4916#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4917 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
a480973c 4918#define rms_set_rsa(nam, name, size) \
a1887106 4919 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
a480973c 4920#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106
JM		 4921 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4922#define rms_nam_name_type_l_size(nam) \
4923 (nam.nam$b_name + nam.nam$b_type)
a480973c
JM		 4924#else
4925static int rms_free_search_context(struct FAB * fab)
4926{
4927struct NAML * nam;
4928
4929 nam = fab->fab$l_naml;
4930 nam->naml$b_nop |= NAM$M_SYNCHK;
4931 nam->naml$l_rlf = NULL;
4932 nam->naml$l_long_defname_size = 0;
988c775c 4933
a480973c
JM		 4934 fab->fab$b_dns = 0;
4935 return sys$parse(fab, NULL, NULL);
4936}
4937
4938#define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4d743a9b 4939#define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
a480973c
JM		 4940#define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4941#define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4942#define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4943#define rms_nam_esll(nam) nam.naml$l_long_expand_size
4944#define rms_nam_esl(nam) nam.naml$b_esl
4945#define rms_nam_name(nam) nam.naml$l_name
4946#define rms_nam_namel(nam) nam.naml$l_long_name
4947#define rms_nam_type(nam) nam.naml$l_type
4948#define rms_nam_typel(nam) nam.naml$l_long_type
4949#define rms_nam_ver(nam) nam.naml$l_ver
4950#define rms_nam_verl(nam) nam.naml$l_long_ver
4951#define rms_nam_rsll(nam) nam.naml$l_long_result_size
4952#define rms_nam_rsl(nam) nam.naml$b_rsl
4953#define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4954#define rms_set_fna(fab, nam, name, size) \
a1887106 4955 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
a480973c 4956 nam.naml$l_long_filename_size = size; \
a1887106 4957 nam.naml$l_long_filename = name;}
a480973c
JM		 4958#define rms_get_fna(fab, nam) nam.naml$l_long_filename
4959#define rms_set_dna(fab, nam, name, size) \
a1887106 4960 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
a480973c 4961 nam.naml$l_long_defname_size = size; \
a1887106 4962 nam.naml$l_long_defname = name; }
a480973c 4963#define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
d584a1c6 4964#define rms_set_esa(nam, name, size) \
a1887106 4965 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
a480973c 4966 nam.naml$l_long_expand_alloc = size; \
a1887106 4967 nam.naml$l_long_expand = name; }
a480973c 4968#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4969 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
a480973c 4970 nam.naml$l_long_expand = l_name; \
a1887106 4971 nam.naml$l_long_expand_alloc = l_size; }
a480973c 4972#define rms_set_rsa(nam, name, size) \
a1887106 4973 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
a480973c 4974 nam.naml$l_long_result = name; \
a1887106 4975 nam.naml$l_long_result_alloc = size; }
a480973c 4976#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106 4977 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
a480973c 4978 nam.naml$l_long_result = l_name; \
a1887106
JM		 4979 nam.naml$l_long_result_alloc = l_size; }
4980#define rms_nam_name_type_l_size(nam) \
4981 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
a480973c
JM		 4982#endif
4983
4fdf8f88 4984
e0e5e8d6
JM		 4985/* rms_erase
4986 * The CRTL for 8.3 and later can create symbolic links in any mode,
4fdf8f88 4987 * however in 8.3 the unlink/remove/delete routines will only properly handle
e0e5e8d6 4988 * them if one of the PCP modes is active.
e0e5e8d6
JM		 4989 */
4990static int rms_erase(const char * vmsname)
4991{
4992 int status;
4993 struct FAB myfab = cc$rms_fab;
4994 rms_setup_nam(mynam);
4995
4996 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4997 rms_bind_fab_nam(myfab, mynam);
4fdf8f88 4998
e0e5e8d6
JM		 4999 /* Are we removing all versions? */
5000 if (vms_unlink_all_versions == 1) {
5001 const char * defspec = ";*";
5002 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5003 }
5004
5005#ifdef NAML$M_OPEN_SPECIAL
5006 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5007#endif
5008
d30c1055 5009 status = sys$erase(&myfab, 0, 0);
e0e5e8d6
JM		 5010
5011 return status;
5012}
5013
bbce6d69 5014
4fdf8f88
JM		 5015static int
5016vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5017 const struct dsc$descriptor_s * vms_dst_dsc,
5018 unsigned long flags)
5019{
5020 /* VMS and UNIX handle file permissions differently and the
5021 * the same ACL trick may be needed for renaming files,
5022 * especially if they are directories.
5023 */
5024
5025 /* todo: get kill_file and rename to share common code */
5026 /* I can not find online documentation for $change_acl
5027 * it appears to be replaced by $set_security some time ago */
5028
5029const unsigned int access_mode = 0;
5030$DESCRIPTOR(obj_file_dsc,"FILE");
5031char *vmsname;
5032char *rslt;
5033unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5034int aclsts, fndsts, rnsts = -1;
5035unsigned int ctx = 0;
5036struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5037struct dsc$descriptor_s * clean_dsc;
5038
5039struct myacedef {
5040 unsigned char myace$b_length;
5041 unsigned char myace$b_type;
5042 unsigned short int myace$w_flags;
5043 unsigned long int myace$l_access;
5044 unsigned long int myace$l_ident;
5045} newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5046 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5047 0},
5048 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5049
5050struct item_list_3
5051 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5052 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5053 {0,0,0,0}},
5054 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5055 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5056 {0,0,0,0}};
5057
5058
5059 /* Expand the input spec using RMS, since we do not want to put
5060 * ACLs on the target of a symbolic link */
5061 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5062 if (vmsname == NULL)
5063 return SS$_INSFMEM;
5064
5065 rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
5066 vmsname,
5067 0,
5068 NULL,
5069 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
5070 NULL,
5071 NULL);
5072 if (rslt == NULL) {
5073 PerlMem_free(vmsname);
5074 return SS$_INSFMEM;
5075 }
5076
5077 /* So we get our own UIC to use as a rights identifier,
5078 * and the insert an ACE at the head of the ACL which allows us
5079 * to delete the file.
5080 */
ebd4d70b 5081 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4fdf8f88
JM		 5082
5083 fildsc.dsc$w_length = strlen(vmsname);
5084 fildsc.dsc$a_pointer = vmsname;
5085 ctx = 0;
5086 newace.myace$l_ident = oldace.myace$l_ident;
5087 rnsts = SS$_ABORT;
5088
5089 /* Grab any existing ACEs with this identifier in case we fail */
5090 clean_dsc = &fildsc;
5091 aclsts = fndsts = sys$get_security(&obj_file_dsc,
5092 &fildsc,
5093 NULL,
5094 OSS$M_WLOCK,
5095 findlst,
5096 &ctx,
5097 &access_mode);
5098
5099 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
5100 /* Add the new ACE . . . */
5101
5102 /* if the sys$get_security succeeded, then ctx is valid, and the
5103 * object/file descriptors will be ignored. But otherwise they
5104 * are needed
5105 */
5106 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5107 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5108 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5109 set_errno(EVMSERR);
5110 set_vaxc_errno(aclsts);
5111 PerlMem_free(vmsname);
5112 return aclsts;
5113 }
5114
5115 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5116 NULL, NULL,
5117 &flags,
5118 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5119
5120 if ($VMS_STATUS_SUCCESS(rnsts)) {
5121 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5122 }
5123
5124 /* Put things back the way they were. */
5125 ctx = 0;
5126 aclsts = sys$get_security(&obj_file_dsc,
5127 clean_dsc,
5128 NULL,
5129 OSS$M_WLOCK,
5130 findlst,
5131 &ctx,
5132 &access_mode);
5133
5134 if ($VMS_STATUS_SUCCESS(aclsts)) {
5135 int sec_flags;
5136
5137 sec_flags = 0;
5138 if (!$VMS_STATUS_SUCCESS(fndsts))
5139 sec_flags = OSS$M_RELCTX;
5140
5141 /* Get rid of the new ACE */
5142 aclsts = sys$set_security(NULL, NULL, NULL,
5143 sec_flags, dellst, &ctx, &access_mode);
5144
5145 /* If there was an old ACE, put it back */
5146 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5147 addlst[0].bufadr = &oldace;
5148 aclsts = sys$set_security(NULL, NULL, NULL,
5149 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5150 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5151 set_errno(EVMSERR);
5152 set_vaxc_errno(aclsts);
5153 rnsts = aclsts;
5154 }
5155 } else {
5156 int aclsts2;
5157
5158 /* Try to clear the lock on the ACL list */
5159 aclsts2 = sys$set_security(NULL, NULL, NULL,
5160 OSS$M_RELCTX, NULL, &ctx, &access_mode);
5161
5162 /* Rename errors are most important */
5163 if (!$VMS_STATUS_SUCCESS(rnsts))
5164 aclsts = rnsts;
5165 set_errno(EVMSERR);
5166 set_vaxc_errno(aclsts);
5167 rnsts = aclsts;
5168 }
5169 }
5170 else {
5171 if (aclsts != SS$_ACLEMPTY)
5172 rnsts = aclsts;
5173 }
5174 }
5175 else
5176 rnsts = fndsts;
5177
5178 PerlMem_free(vmsname);
5179 return rnsts;
5180}
5181
5182
5183/*{{{int rename(const char *, const char * */
5184/* Not exactly what X/Open says to do, but doing it absolutely right
5185 * and efficiently would require a lot more work. This should be close
5186 * enough to pass all but the most strict X/Open compliance test.
5187 */
5188int
5189Perl_rename(pTHX_ const char *src, const char * dst)
5190{
5191int retval;
5192int pre_delete = 0;
5193int src_sts;
5194int dst_sts;
5195Stat_t src_st;
5196Stat_t dst_st;
5197
5198 /* Validate the source file */
5199 src_sts = flex_lstat(src, &src_st);
5200 if (src_sts != 0) {
5201
5202 /* No source file or other problem */
5203 return src_sts;
5204 }
5205
5206 dst_sts = flex_lstat(dst, &dst_st);
5207 if (dst_sts == 0) {
5208
5209 if (dst_st.st_dev != src_st.st_dev) {
5210 /* Must be on the same device */
5211 errno = EXDEV;
5212 return -1;
5213 }
5214
5215 /* VMS_INO_T_COMPARE is true if the inodes are different
5216 * to match the output of memcmp
5217 */
5218
5219 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5220 /* That was easy, the files are the same! */
5221 return 0;
5222 }
5223
5224 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5225 /* If source is a directory, so must be dest */
5226 errno = EISDIR;
5227 return -1;
5228 }
5229
5230 }
5231
5232
5233 if ((dst_sts == 0) &&
5234 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5235
5236 /* We have issues here if vms_unlink_all_versions is set
5237 * If the destination exists, and is not a directory, then
5238 * we must delete in advance.
5239 *
5240 * If the src is a directory, then we must always pre-delete
5241 * the destination.
5242 *
5243 * If we successfully delete the dst in advance, and the rename fails
5244 * X/Open requires that errno be EIO.
5245 *
5246 */
5247
5248 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5249 int d_sts;
5250 d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5251 if (d_sts != 0)
5252 return d_sts;
5253
5254 /* We killed the destination, so only errno now is EIO */
5255 pre_delete = 1;
5256 }
5257 }
5258
5259 /* Originally the idea was to call the CRTL rename() and only
5260 * try the lib$rename_file if it failed.
5261 * It turns out that there are too many variants in what the
5262 * the CRTL rename might do, so only use lib$rename_file
5263 */
5264 retval = -1;
5265
5266 {
5267 /* Is the source and dest both in VMS format */
5268 /* if the source is a directory, then need to fileify */
5269 /* and dest must be a directory or non-existant. */
5270
5271 char * vms_src;
5272 char * vms_dst;
5273 int sts;
5274 char * ret_str;
5275 unsigned long flags;
5276 struct dsc$descriptor_s old_file_dsc;
5277 struct dsc$descriptor_s new_file_dsc;
5278
5279 /* We need to modify the src and dst depending
5280 * on if one or more of them are directories.
5281 */
5282
5283 vms_src = PerlMem_malloc(VMS_MAXRSS);
5284 if (vms_src == NULL)
ebd4d70b 5285 _ckvmssts_noperl(SS$_INSFMEM);
4fdf8f88
JM		 5286
5287 /* Source is always a VMS format file */
5288 ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5289 if (ret_str == NULL) {
5290 PerlMem_free(vms_src);
5291 errno = EIO;
5292 return -1;
5293 }
5294
5295 vms_dst = PerlMem_malloc(VMS_MAXRSS);
5296 if (vms_dst == NULL)
ebd4d70b 5297 _ckvmssts_noperl(SS$_INSFMEM);
4fdf8f88
JM		 5298
5299 if (S_ISDIR(src_st.st_mode)) {
5300 char * ret_str;
5301 char * vms_dir_file;
5302
5303 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5304 if (vms_dir_file == NULL)
ebd4d70b 5305 _ckvmssts_noperl(SS$_INSFMEM);
4fdf8f88
JM		 5306
5307 /* The source must be a file specification */
5308 ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5309 if (ret_str == NULL) {
5310 PerlMem_free(vms_src);
5311 PerlMem_free(vms_dst);
5312 PerlMem_free(vms_dir_file);
5313 errno = EIO;
5314 return -1;
5315 }
5316 PerlMem_free(vms_src);
5317 vms_src = vms_dir_file;
5318
5319 /* If the dest is a directory, we must remove it
5320 if (dst_sts == 0) {
5321 int d_sts;
5322 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5323 if (d_sts != 0) {
5324 PerlMem_free(vms_src);
5325 PerlMem_free(vms_dst);
5326 errno = EIO;
5327 return sts;
5328 }
5329
5330 pre_delete = 1;
5331 }
5332
5333 /* The dest must be a VMS file specification */
df278665 5334 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
4fdf8f88
JM		 5335 if (ret_str == NULL) {
5336 PerlMem_free(vms_src);
5337 PerlMem_free(vms_dst);
5338 errno = EIO;
5339 return -1;
5340 }
5341
5342 /* The source must be a file specification */
5343 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5344 if (vms_dir_file == NULL)
ebd4d70b 5345 _ckvmssts_noperl(SS$_INSFMEM);
4fdf8f88
JM		 5346
5347 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5348 if (ret_str == NULL) {
5349 PerlMem_free(vms_src);
5350 PerlMem_free(vms_dst);
5351 PerlMem_free(vms_dir_file);
5352 errno = EIO;
5353 return -1;
5354 }
5355 PerlMem_free(vms_dst);
5356 vms_dst = vms_dir_file;
5357
5358 } else {
5359 /* File to file or file to new dir */
5360
5361 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5362 /* VMS pathify a dir target */
5363 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5364 if (ret_str == NULL) {
5365 PerlMem_free(vms_src);
5366 PerlMem_free(vms_dst);
5367 errno = EIO;
5368 return -1;
5369 }
5370 } else {
5371
5372 /* fileify a target VMS file specification */
df278665 5373 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
4fdf8f88
JM		 5374 if (ret_str == NULL) {
5375 PerlMem_free(vms_src);
5376 PerlMem_free(vms_dst);
5377 errno = EIO;
5378 return -1;
5379 }
5380 }
5381 }
5382
5383 old_file_dsc.dsc$a_pointer = vms_src;
5384 old_file_dsc.dsc$w_length = strlen(vms_src);
5385 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5386 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5387
5388 new_file_dsc.dsc$a_pointer = vms_dst;
5389 new_file_dsc.dsc$w_length = strlen(vms_dst);
5390 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5391 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5392
5393 flags = 0;
5394#if !defined(__VAX) && defined(NAML$C_MAXRSS)
449de3c2 5395 flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
4fdf8f88
JM		 5396#endif
5397
5398 sts = lib$rename_file(&old_file_dsc,
5399 &new_file_dsc,
5400 NULL, NULL,
5401 &flags,
5402 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5403 if (!$VMS_STATUS_SUCCESS(sts)) {
5404
5405 /* We could have failed because VMS style permissions do not
5406 * permit renames that UNIX will allow. Just like the hack
5407 * in for kill_file.
5408 */
5409 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5410 }
5411
5412 PerlMem_free(vms_src);
5413 PerlMem_free(vms_dst);
5414 if (!$VMS_STATUS_SUCCESS(sts)) {
5415 errno = EIO;
5416 return -1;
5417 }
5418 retval = 0;
5419 }
5420
5421 if (vms_unlink_all_versions) {
5422 /* Now get rid of any previous versions of the source file that
5423 * might still exist
5424 */
5425 int save_errno;
5426 save_errno = errno;
5427 src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5428 errno = save_errno;
5429 }
5430
5431 /* We deleted the destination, so must force the error to be EIO */
5432 if ((retval != 0) && (pre_delete != 0))
5433 errno = EIO;
5434
5435 return retval;
5436}
5437/*}}}*/
5438
5439
bbce6d69 5440/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5441/* Shortcut for common case of simple calls to $PARSE and $SEARCH
5442 * to expand file specification. Allows for a single default file
5443 * specification and a simple mask of options. If outbuf is non-NULL,
5444 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5445 * the resultant file specification is placed. If outbuf is NULL, the
5446 * resultant file specification is placed into a static buffer.
5447 * The third argument, if non-NULL, is taken to be a default file
5448 * specification string. The fourth argument is unused at present.
5449 * rmesexpand() returns the address of the resultant string if
5450 * successful, and NULL on error.
e886094b
JM		 5451 *
5452 * New functionality for previously unused opts value:
5453 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
a1887106
JM		 5454 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5455 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
e0e5e8d6 5456 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
bbce6d69 5457 */
360732b5 5458static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
96e4d5b1 5459
bbce6d69 5460static char *
360732b5
JM		 5461mp_do_rmsexpand
5462 (pTHX_ const char *filespec,
5463 char *outbuf,
5464 int ts,
5465 const char *defspec,
5466 unsigned opts,
5467 int * fs_utf8,
5468 int * dfs_utf8)
bbce6d69 5469{
a1887106 5470 static char __rmsexpand_retbuf[VMS_MAXRSS];
18a3d61e
JM		 5471 char * vmsfspec, *tmpfspec;
5472 char * esa, *cp, *out = NULL;
c5375c28 5473 char * tbuf;
7566800d 5474 char * esal = NULL;
18a3d61e
JM		 5475 char * outbufl;
5476 struct FAB myfab = cc$rms_fab;
a480973c 5477 rms_setup_nam(mynam);
18a3d61e
JM		 5478 STRLEN speclen;
5479 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5480 int sts;
5481
360732b5
JM		 5482 /* temp hack until UTF8 is actually implemented */
5483 if (fs_utf8 != NULL)
5484 *fs_utf8 = 0;
5485
18a3d61e
JM		 5486 if (!filespec || !*filespec) {
5487 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5488 return NULL;
5489 }
5490 if (!outbuf) {
5491 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5492 else outbuf = __rmsexpand_retbuf;
5493 }
5494
5495 vmsfspec = NULL;
5496 tmpfspec = NULL;
5497 outbufl = NULL;
a1887106
JM		 5498
5499 isunix = 0;
5500 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5501 isunix = is_unix_filespec(filespec);
5502 if (isunix) {
5503 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 5504 if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
df278665 5505 if (int_tovmsspec(filespec, vmsfspec, 0, fs_utf8) == NULL) {
c5375c28 5506 PerlMem_free(vmsfspec);
18a3d61e
JM		 5507 if (out)
5508 Safefree(out);
5509 return NULL;
a1887106
JM		 5510 }
5511 filespec = vmsfspec;
18a3d61e 5512
a1887106
JM		 5513 /* Unless we are forcing to VMS format, a UNIX input means
5514 * UNIX output, and that requires long names to be used
5515 */
b1a8dcd7 5516#if !defined(__VAX) && defined(NAML$C_MAXRSS)
a1887106 5517 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
18a3d61e 5518 opts |= PERL_RMSEXPAND_M_LONG;
b1a8dcd7
JM		 5519 else
5520#endif
18a3d61e 5521 isunix = 0;
a1887106 5522 }
18a3d61e 5523 }
18a3d61e 5524
a480973c
JM		 5525 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5526 rms_bind_fab_nam(myfab, mynam);
18a3d61e
JM		 5527
5528 if (defspec && *defspec) {
5529 int t_isunix;
5530 t_isunix = is_unix_filespec(defspec);
5531 if (t_isunix) {
c5375c28 5532 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 5533 if (tmpfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
df278665 5534 if (int_tovmsspec(defspec, tmpfspec, 0, dfs_utf8) == NULL) {
c5375c28 5535 PerlMem_free(tmpfspec);
18a3d61e 5536 if (vmsfspec != NULL)
c5375c28 5537 PerlMem_free(vmsfspec);
18a3d61e
JM		 5538 if (out)
5539 Safefree(out);
5540 return NULL;
5541 }
5542 defspec = tmpfspec;
5543 }
a480973c 5544 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
18a3d61e
JM		 5545 }
5546
c5375c28 5547 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 5548 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 5549#if !defined(__VAX) && defined(NAML$C_MAXRSS)
a1887106 5550 esal = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 5551 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 5552#endif
a1887106 5553 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
18a3d61e 5554
d584a1c6
JM		 5555 /* If a NAML block is used RMS always writes to the long and short
5556 * addresses unless you suppress the short name.
5557 */
a480973c 5558#if !defined(__VAX) && defined(NAML$C_MAXRSS)
d584a1c6 5559 outbufl = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 5560 if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 5561#endif
d584a1c6 5562 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
18a3d61e 5563
f7ddb74a
JM		 5564#ifdef NAM$M_NO_SHORT_UPCASE
5565 if (decc_efs_case_preserve)
a480973c 5566 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 5567#endif
18a3d61e 5568
e0e5e8d6
JM		 5569 /* We may not want to follow symbolic links */
5570#ifdef NAML$M_OPEN_SPECIAL
5571 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5572 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5573#endif
5574
18a3d61e
JM		 5575 /* First attempt to parse as an existing file */
5576 retsts = sys$parse(&myfab,0,0);
5577 if (!(retsts & STS$K_SUCCESS)) {
5578
5579 /* Could not find the file, try as syntax only if error is not fatal */
a480973c 5580 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
18a3d61e
JM		 5581 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5582 retsts = sys$parse(&myfab,0,0);
5583 if (retsts & STS$K_SUCCESS) goto expanded;
5584 }
5585
5586 /* Still could not parse the file specification */
5587 /*----------------------------------------------*/
a480973c 5588 sts = rms_free_search_context(&myfab); /* Free search context */
18a3d61e
JM		 5589 if (out) Safefree(out);
5590 if (tmpfspec != NULL)
c5375c28 5591 PerlMem_free(tmpfspec);
18a3d61e 5592 if (vmsfspec != NULL)
c5375c28
JM		 5593 PerlMem_free(vmsfspec);
5594 if (outbufl != NULL)
5595 PerlMem_free(outbufl);
5596 PerlMem_free(esa);
7566800d
CB		 5597 if (esal != NULL)
5598 PerlMem_free(esal);
18a3d61e
JM		 5599 set_vaxc_errno(retsts);
5600 if (retsts == RMS$_PRV) set_errno(EACCES);
5601 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5602 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5603 else set_errno(EVMSERR);
5604 return NULL;
5605 }
5606 retsts = sys$search(&myfab,0,0);
5607 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
a480973c 5608 sts = rms_free_search_context(&myfab); /* Free search context */
18a3d61e
JM		 5609 if (out) Safefree(out);
5610 if (tmpfspec != NULL)
c5375c28 5611 PerlMem_free(tmpfspec);
18a3d61e 5612 if (vmsfspec != NULL)
c5375c28
JM		 5613 PerlMem_free(vmsfspec);
5614 if (outbufl != NULL)
5615 PerlMem_free(outbufl);
5616 PerlMem_free(esa);
7566800d
CB		 5617 if (esal != NULL)
5618 PerlMem_free(esal);
18a3d61e
JM		 5619 set_vaxc_errno(retsts);
5620 if (retsts == RMS$_PRV) set_errno(EACCES);
5621 else set_errno(EVMSERR);
5622 return NULL;
5623 }
5624
5625 /* If the input filespec contained any lowercase characters,
5626 * downcase the result for compatibility with Unix-minded code. */
5627 expanded:
5628 if (!decc_efs_case_preserve) {
c5375c28
JM		 5629 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5630 if (islower(*tbuf)) { haslower = 1; break; }
18a3d61e
JM		 5631 }
5632
5633 /* Is a long or a short name expected */
5634 /*------------------------------------*/
5635 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 5636 if (rms_nam_rsll(mynam)) {
d584a1c6 5637 tbuf = outbufl;
a480973c 5638 speclen = rms_nam_rsll(mynam);
18a3d61e
JM		 5639 }
5640 else {
c5375c28 5641 tbuf = esal; /* Not esa */
a480973c 5642 speclen = rms_nam_esll(mynam);
18a3d61e
JM		 5643 }
5644 }
5645 else {
a480973c 5646 if (rms_nam_rsl(mynam)) {
c5375c28 5647 tbuf = outbuf;
a480973c 5648 speclen = rms_nam_rsl(mynam);
18a3d61e
JM		 5649 }
5650 else {
c5375c28 5651 tbuf = esa; /* Not esal */
a480973c 5652 speclen = rms_nam_esl(mynam);
18a3d61e
JM		 5653 }
5654 }
4d743a9b
JM		 5655 tbuf[speclen] = '\0';
5656
18a3d61e
JM		 5657 /* Trim off null fields added by $PARSE
5658 * If type > 1 char, must have been specified in original or default spec
5659 * (not true for version; $SEARCH may have added version of existing file).
5660 */
a480973c 5661 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
18a3d61e 5662 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 5663 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5664 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
18a3d61e
JM		 5665 }
5666 else {
a480973c
JM		 5667 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5668 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
18a3d61e
JM		 5669 }
5670 if (trimver || trimtype) {
5671 if (defspec && *defspec) {
5672 char *defesal = NULL;
d584a1c6
JM		 5673 char *defesa = NULL;
5674 defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5675 if (defesa != NULL) {
5676#if !defined(__VAX) && defined(NAML$C_MAXRSS)
5677 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 5678 if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 5679#endif
18a3d61e 5680 struct FAB deffab = cc$rms_fab;
a480973c 5681 rms_setup_nam(defnam);
18a3d61e 5682
a480973c
JM		 5683 rms_bind_fab_nam(deffab, defnam);
5684
5685 /* Cast ok */
5686 rms_set_fna
5687 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5688
d584a1c6
JM		 5689 /* RMS needs the esa/esal as a work area if wildcards are involved */
5690 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
a480973c 5691
4d743a9b 5692 rms_clear_nam_nop(defnam);
a480973c 5693 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
18a3d61e
JM		 5694#ifdef NAM$M_NO_SHORT_UPCASE
5695 if (decc_efs_case_preserve)
a480973c 5696 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
18a3d61e 5697#endif
e0e5e8d6
JM		 5698#ifdef NAML$M_OPEN_SPECIAL
5699 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5700 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5701#endif
18a3d61e
JM		 5702 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5703 if (trimver) {
a480973c 5704 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
18a3d61e
JM		 5705 }
5706 if (trimtype) {
a480973c 5707 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
18a3d61e
JM		 5708 }
5709 }
d584a1c6
JM		 5710 if (defesal != NULL)
5711 PerlMem_free(defesal);
5712 PerlMem_free(defesa);
18a3d61e
JM		 5713 }
5714 }
5715 if (trimver) {
5716 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 5717 if (*(rms_nam_verl(mynam)) != '\"')
c5375c28 5718 speclen = rms_nam_verl(mynam) - tbuf;
18a3d61e
JM		 5719 }
5720 else {
a480973c 5721 if (*(rms_nam_ver(mynam)) != '\"')
c5375c28 5722 speclen = rms_nam_ver(mynam) - tbuf;
18a3d61e
JM		 5723 }
5724 }
5725 if (trimtype) {
5726 /* If we didn't already trim version, copy down */
5727 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
c5375c28 5728 if (speclen > rms_nam_verl(mynam) - tbuf)
18a3d61e 5729 memmove
a480973c
JM		 5730 (rms_nam_typel(mynam),
5731 rms_nam_verl(mynam),
c5375c28 5732 speclen - (rms_nam_verl(mynam) - tbuf));
a480973c 5733 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
18a3d61e
JM		 5734 }
5735 else {
c5375c28 5736 if (speclen > rms_nam_ver(mynam) - tbuf)
18a3d61e 5737 memmove
a480973c
JM		 5738 (rms_nam_type(mynam),
5739 rms_nam_ver(mynam),
c5375c28 5740 speclen - (rms_nam_ver(mynam) - tbuf));
a480973c 5741 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
18a3d61e
JM		 5742 }
5743 }
5744 }
5745
5746 /* Done with these copies of the input files */
5747 /*-------------------------------------------*/
5748 if (vmsfspec != NULL)
c5375c28 5749 PerlMem_free(vmsfspec);
18a3d61e 5750 if (tmpfspec != NULL)
c5375c28 5751 PerlMem_free(tmpfspec);
18a3d61e
JM		 5752
5753 /* If we just had a directory spec on input, $PARSE "helpfully"
5754 * adds an empty name and type for us */
d584a1c6 5755#if !defined(__VAX) && defined(NAML$C_MAXRSS)
18a3d61e 5756 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 5757 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5758 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5759 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
c5375c28 5760 speclen = rms_nam_namel(mynam) - tbuf;
18a3d61e 5761 }
d584a1c6
JM		 5762 else
5763#endif
5764 {
a480973c
JM		 5765 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5766 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5767 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
c5375c28 5768 speclen = rms_nam_name(mynam) - tbuf;
18a3d61e
JM		 5769 }
5770
5771 /* Posix format specifications must have matching quotes */
4d743a9b
JM		 5772 if (speclen < (VMS_MAXRSS - 1)) {
5773 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5774 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5775 tbuf[speclen] = '\"';
5776 speclen++;
5777 }
18a3d61e
JM		 5778 }
5779 }
c5375c28
JM		 5780 tbuf[speclen] = '\0';
5781 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
18a3d61e
JM		 5782
5783 /* Have we been working with an expanded, but not resultant, spec? */
5784 /* Also, convert back to Unix syntax if necessary. */
d584a1c6
JM		 5785 {
5786 int rsl;
18a3d61e 5787
d584a1c6
JM		 5788#if !defined(__VAX) && defined(NAML$C_MAXRSS)
5789 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5790 rsl = rms_nam_rsll(mynam);
5791 } else
5792#endif
5793 {
5794 rsl = rms_nam_rsl(mynam);
5795 }
5796 if (!rsl) {
5797 if (isunix) {
0e5ce2c7 5798 if (int_tounixspec(tbuf, outbuf, fs_utf8) == NULL) {
d584a1c6
JM		 5799 if (out) Safefree(out);
5800 if (esal != NULL)
7566800d 5801 PerlMem_free(esal);
d584a1c6
JM		 5802 PerlMem_free(esa);
5803 if (outbufl != NULL)
c5375c28 5804 PerlMem_free(outbufl);
d584a1c6
JM		 5805 return NULL;
5806 }
18a3d61e 5807 }
d584a1c6 5808 else strcpy(outbuf, tbuf);
18a3d61e 5809 }
d584a1c6
JM		 5810 else if (isunix) {
5811 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 5812 if (tmpfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
0e5ce2c7 5813 if (int_tounixspec(tbuf, tmpfspec, fs_utf8) == NULL) {
c5375c28
JM		 5814 if (out) Safefree(out);
5815 PerlMem_free(esa);
7566800d
CB		 5816 if (esal != NULL)
5817 PerlMem_free(esal);
c5375c28
JM		 5818 PerlMem_free(tmpfspec);
5819 if (outbufl != NULL)
5820 PerlMem_free(outbufl);
18a3d61e 5821 return NULL;
d584a1c6
JM		 5822 }
5823 strcpy(outbuf,tmpfspec);
5824 PerlMem_free(tmpfspec);
18a3d61e 5825 }
18a3d61e 5826 }
a480973c
JM		 5827 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5828 sts = rms_free_search_context(&myfab); /* Free search context */
c5375c28 5829 PerlMem_free(esa);
7566800d
CB		 5830 if (esal != NULL)
5831 PerlMem_free(esal);
c5375c28
JM		 5832 if (outbufl != NULL)
5833 PerlMem_free(outbufl);
bbce6d69 5834 return outbuf;
5835}
5836/*}}}*/
5837/* External entry points */
2fbb330f 5838char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
360732b5 5839{ return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
2fbb330f 5840char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
360732b5
JM		 5841{ return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5842char *Perl_rmsexpand_utf8
5843 (pTHX_ const char *spec, char *buf, const char *def,
5844 unsigned opt, int * fs_utf8, int * dfs_utf8)
5845{ return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5846char *Perl_rmsexpand_utf8_ts
5847 (pTHX_ const char *spec, char *buf, const char *def,
5848 unsigned opt, int * fs_utf8, int * dfs_utf8)
5849{ return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
bbce6d69 5850
5851
a0d0e21e
LW		 5852/*
5853** The following routines are provided to make life easier when
5854** converting among VMS-style and Unix-style directory specifications.
5855** All will take input specifications in either VMS or Unix syntax. On
5856** failure, all return NULL. If successful, the routines listed below
748a9306 5857** return a pointer to a buffer containing the appropriately
a0d0e21e
LW		 5858** reformatted spec (and, therefore, subsequent calls to that routine
5859** will clobber the result), while the routines of the same names with
5860** a _ts suffix appended will return a pointer to a mallocd string
5861** containing the appropriately reformatted spec.
5862** In all cases, only explicit syntax is altered; no check is made that
5863** the resulting string is valid or that the directory in question
5864** actually exists.
5865**
5866** fileify_dirspec() - convert a directory spec into the name of the
5867** directory file (i.e. what you can stat() to see if it's a dir).
5868** The style (VMS or Unix) of the result is the same as the style
5869** of the parameter passed in.
5870** pathify_dirspec() - convert a directory spec into a path (i.e.
5871** what you prepend to a filename to indicate what directory it's in).
5872** The style (VMS or Unix) of the result is the same as the style
5873** of the parameter passed in.
5874** tounixpath() - convert a directory spec into a Unix-style path.
5875** tovmspath() - convert a directory spec into a VMS-style path.
5876** tounixspec() - convert any file spec into a Unix-style file spec.
5877** tovmsspec() - convert any file spec into a VMS-style spec.
360732b5 5878** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
e518068a 5879**
bd3fa61c 5880** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
01b8edb6 5881** Permission is given to distribute this code as part of the Perl
5882** standard distribution under the terms of the GNU General Public
5883** License or the Perl Artistic License. Copies of each may be
5884** found in the Perl standard distribution.
a0d0e21e
LW		 5885 */
5886
360732b5
JM		 5887/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5888static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
a0d0e21e 5889{
a480973c 5890 static char __fileify_retbuf[VMS_MAXRSS];
b7ae7a0d 5891 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
a0d0e21e 5892 char *retspec, *cp1, *cp2, *lastdir;
a480973c 5893 char *trndir, *vmsdir;
2d9f3838 5894 unsigned short int trnlnm_iter_count;
df278665
JM		 5895 int is_vms = 0;
5896 int is_unix = 0;
f7ddb74a 5897 int sts;
360732b5
JM		 5898 if (utf8_fl != NULL)
5899 *utf8_fl = 0;
a0d0e21e 5900
c07a80fd 5901 if (!dir || !*dir) {
5902 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5903 }
a0d0e21e 5904 dirlen = strlen(dir);
a2a90019 5905 while (dirlen && dir[dirlen-1] == '/') --dirlen;
61bb5906 5906 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
f7ddb74a
JM		 5907 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5908 dir = "/sys$disk";
5909 dirlen = 9;
5910 }
5911 else
5912 dirlen = 1;
61bb5906 5913 }
a480973c
JM		 5914 if (dirlen > (VMS_MAXRSS - 1)) {
5915 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5916 return NULL;
c07a80fd 5917 }
c5375c28 5918 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 5919 if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f7ddb74a
JM		 5920 if (!strpbrk(dir+1,"/]>:") &&
5921 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
e518068a 5922 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2d9f3838 5923 trnlnm_iter_count = 0;
b8486b9d 5924 while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
2d9f3838
CB		 5925 trnlnm_iter_count++;
5926 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5927 }
b8ffc8df 5928 dirlen = strlen(trndir);
e518068a 5929 }
01b8edb6 5930 else {
5931 strncpy(trndir,dir,dirlen);
5932 trndir[dirlen] = '\0';
01b8edb6 5933 }
b8ffc8df
RGS		 5934
5935 /* At this point we are done with *dir and use *trndir which is a
5936 * copy that can be modified. *dir must not be modified.
5937 */
5938
c07a80fd 5939 /* If we were handed a rooted logical name or spec, treat it like a
5940 * simple directory, so that
5941 * $ Define myroot dev:[dir.]
5942 * ... do_fileify_dirspec("myroot",buf,1) ...
5943 * does something useful.
5944 */
b8ffc8df
RGS		 5945 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5946 trndir[--dirlen] = '\0';
5947 trndir[dirlen-1] = ']';
c07a80fd 5948 }
b8ffc8df
RGS		 5949 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5950 trndir[--dirlen] = '\0';
5951 trndir[dirlen-1] = '>';
46112e17 5952 }
e518068a 5953
b8ffc8df 5954 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
b7ae7a0d 5955 /* If we've got an explicit filename, we can just shuffle the string. */
5956 if (*(cp1+1)) hasfilename = 1;
5957 /* Similarly, we can just back up a level if we've got multiple levels
5958 of explicit directories in a VMS spec which ends with directories. */
5959 else {
b8ffc8df 5960 for (cp2 = cp1; cp2 > trndir; cp2--) {
f7ddb74a
JM		 5961 if (*cp2 == '.') {
5962 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
657054d4 5963/* fix-me, can not scan EFS file specs backward like this */
f7ddb74a
JM		 5964 *cp2 = *cp1; *cp1 = '\0';
5965 hasfilename = 1;
5966 break;
5967 }
b7ae7a0d 5968 }
5969 if (*cp2 == '[' || *cp2 == '<') break;
5970 }
5971 }
5972 }
5973
c5375c28 5974 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 5975 if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 5976 cp1 = strpbrk(trndir,"]:>");
f7ddb74a 5977 if (hasfilename || !cp1) { /* Unix-style path or filename */
b8ffc8df 5978 if (trndir[0] == '.') {
a480973c 5979 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
c5375c28
JM		 5980 PerlMem_free(trndir);
5981 PerlMem_free(vmsdir);
360732b5 5982 return do_fileify_dirspec("[]",buf,ts,NULL);
a480973c 5983 }
b8ffc8df 5984 else if (trndir[1] == '.' &&
a480973c 5985 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
c5375c28
JM		 5986 PerlMem_free(trndir);
5987 PerlMem_free(vmsdir);
360732b5 5988 return do_fileify_dirspec("[-]",buf,ts,NULL);
a480973c 5989 }
748a9306 5990 }
b8ffc8df 5991 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
a0d0e21e 5992 dirlen -= 1; /* to last element */
b8ffc8df 5993 lastdir = strrchr(trndir,'/');
a0d0e21e 5994 }
b8ffc8df 5995 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
01b8edb6 5996 /* If we have "/." or "/..", VMSify it and let the VMS code
5997 * below expand it, rather than repeating the code to handle
5998 * relative components of a filespec here */
4633a7c4
LW		 5999 do {
6000 if (*(cp1+2) == '.') cp1++;
6001 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
a480973c 6002 char * ret_chr;
df278665 6003 if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
c5375c28
JM		 6004 PerlMem_free(trndir);
6005 PerlMem_free(vmsdir);
a480973c
JM		 6006 return NULL;
6007 }
fc1ce8cc 6008 if (strchr(vmsdir,'/') != NULL) {
df278665 6009 /* If int_tovmsspec() returned it, it must have VMS syntax
fc1ce8cc
CB		 6010 * delimiters in it, so it's a mixed VMS/Unix spec. We take
6011 * the time to check this here only so we avoid a recursion
6012 * loop; otherwise, gigo.
6013 */
c5375c28
JM		 6014 PerlMem_free(trndir);
6015 PerlMem_free(vmsdir);
a480973c
JM		 6016 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
6017 return NULL;
fc1ce8cc 6018 }
360732b5 6019 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
c5375c28
JM		 6020 PerlMem_free(trndir);
6021 PerlMem_free(vmsdir);
a480973c
JM		 6022 return NULL;
6023 }
0e5ce2c7 6024 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
c5375c28
JM		 6025 PerlMem_free(trndir);
6026 PerlMem_free(vmsdir);
a480973c 6027 return ret_chr;
4633a7c4
LW		 6028 }
6029 cp1++;
6030 } while ((cp1 = strstr(cp1,"/.")) != NULL);
b8ffc8df 6031 lastdir = strrchr(trndir,'/');
748a9306 6032 }
b8ffc8df 6033 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
a480973c 6034 char * ret_chr;
61bb5906
CB		 6035 /* Ditto for specs that end in an MFD -- let the VMS code
6036 * figure out whether it's a real device or a rooted logical. */
f7ddb74a
JM		 6037
6038 /* This should not happen any more. Allowing the fake /000000
6039 * in a UNIX pathname causes all sorts of problems when trying
6040 * to run in UNIX emulation. So the VMS to UNIX conversions
6041 * now remove the fake /000000 directories.
6042 */
6043
b8ffc8df 6044 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
df278665 6045 if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
c5375c28
JM		 6046 PerlMem_free(trndir);
6047 PerlMem_free(vmsdir);
a480973c
JM		 6048 return NULL;
6049 }
360732b5 6050 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
c5375c28
JM		 6051 PerlMem_free(trndir);
6052 PerlMem_free(vmsdir);
a480973c
JM		 6053 return NULL;
6054 }
0e5ce2c7 6055 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
c5375c28
JM		 6056 PerlMem_free(trndir);
6057 PerlMem_free(vmsdir);
a480973c 6058 return ret_chr;
61bb5906 6059 }
a0d0e21e 6060 else {
f7ddb74a 6061
b8ffc8df
RGS		 6062 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6063 !(lastdir = cp1 = strrchr(trndir,']')) &&
6064 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
a0d0e21e 6065 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
b7ae7a0d 6066 int ver; char *cp3;
f7ddb74a
JM		 6067
6068 /* For EFS or ODS-5 look for the last dot */
6069 if (decc_efs_charset) {
6070 cp2 = strrchr(cp1,'.');
6071 }
6072 if (vms_process_case_tolerant) {
6073 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6074 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6075 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6076 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6077 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 6078 (ver || *cp3)))))) {
c5375c28
JM		 6079 PerlMem_free(trndir);
6080 PerlMem_free(vmsdir);
f7ddb74a
JM		 6081 set_errno(ENOTDIR);
6082 set_vaxc_errno(RMS$_DIR);
6083 return NULL;
6084 }
6085 }
6086 else {
6087 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6088 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6089 !*(cp2+3) || *(cp2+3) != 'R' ||
6090 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6091 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6092 (ver || *cp3)))))) {
c5375c28
JM		 6093 PerlMem_free(trndir);
6094 PerlMem_free(vmsdir);
f7ddb74a
JM		 6095 set_errno(ENOTDIR);
6096 set_vaxc_errno(RMS$_DIR);
6097 return NULL;
df278665
JM		 6098 }
6099 }
b8ffc8df 6100 dirlen = cp2 - trndir;
a0d0e21e 6101 }
748a9306 6102 }
f7ddb74a
JM		 6103
6104 retlen = dirlen + 6;
748a9306 6105 if (buf) retspec = buf;
a02a5408 6106 else if (ts) Newx(retspec,retlen+1,char);
748a9306 6107 else retspec = __fileify_retbuf;
f7ddb74a
JM		 6108 memcpy(retspec,trndir,dirlen);
6109 retspec[dirlen] = '\0';
6110
a0d0e21e
LW		 6111 /* We've picked up everything up to the directory file name.
6112 Now just add the type and version, and we're set. */
df278665
JM		 6113
6114 /* We should only add type for VMS syntax, but historically Perl
6115 has added it for UNIX style also */
6116
6117 /* Fix me - we should not be using the same routine for VMS and
6118 UNIX format files. Things are too tangled so we need to lookup
6119 what syntax the output is */
6120
6121 is_unix = 0;
6122 is_vms = 0;
6123 lastdir = strrchr(trndir,'/');
6124 if (lastdir) {
6125 is_unix = 1;
6126 } else {
6127 lastdir = strpbrk(trndir,"]:>");
6128 if (lastdir) {
6129 is_vms = 1;
6130 }
6131 }
6132
6133 if ((is_vms == 0) && (is_unix == 0)) {
6134 /* We still do not know? */
6135 is_unix = decc_filename_unix_report;
6136 if (is_unix == 0)
6137 is_vms = 1;
6138 }
6139
6140 if ((is_unix && !decc_efs_charset) || is_vms) {
6141
6142 /* It is a bug to add a .dir to a UNIX format directory spec */
6143 /* However Perl on VMS may have programs that expect this so */
6144 /* If not using EFS character specifications allow it. */
6145
6146 if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6147 /* Traditionally Perl expects filenames in lower case */
6148 strcat(retspec, ".dir");
6149 } else {
6150 /* VMS expects the .DIR to be in upper case */
6151 strcat(retspec, ".DIR");
6152 }
6153
6154 /* It is also a bug to put a VMS format version on a UNIX file */
6155 /* specification. Perl self tests are looking for this */
6156 if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6157 strcat(retspec, ";1");
6158 }
c5375c28
JM		 6159 PerlMem_free(trndir);
6160 PerlMem_free(vmsdir);
a0d0e21e
LW		 6161 return retspec;
6162 }
6163 else { /* VMS-style directory spec */
a480973c 6164
d584a1c6
JM		 6165 char *esa, *esal, term, *cp;
6166 char *my_esa;
6167 int my_esa_len;
01b8edb6 6168 unsigned long int sts, cmplen, haslower = 0;
a480973c
JM		 6169 unsigned int nam_fnb;
6170 char * nam_type;
a0d0e21e 6171 struct FAB dirfab = cc$rms_fab;
a480973c
JM		 6172 rms_setup_nam(savnam);
6173 rms_setup_nam(dirnam);
6174
d584a1c6 6175 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 6176 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 6177 esal = NULL;
6178#if !defined(__VAX) && defined(NAML$C_MAXRSS)
6179 esal = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 6180 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 6181#endif
a480973c
JM		 6182 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6183 rms_bind_fab_nam(dirfab, dirnam);
6184 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
d584a1c6 6185 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
f7ddb74a
JM		 6186#ifdef NAM$M_NO_SHORT_UPCASE
6187 if (decc_efs_case_preserve)
a480973c 6188 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6189#endif
01b8edb6 6190
b8ffc8df 6191 for (cp = trndir; *cp; cp++)
01b8edb6 6192 if (islower(*cp)) { haslower = 1; break; }
a480973c 6193 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
f7ddb74a 6194 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
a480973c
JM		 6195 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6196 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
e518068a 6197 }
6198 if (!sts) {
c5375c28 6199 PerlMem_free(esa);
d584a1c6
JM		 6200 if (esal != NULL)
6201 PerlMem_free(esal);
c5375c28
JM		 6202 PerlMem_free(trndir);
6203 PerlMem_free(vmsdir);
748a9306
LW		 6204 set_errno(EVMSERR);
6205 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 6206 return NULL;
6207 }
e518068a 6208 }
6209 else {
6210 savnam = dirnam;
a480973c
JM		 6211 /* Does the file really exist? */
6212 if (sys$search(&dirfab)& STS$K_SUCCESS) {
e518068a 6213 /* Yes; fake the fnb bits so we'll check type below */
a480973c 6214 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
e518068a 6215 }
752635ea
CB		 6216 else { /* No; just work with potential name */
6217 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6218 else {
2623a4a6
JM		 6219 int fab_sts;
6220 fab_sts = dirfab.fab$l_sts;
6221 sts = rms_free_search_context(&dirfab);
c5375c28 6222 PerlMem_free(esa);
d584a1c6
JM		 6223 if (esal != NULL)
6224 PerlMem_free(esal);
c5375c28
JM		 6225 PerlMem_free(trndir);
6226 PerlMem_free(vmsdir);
2623a4a6 6227 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
e518068a 6228 return NULL;
6229 }
e518068a 6230 }
a0d0e21e 6231 }
d584a1c6
JM		 6232
6233 /* Make sure we are using the right buffer */
6234 if (esal != NULL) {
6235 my_esa = esal;
6236 my_esa_len = rms_nam_esll(dirnam);
6237 } else {
6238 my_esa = esa;
6239 my_esa_len = rms_nam_esl(dirnam);
6240 }
6241 my_esa[my_esa_len] = '\0';
a480973c 6242 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
d584a1c6
JM		 6243 cp1 = strchr(my_esa,']');
6244 if (!cp1) cp1 = strchr(my_esa,'>');
748a9306 6245 if (cp1) { /* Should always be true */
d584a1c6
JM		 6246 my_esa_len -= cp1 - my_esa - 1;
6247 memmove(my_esa, cp1 + 1, my_esa_len);
748a9306
LW		 6248 }
6249 }
a480973c 6250 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
a0d0e21e 6251 /* Yep; check version while we're at it, if it's there. */
a480973c
JM		 6252 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6253 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
a0d0e21e 6254 /* Something other than .DIR[;1]. Bzzt. */
a480973c 6255 sts = rms_free_search_context(&dirfab);
c5375c28 6256 PerlMem_free(esa);
d584a1c6
JM		 6257 if (esal != NULL)
6258 PerlMem_free(esal);
c5375c28
JM		 6259 PerlMem_free(trndir);
6260 PerlMem_free(vmsdir);
748a9306
LW		 6261 set_errno(ENOTDIR);
6262 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 6263 return NULL;
6264 }
748a9306 6265 }
ae6d78fe 6266
a480973c 6267 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
748a9306
LW		 6268 /* They provided at least the name; we added the type, if necessary, */
6269 if (buf) retspec = buf; /* in sys$parse() */
d584a1c6 6270 else if (ts) Newx(retspec, my_esa_len + 1, char);
748a9306 6271 else retspec = __fileify_retbuf;
d584a1c6 6272 strcpy(retspec,my_esa);
a480973c 6273 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 6274 PerlMem_free(trndir);
6275 PerlMem_free(esa);
d584a1c6
JM		 6276 if (esal != NULL)
6277 PerlMem_free(esal);
c5375c28 6278 PerlMem_free(vmsdir);
748a9306
LW		 6279 return retspec;
6280 }
c07a80fd 6281 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6282 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6283 *cp1 = '\0';
d584a1c6 6284 my_esa_len -= 9;
c07a80fd 6285 }
d584a1c6 6286 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
752635ea 6287 if (cp1 == NULL) { /* should never happen */
a480973c 6288 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 6289 PerlMem_free(trndir);
6290 PerlMem_free(esa);
d584a1c6
JM		 6291 if (esal != NULL)
6292 PerlMem_free(esal);
c5375c28 6293 PerlMem_free(vmsdir);
752635ea
CB		 6294 return NULL;
6295 }
748a9306
LW		 6296 term = *cp1;
6297 *cp1 = '\0';
d584a1c6
JM		 6298 retlen = strlen(my_esa);
6299 cp1 = strrchr(my_esa,'.');
f7ddb74a 6300 /* ODS-5 directory specifications can have extra "." in them. */
657054d4 6301 /* Fix-me, can not scan EFS file specifications backwards */
f7ddb74a 6302 while (cp1 != NULL) {
d584a1c6 6303 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
f7ddb74a
JM		 6304 break;
6305 else {
6306 cp1--;
d584a1c6 6307 while ((cp1 > my_esa) && (*cp1 != '.'))
f7ddb74a
JM		 6308 cp1--;
6309 }
d584a1c6 6310 if (cp1 == my_esa)
f7ddb74a
JM		 6311 cp1 = NULL;
6312 }
6313
6314 if ((cp1) != NULL) {
748a9306
LW		 6315 /* There's more than one directory in the path. Just roll back. */
6316 *cp1 = term;
6317 if (buf) retspec = buf;
a02a5408 6318 else if (ts) Newx(retspec,retlen+7,char);
748a9306 6319 else retspec = __fileify_retbuf;
d584a1c6 6320 strcpy(retspec,my_esa);
a0d0e21e
LW		 6321 }
6322 else {
a480973c 6323 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
748a9306 6324 /* Go back and expand rooted logical name */
a480973c 6325 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
f7ddb74a
JM		 6326#ifdef NAM$M_NO_SHORT_UPCASE
6327 if (decc_efs_case_preserve)
a480973c 6328 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6329#endif
a480973c
JM		 6330 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6331 sts = rms_free_search_context(&dirfab);
c5375c28 6332 PerlMem_free(esa);
d584a1c6
JM		 6333 if (esal != NULL)
6334 PerlMem_free(esal);
c5375c28
JM		 6335 PerlMem_free(trndir);
6336 PerlMem_free(vmsdir);
748a9306
LW		 6337 set_errno(EVMSERR);
6338 set_vaxc_errno(dirfab.fab$l_sts);
6339 return NULL;
6340 }
d584a1c6
JM		 6341
6342 /* This changes the length of the string of course */
6343 if (esal != NULL) {
6344 my_esa_len = rms_nam_esll(dirnam);
6345 } else {
6346 my_esa_len = rms_nam_esl(dirnam);
6347 }
6348
6349 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
a0d0e21e 6350 if (buf) retspec = buf;
a02a5408 6351 else if (ts) Newx(retspec,retlen+16,char);
a0d0e21e 6352 else retspec = __fileify_retbuf;
d584a1c6
JM		 6353 cp1 = strstr(my_esa,"][");
6354 if (!cp1) cp1 = strstr(my_esa,"]<");
6355 dirlen = cp1 - my_esa;
6356 memcpy(retspec,my_esa,dirlen);
748a9306
LW		 6357 if (!strncmp(cp1+2,"000000]",7)) {
6358 retspec[dirlen-1] = '\0';
657054d4 6359 /* fix-me Not full ODS-5, just extra dots in directories for now */
f7ddb74a
JM		 6360 cp1 = retspec + dirlen - 1;
6361 while (cp1 > retspec)
6362 {
6363 if (*cp1 == '[')
6364 break;
6365 if (*cp1 == '.') {
6366 if (*(cp1-1) != '^')
6367 break;
6368 }
6369 cp1--;
6370 }
4633a7c4
LW		 6371 if (*cp1 == '.') *cp1 = ']';
6372 else {
6373 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
18a3d61e 6374 memmove(cp1+1,"000000]",7);
4633a7c4 6375 }
748a9306
LW		 6376 }
6377 else {
18a3d61e 6378 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
748a9306
LW		 6379 retspec[retlen] = '\0';
6380 /* Convert last '.' to ']' */
f7ddb74a
JM		 6381 cp1 = retspec+retlen-1;
6382 while (*cp != '[') {
6383 cp1--;
6384 if (*cp1 == '.') {
6385 /* Do not trip on extra dots in ODS-5 directories */
6386 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6387 break;
6388 }
6389 }
4633a7c4
LW		 6390 if (*cp1 == '.') *cp1 = ']';
6391 else {
6392 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
18a3d61e 6393 memmove(cp1+1,"000000]",7);
4633a7c4 6394 }
748a9306 6395 }
a0d0e21e 6396 }
748a9306 6397 else { /* This is a top-level dir. Add the MFD to the path. */
a0d0e21e 6398 if (buf) retspec = buf;
a02a5408 6399 else if (ts) Newx(retspec,retlen+16,char);
a0d0e21e 6400 else retspec = __fileify_retbuf;
d584a1c6 6401 cp1 = my_esa;
a0d0e21e 6402 cp2 = retspec;
bbdb6c9a 6403 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
a0d0e21e
LW		 6404 strcpy(cp2,":[000000]");
6405 cp1 += 2;
6406 strcpy(cp2+9,cp1);
6407 }
748a9306 6408 }
a480973c 6409 sts = rms_free_search_context(&dirfab);
748a9306 6410 /* We've set up the string up through the filename. Add the
a0d0e21e
LW		 6411 type and version, and we're done. */
6412 strcat(retspec,".DIR;1");
01b8edb6 6413
6414 /* $PARSE may have upcased filespec, so convert output to lower
6415 * case if input contained any lowercase characters. */
f7ddb74a 6416 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
c5375c28
JM		 6417 PerlMem_free(trndir);
6418 PerlMem_free(esa);
d584a1c6
JM		 6419 if (esal != NULL)
6420 PerlMem_free(esal);
c5375c28 6421 PerlMem_free(vmsdir);
a0d0e21e
LW		 6422 return retspec;
6423 }
6424} /* end of do_fileify_dirspec() */
6425/*}}}*/
6426/* External entry points */
b8ffc8df 6427char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
360732b5 6428{ return do_fileify_dirspec(dir,buf,0,NULL); }
b8ffc8df 6429char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
360732b5
JM		 6430{ return do_fileify_dirspec(dir,buf,1,NULL); }
6431char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6432{ return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6433char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6434{ return do_fileify_dirspec(dir,buf,1,utf8_fl); }
a0d0e21e
LW		 6435
6436/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
360732b5 6437static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
a0d0e21e 6438{
a480973c 6439 static char __pathify_retbuf[VMS_MAXRSS];
a0d0e21e 6440 unsigned long int retlen;
a480973c 6441 char *retpath, *cp1, *cp2, *trndir;
2d9f3838 6442 unsigned short int trnlnm_iter_count;
baf3cf9c 6443 STRLEN trnlen;
f7ddb74a 6444 int sts;
360732b5
JM		 6445 if (utf8_fl != NULL)
6446 *utf8_fl = 0;
a0d0e21e 6447
c07a80fd 6448 if (!dir || !*dir) {
6449 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6450 }
6451
c5375c28 6452 trndir = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 6453 if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c07a80fd 6454 if (*dir) strcpy(trndir,dir);
a480973c 6455 else getcwd(trndir,VMS_MAXRSS - 1);
c07a80fd 6456
2d9f3838 6457 trnlnm_iter_count = 0;
93948341 6458 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
b8486b9d 6459 && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
2d9f3838
CB		 6460 trnlnm_iter_count++;
6461 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
baf3cf9c 6462 trnlen = strlen(trndir);
a0d0e21e 6463
c07a80fd 6464 /* Trap simple rooted lnms, and return lnm:[000000] */
6465 if (!strcmp(trndir+trnlen-2,".]")) {
6466 if (buf) retpath = buf;
a02a5408 6467 else if (ts) Newx(retpath,strlen(dir)+10,char);
c07a80fd 6468 else retpath = __pathify_retbuf;
6469 strcpy(retpath,dir);
6470 strcat(retpath,":[000000]");
c5375c28 6471 PerlMem_free(trndir);
c07a80fd 6472 return retpath;
6473 }
6474 }
748a9306 6475
b8ffc8df
RGS		 6476 /* At this point we do not work with *dir, but the copy in
6477 * *trndir that is modifiable.
6478 */
6479
6480 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6481 if (*trndir == '.' && (*(trndir+1) == '\0' ||
6482 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6483 retlen = 2 + (*(trndir+1) != '\0');
748a9306 6484 else {
b8ffc8df
RGS		 6485 if ( !(cp1 = strrchr(trndir,'/')) &&
6486 !(cp1 = strrchr(trndir,']')) &&
6487 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
f86702cc 6488 if ((cp2 = strchr(cp1,'.')) != NULL &&
6489 (*(cp2-1) != '/' || /* Trailing '.', '..', */
6490 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
6491 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6492 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
b7ae7a0d 6493 int ver; char *cp3;
f7ddb74a
JM		 6494
6495 /* For EFS or ODS-5 look for the last dot */
6496 if (decc_efs_charset) {
6497 cp2 = strrchr(cp1,'.');
6498 }
6499 if (vms_process_case_tolerant) {
6500 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6501 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6502 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6503 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6504 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 6505 (ver || *cp3)))))) {
c5375c28 6506 PerlMem_free(trndir);
f7ddb74a
JM		 6507 set_errno(ENOTDIR);
6508 set_vaxc_errno(RMS$_DIR);
6509 return NULL;
6510 }
6511 }
6512 else {
6513 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6514 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6515 !*(cp2+3) || *(cp2+3) != 'R' ||
6516 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6517 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6518 (ver || *cp3)))))) {
c5375c28 6519 PerlMem_free(trndir);
f7ddb74a
JM		 6520 set_errno(ENOTDIR);
6521 set_vaxc_errno(RMS$_DIR);
6522 return NULL;
6523 }
6524 }
b8ffc8df 6525 retlen = cp2 - trndir + 1;
a0d0e21e 6526 }
748a9306 6527 else { /* No file type present. Treat the filename as a directory. */
b8ffc8df 6528 retlen = strlen(trndir) + 1;
a0d0e21e
LW		 6529 }
6530 }
a0d0e21e 6531 if (buf) retpath = buf;
a02a5408 6532 else if (ts) Newx(retpath,retlen+1,char);
a0d0e21e 6533 else retpath = __pathify_retbuf;
b8ffc8df 6534 strncpy(retpath, trndir, retlen-1);
a0d0e21e
LW		 6535 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6536 retpath[retlen-1] = '/'; /* with '/', add it. */
6537 retpath[retlen] = '\0';
6538 }
6539 else retpath[retlen-1] = '\0';
6540 }
6541 else { /* VMS-style directory spec */
d584a1c6
JM		 6542 char *esa, *esal, *cp;
6543 char *my_esa;
6544 int my_esa_len;
01b8edb6 6545 unsigned long int sts, cmplen, haslower;
a0d0e21e 6546 struct FAB dirfab = cc$rms_fab;
a480973c
JM		 6547 int dirlen;
6548 rms_setup_nam(savnam);
6549 rms_setup_nam(dirnam);
a0d0e21e 6550
b7ae7a0d 6551 /* If we've got an explicit filename, we can just shuffle the string. */
b8ffc8df
RGS		 6552 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6553 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
b7ae7a0d 6554 if ((cp2 = strchr(cp1,'.')) != NULL) {
6555 int ver; char *cp3;
f7ddb74a
JM		 6556 if (vms_process_case_tolerant) {
6557 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6558 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6559 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6560 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6561 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 6562 (ver || *cp3)))))) {
c5375c28 6563 PerlMem_free(trndir);
f7ddb74a
JM		 6564 set_errno(ENOTDIR);
6565 set_vaxc_errno(RMS$_DIR);
6566 return NULL;
6567 }
6568 }
6569 else {
6570 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6571 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6572 !*(cp2+3) || *(cp2+3) != 'R' ||
6573 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6574 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6575 (ver || *cp3)))))) {
c5375c28 6576 PerlMem_free(trndir);
f7ddb74a
JM		 6577 set_errno(ENOTDIR);
6578 set_vaxc_errno(RMS$_DIR);
6579 return NULL;
6580 }
6581 }
b7ae7a0d 6582 }
6583 else { /* No file type, so just draw name into directory part */
6584 for (cp2 = cp1; *cp2; cp2++) ;
6585 }
6586 *cp2 = *cp1;
6587 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
6588 *cp1 = '.';
6589 /* We've now got a VMS 'path'; fall through */
6590 }
a480973c
JM		 6591
6592 dirlen = strlen(trndir);
6593 if (trndir[dirlen-1] == ']' ||
6594 trndir[dirlen-1] == '>' ||
6595 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
748a9306 6596 if (buf) retpath = buf;
f7ddb74a 6597 else if (ts) Newx(retpath,strlen(trndir)+1,char);
748a9306 6598 else retpath = __pathify_retbuf;
b8ffc8df 6599 strcpy(retpath,trndir);
c5375c28 6600 PerlMem_free(trndir);
748a9306 6601 return retpath;
a480973c
JM		 6602 }
6603 rms_set_fna(dirfab, dirnam, trndir, dirlen);
c5375c28 6604 esa = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 6605 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 6606 esal = NULL;
6607#if !defined(__VAX) && defined(NAML$C_MAXRSS)
6608 esal = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 6609 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 6610#endif
a480973c
JM		 6611 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6612 rms_bind_fab_nam(dirfab, dirnam);
d584a1c6 6613 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
f7ddb74a
JM		 6614#ifdef NAM$M_NO_SHORT_UPCASE
6615 if (decc_efs_case_preserve)
a480973c 6616 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6617#endif
01b8edb6 6618
b8ffc8df 6619 for (cp = trndir; *cp; cp++)
01b8edb6 6620 if (islower(*cp)) { haslower = 1; break; }
6621
a480973c 6622 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
f7ddb74a 6623 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
a480973c
JM		 6624 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6625 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
e518068a 6626 }
6627 if (!sts) {
c5375c28
JM		 6628 PerlMem_free(trndir);
6629 PerlMem_free(esa);
d584a1c6
JM		 6630 if (esal != NULL)
6631 PerlMem_free(esal);
748a9306
LW		 6632 set_errno(EVMSERR);
6633 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 6634 return NULL;
6635 }
a0d0e21e 6636 }
e518068a 6637 else {
6638 savnam = dirnam;
a480973c
JM		 6639 /* Does the file really exist? */
6640 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
e518068a 6641 if (dirfab.fab$l_sts != RMS$_FNF) {
f7ddb74a 6642 int sts1;
a480973c 6643 sts1 = rms_free_search_context(&dirfab);
c5375c28
JM		 6644 PerlMem_free(trndir);
6645 PerlMem_free(esa);
d584a1c6
JM		 6646 if (esal != NULL)
6647 PerlMem_free(esal);
e518068a 6648 set_errno(EVMSERR);
6649 set_vaxc_errno(dirfab.fab$l_sts);
6650 return NULL;
6651 }
6652 dirnam = savnam; /* No; just work with potential name */
6653 }
6654 }
a480973c 6655 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
a0d0e21e 6656 /* Yep; check version while we're at it, if it's there. */
a480973c
JM		 6657 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6658 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
f7ddb74a 6659 int sts2;
a0d0e21e 6660 /* Something other than .DIR[;1]. Bzzt. */
a480973c 6661 sts2 = rms_free_search_context(&dirfab);
c5375c28
JM		 6662 PerlMem_free(trndir);
6663 PerlMem_free(esa);
d584a1c6
JM		 6664 if (esal != NULL)
6665 PerlMem_free(esal);
748a9306
LW		 6666 set_errno(ENOTDIR);
6667 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 6668 return NULL;
6669 }
a0d0e21e 6670 }
d584a1c6
JM		 6671 /* Make sure we are using the right buffer */
6672 if (esal != NULL) {
6673 /* We only need one, clean up the other */
6674 my_esa = esal;
6675 my_esa_len = rms_nam_esll(dirnam);
6676 } else {
6677 my_esa = esa;
6678 my_esa_len = rms_nam_esl(dirnam);
6679 }
6680
6681 /* Null terminate the buffer */
6682 my_esa[my_esa_len] = '\0';
6683
748a9306
LW		 6684 /* OK, the type was fine. Now pull any file name into the
6685 directory path. */
d584a1c6 6686 if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
a0d0e21e 6687 else {
d584a1c6 6688 cp1 = strrchr(my_esa,'>');
a480973c 6689 *(rms_nam_typel(dirnam)) = '>';
a0d0e21e 6690 }
748a9306 6691 *cp1 = '.';
a480973c 6692 *(rms_nam_typel(dirnam) + 1) = '\0';
d584a1c6 6693 retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
a0d0e21e 6694 if (buf) retpath = buf;
a02a5408 6695 else if (ts) Newx(retpath,retlen,char);
a0d0e21e 6696 else retpath = __pathify_retbuf;
d584a1c6 6697 strcpy(retpath,my_esa);
c5375c28 6698 PerlMem_free(esa);
d584a1c6
JM		 6699 if (esal != NULL)
6700 PerlMem_free(esal);
a480973c 6701 sts = rms_free_search_context(&dirfab);
01b8edb6 6702 /* $PARSE may have upcased filespec, so convert output to lower
6703 * case if input contained any lowercase characters. */
f7ddb74a 6704 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
a0d0e21e
LW		 6705 }
6706
c5375c28 6707 PerlMem_free(trndir);
a0d0e21e
LW		 6708 return retpath;
6709} /* end of do_pathify_dirspec() */
6710/*}}}*/
6711/* External entry points */
b8ffc8df 6712char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
360732b5 6713{ return do_pathify_dirspec(dir,buf,0,NULL); }
b8ffc8df 6714char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
360732b5
JM		 6715{ return do_pathify_dirspec(dir,buf,1,NULL); }
6716char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6717{ return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6718char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6719{ return do_pathify_dirspec(dir,buf,1,utf8_fl); }
a0d0e21e 6720
0e5ce2c7
JM		 6721/* Internal tounixspec routine that does not use a thread context */
6722/*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6723static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
a0d0e21e 6724{
0e5ce2c7 6725 char *dirend, *cp1, *cp3, *tmp;
b8ffc8df 6726 const char *cp2;
a480973c 6727 int devlen, dirlen, retlen = VMS_MAXRSS;
0f20d7df 6728 int expand = 1; /* guarantee room for leading and trailing slashes */
2d9f3838 6729 unsigned short int trnlnm_iter_count;
f7ddb74a 6730 int cmp_rslt;
360732b5
JM		 6731 if (utf8_fl != NULL)
6732 *utf8_fl = 0;
a0d0e21e 6733
0e5ce2c7
JM		 6734 if (vms_debug_fileify) {
6735 if (spec == NULL)
6736 fprintf(stderr, "int_tounixspec: spec = NULL\n");
6737 else
6738 fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6739 }
6740
6741
6742 if (spec == NULL) {
6743 set_errno(EINVAL);
6744 set_vaxc_errno(SS$_BADPARAM);
6745 return NULL;
6746 }
6747 if (strlen(spec) > (VMS_MAXRSS-1)) {
6748 set_errno(E2BIG);
6749 set_vaxc_errno(SS$_BUFFEROVF);
6750 return NULL;
e518068a 6751 }
f7ddb74a 6752
2497a41f
JM		 6753 /* New VMS specific format needs translation
6754 * glob passes filenames with trailing '\n' and expects this preserved.
6755 */
6756 if (decc_posix_compliant_pathnames) {
6757 if (strncmp(spec, "\"^UP^", 5) == 0) {
6758 char * uspec;
6759 char *tunix;
6760 int tunix_len;
6761 int nl_flag;
6762
c5375c28 6763 tunix = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 6764 if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2497a41f
JM		 6765 strcpy(tunix, spec);
6766 tunix_len = strlen(tunix);
6767 nl_flag = 0;
6768 if (tunix[tunix_len - 1] == '\n') {
6769 tunix[tunix_len - 1] = '\"';
6770 tunix[tunix_len] = '\0';
6771 tunix_len--;
6772 nl_flag = 1;
6773 }
6774 uspec = decc$translate_vms(tunix);
367e4b85 6775 PerlMem_free(tunix);
2497a41f
JM		 6776 if ((int)uspec > 0) {
6777 strcpy(rslt,uspec);
6778 if (nl_flag) {
6779 strcat(rslt,"\n");
6780 }
6781 else {
6782 /* If we can not translate it, makemaker wants as-is */
6783 strcpy(rslt, spec);
6784 }
6785 return rslt;
6786 }
6787 }
6788 }
6789
f7ddb74a
JM		 6790 cmp_rslt = 0; /* Presume VMS */
6791 cp1 = strchr(spec, '/');
6792 if (cp1 == NULL)
6793 cmp_rslt = 0;
6794
6795 /* Look for EFS ^/ */
6796 if (decc_efs_charset) {
6797 while (cp1 != NULL) {
6798 cp2 = cp1 - 1;
6799 if (*cp2 != '^') {
6800 /* Found illegal VMS, assume UNIX */
6801 cmp_rslt = 1;
6802 break;
6803 }
6804 cp1++;
6805 cp1 = strchr(cp1, '/');
6806 }
6807 }
6808
6809 /* Look for "." and ".." */
6810 if (decc_filename_unix_report) {
6811 if (spec[0] == '.') {
6812 if ((spec[1] == '\0') || (spec[1] == '\n')) {
6813 cmp_rslt = 1;
6814 }
6815 else {
6816 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6817 cmp_rslt = 1;
6818 }
6819 }
6820 }
6821 }
6822 /* This is already UNIX or at least nothing VMS understands */
6823 if (cmp_rslt) {
a0d0e21e 6824 strcpy(rslt,spec);
0e5ce2c7
JM		 6825 if (vms_debug_fileify) {
6826 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6827 }
a0d0e21e
LW		 6828 return rslt;
6829 }
6830
6831 cp1 = rslt;
6832 cp2 = spec;
6833 dirend = strrchr(spec,']');
6834 if (dirend == NULL) dirend = strrchr(spec,'>');
6835 if (dirend == NULL) dirend = strchr(spec,':');
6836 if (dirend == NULL) {
6837 strcpy(rslt,spec);
0e5ce2c7
JM		 6838 if (vms_debug_fileify) {
6839 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6840 }
a0d0e21e
LW		 6841 return rslt;
6842 }
f7ddb74a
JM		 6843
6844 /* Special case 1 - sys$posix_root = / */
6845#if __CRTL_VER >= 70000000
6846 if (!decc_disable_posix_root) {
6847 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6848 *cp1 = '/';
6849 cp1++;
6850 cp2 = cp2 + 15;
6851 }
6852 }
6853#endif
6854
6855 /* Special case 2 - Convert NLA0: to /dev/null */
6856#if __CRTL_VER < 70000000
6857 cmp_rslt = strncmp(spec,"NLA0:", 5);
6858 if (cmp_rslt != 0)
6859 cmp_rslt = strncmp(spec,"nla0:", 5);
6860#else
6861 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6862#endif
6863 if (cmp_rslt == 0) {
6864 strcpy(rslt, "/dev/null");
6865 cp1 = cp1 + 9;
6866 cp2 = cp2 + 5;
6867 if (spec[6] != '\0') {
6868 cp1[9] == '/';
6869 cp1++;
6870 cp2++;
6871 }
6872 }
6873
6874 /* Also handle special case "SYS$SCRATCH:" */
6875#if __CRTL_VER < 70000000
6876 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6877 if (cmp_rslt != 0)
6878 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6879#else
6880 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6881#endif
c5375c28 6882 tmp = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 6883 if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f7ddb74a
JM		 6884 if (cmp_rslt == 0) {
6885 int islnm;
6886
b8486b9d 6887 islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
f7ddb74a
JM		 6888 if (!islnm) {
6889 strcpy(rslt, "/tmp");
6890 cp1 = cp1 + 4;
6891 cp2 = cp2 + 12;
6892 if (spec[12] != '\0') {
6893 cp1[4] == '/';
6894 cp1++;
6895 cp2++;
6896 }
6897 }
6898 }
6899
a5f75d66 6900 if (*cp2 != '[' && *cp2 != '<') {
a0d0e21e
LW		 6901 *(cp1++) = '/';
6902 }
6903 else { /* the VMS spec begins with directories */
6904 cp2++;
a5f75d66 6905 if (*cp2 == ']' || *cp2 == '>') {
f86702cc 6906 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
367e4b85 6907 PerlMem_free(tmp);
a5f75d66
AD		 6908 return rslt;
6909 }
f7ddb74a 6910 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2f4077ca 6911 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
367e4b85 6912 PerlMem_free(tmp);
0e5ce2c7
JM		 6913 if (vms_debug_fileify) {
6914 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
6915 }
a0d0e21e
LW		 6916 return NULL;
6917 }
2d9f3838 6918 trnlnm_iter_count = 0;
a0d0e21e
LW		 6919 do {
6920 cp3 = tmp;
6921 while (*cp3 != ':' && *cp3) cp3++;
6922 *(cp3++) = '\0';
6923 if (strchr(cp3,']') != NULL) break;
2d9f3838
CB		 6924 trnlnm_iter_count++;
6925 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
f675dbe5 6926 } while (vmstrnenv(tmp,tmp,0,fildev,0));
0e5ce2c7 6927 cp1 = rslt;
f86702cc 6928 cp3 = tmp;
6929 *(cp1++) = '/';
6930 while (*cp3) {
6931 *(cp1++) = *(cp3++);
0e5ce2c7 6932 if (cp1 - rslt > (VMS_MAXRSS - 1)) {
367e4b85 6933 PerlMem_free(tmp);
0e5ce2c7
JM		 6934 set_errno(ENAMETOOLONG);
6935 set_vaxc_errno(SS$_BUFFEROVF);
6936 if (vms_debug_fileify) {
6937 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
6938 }
2f4077ca
JM		 6939 return NULL; /* No room */
6940 }
a0d0e21e 6941 }
f86702cc 6942 *(cp1++) = '/';
6943 }
f7ddb74a
JM		 6944 if ((*cp2 == '^')) {
6945 /* EFS file escape, pass the next character as is */
38a44b82 6946 /* Fix me: HEX encoding for Unicode not implemented */
f7ddb74a
JM		 6947 cp2++;
6948 }
f86702cc 6949 else if ( *cp2 == '.') {
6950 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6951 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6952 cp2 += 3;
6953 }
6954 else cp2++;
a0d0e21e 6955 }
a0d0e21e 6956 }
367e4b85 6957 PerlMem_free(tmp);
a0d0e21e 6958 for (; cp2 <= dirend; cp2++) {
f7ddb74a
JM		 6959 if ((*cp2 == '^')) {
6960 /* EFS file escape, pass the next character as is */
38a44b82 6961 /* Fix me: HEX encoding for Unicode not implemented */
42cd432e
CB		 6962 *(cp1++) = *(++cp2);
6963 /* An escaped dot stays as is -- don't convert to slash */
6964 if (*cp2 == '.') cp2++;
f7ddb74a 6965 }
a0d0e21e
LW		 6966 if (*cp2 == ':') {
6967 *(cp1++) = '/';
6968 if (*(cp2+1) == '[') cp2++;
6969 }
f86702cc 6970 else if (*cp2 == ']' || *cp2 == '>') {
6971 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6972 }
f7ddb74a 6973 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
a0d0e21e 6974 *(cp1++) = '/';
e518068a 6975 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6976 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6977 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6978 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6979 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6980 }
f86702cc 6981 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6982 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6983 cp2 += 2;
6984 }
a0d0e21e
LW		 6985 }
6986 else if (*cp2 == '-') {
6987 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6988 while (*cp2 == '-') {
6989 cp2++;
6990 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6991 }
6992 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
0e5ce2c7 6993 /* filespecs like */
01b8edb6 6994 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
0e5ce2c7
JM		 6995 if (vms_debug_fileify) {
6996 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
6997 }
a0d0e21e
LW		 6998 return NULL;
6999 }
a0d0e21e
LW		 7000 }
7001 else *(cp1++) = *cp2;
7002 }
7003 else *(cp1++) = *cp2;
7004 }
0e5ce2c7 7005 /* Translate the rest of the filename. */
42cd432e 7006 while (*cp2) {
0e5ce2c7
JM		 7007 int dot_seen;
7008 dot_seen = 0;
7009 switch(*cp2) {
7010 /* Fixme - for compatibility with the CRTL we should be removing */
7011 /* spaces from the file specifications, but this may show that */
7012 /* some tests that were appearing to pass are not really passing */
7013 case '%':
7014 cp2++;
7015 *(cp1++) = '?';
7016 break;
7017 case '^':
7018 /* Fix me hex expansions not implemented */
7019 cp2++; /* '^.' --> '.' and other. */
7020 if (*cp2) {
7021 if (*cp2 == '_') {
7022 cp2++;
7023 *(cp1++) = ' ';
7024 } else {
7025 *(cp1++) = *(cp2++);
7026 }
7027 }
7028 break;
7029 case ';':
7030 if (decc_filename_unix_no_version) {
7031 /* Easy, drop the version */
7032 while (*cp2)
7033 cp2++;
7034 break;
7035 } else {
7036 /* Punt - passing the version as a dot will probably */
7037 /* break perl in weird ways, but so did passing */
7038 /* through the ; as a version. Follow the CRTL and */
7039 /* hope for the best. */
7040 cp2++;
7041 *(cp1++) = '.';
7042 }
7043 break;
7044 case '.':
7045 if (dot_seen) {
7046 /* We will need to fix this properly later */
7047 /* As Perl may be installed on an ODS-5 volume, but not */
7048 /* have the EFS_CHARSET enabled, it still may encounter */
7049 /* filenames with extra dots in them, and a precedent got */
7050 /* set which allowed them to work, that we will uphold here */
7051 /* If extra dots are present in a name and no ^ is on them */
7052 /* VMS assumes that the first one is the extension delimiter */
7053 /* the rest have an implied ^. */
7054
7055 /* this is also a conflict as the . is also a version */
7056 /* delimiter in VMS, */
7057
7058 *(cp1++) = *(cp2++);
7059 break;
7060 }
7061 dot_seen = 1;
7062 /* This is an extension */
7063 if (decc_readdir_dropdotnotype) {
7064 cp2++;
7065 if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7066 /* Drop the dot for the extension */
7067 break;
7068 } else {
7069 *(cp1++) = '.';
7070 }
7071 break;
7072 }
7073 default:
7074 *(cp1++) = *(cp2++);
7075 }
42cd432e 7076 }
a0d0e21e
LW		 7077 *cp1 = '\0';
7078
f7ddb74a
JM		 7079 /* This still leaves /000000/ when working with a
7080 * VMS device root or concealed root.
7081 */
7082 {
7083 int ulen;
7084 char * zeros;
7085
7086 ulen = strlen(rslt);
7087
7088 /* Get rid of "000000/ in rooted filespecs */
7089 if (ulen > 7) {
7090 zeros = strstr(rslt, "/000000/");
7091 if (zeros != NULL) {
7092 int mlen;
7093 mlen = ulen - (zeros - rslt) - 7;
7094 memmove(zeros, &zeros[7], mlen);
7095 ulen = ulen - 7;
7096 rslt[ulen] = '\0';
7097 }
7098 }
7099 }
7100
0e5ce2c7
JM		 7101 if (vms_debug_fileify) {
7102 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7103 }
a0d0e21e
LW		 7104 return rslt;
7105
0e5ce2c7
JM		 7106} /* end of int_tounixspec() */
7107
7108
7109/*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7110static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7111{
7112 static char __tounixspec_retbuf[VMS_MAXRSS];
7113 char * unixspec, *ret_spec, *ret_buf;
7114
7115 unixspec = NULL;
7116 ret_buf = buf;
7117 if (ret_buf == NULL) {
7118 if (ts) {
7119 Newx(unixspec, VMS_MAXRSS, char);
7120 if (unixspec == NULL)
7121 _ckvmssts(SS$_INSFMEM);
7122 ret_buf = unixspec;
7123 } else {
7124 ret_buf = __tounixspec_retbuf;
7125 }
7126 }
7127
7128 ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7129
7130 if (ret_spec == NULL) {
7131 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7132 if (unixspec)
7133 Safefree(unixspec);
7134 }
7135
7136 return ret_spec;
7137
a0d0e21e
LW		 7138} /* end of do_tounixspec() */
7139/*}}}*/
7140/* External entry points */
360732b5
JM		 7141char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7142 { return do_tounixspec(spec,buf,0, NULL); }
7143char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7144 { return do_tounixspec(spec,buf,1, NULL); }
7145char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7146 { return do_tounixspec(spec,buf,0, utf8_fl); }
7147char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7148 { return do_tounixspec(spec,buf,1, utf8_fl); }
a0d0e21e 7149
360732b5 7150#if __CRTL_VER >= 70200000 && !defined(__VAX)
2497a41f 7151
360732b5
JM		 7152/*
7153 This procedure is used to identify if a path is based in either
7154 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7155 it returns the OpenVMS format directory for it.
7156
7157 It is expecting specifications of only '/' or '/xxxx/'
7158
7159 If a posix root does not exist, or 'xxxx' is not a directory
7160 in the posix root, it returns a failure.
7161
7162 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7163
7164 It is used only internally by posix_to_vmsspec_hardway().
7165 */
7166
7167static int posix_root_to_vms
7168 (char *vmspath, int vmspath_len,
7169 const char *unixpath,
d584a1c6
JM		 7170 const int * utf8_fl)
7171{
2497a41f
JM		 7172int sts;
7173struct FAB myfab = cc$rms_fab;
d584a1c6 7174rms_setup_nam(mynam);
2497a41f 7175struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
d584a1c6
JM		 7176struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7177char * esa, * esal, * rsa, * rsal;
2497a41f
JM		 7178char *vms_delim;
7179int dir_flag;
7180int unixlen;
7181
360732b5 7182 dir_flag = 0;
d584a1c6 7183 vmspath[0] = '\0';
360732b5
JM		 7184 unixlen = strlen(unixpath);
7185 if (unixlen == 0) {
360732b5
JM		 7186 return RMS$_FNF;
7187 }
7188
7189#if __CRTL_VER >= 80200000
2497a41f 7190 /* If not a posix spec already, convert it */
360732b5
JM		 7191 if (decc_posix_compliant_pathnames) {
7192 if (strncmp(unixpath,"\"^UP^",5) != 0) {
7193 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7194 }
7195 else {
7196 /* This is already a VMS specification, no conversion */
7197 unixlen--;
7198 strncpy(vmspath,unixpath, vmspath_len);
7199 }
2497a41f 7200 }
360732b5
JM		 7201 else
7202#endif
7203 {
7204 int path_len;
7205 int i,j;
7206
7207 /* Check to see if this is under the POSIX root */
7208 if (decc_disable_posix_root) {
7209 return RMS$_FNF;
7210 }
7211
7212 /* Skip leading / */
7213 if (unixpath[0] == '/') {
7214 unixpath++;
7215 unixlen--;
7216 }
7217
7218
7219 strcpy(vmspath,"SYS$POSIX_ROOT:");
7220
7221 /* If this is only the / , or blank, then... */
7222 if (unixpath[0] == '\0') {
7223 /* by definition, this is the answer */
7224 return SS$_NORMAL;
7225 }
7226
7227 /* Need to look up a directory */
7228 vmspath[15] = '[';
7229 vmspath[16] = '\0';
7230
7231 /* Copy and add '^' escape characters as needed */
7232 j = 16;
7233 i = 0;
7234 while (unixpath[i] != 0) {
7235 int k;
7236
7237 j += copy_expand_unix_filename_escape
7238 (&vmspath[j], &unixpath[i], &k, utf8_fl);
7239 i += k;
7240 }
7241
7242 path_len = strlen(vmspath);
7243 if (vmspath[path_len - 1] == '/')
7244 path_len--;
7245 vmspath[path_len] = ']';
7246 path_len++;
7247 vmspath[path_len] = '\0';
7248
2497a41f
JM		 7249 }
7250 vmspath[vmspath_len] = 0;
7251 if (unixpath[unixlen - 1] == '/')
7252 dir_flag = 1;
d584a1c6
JM		 7253 esal = PerlMem_malloc(VMS_MAXRSS);
7254 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7255 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
c5375c28 7256 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 7257 rsal = PerlMem_malloc(VMS_MAXRSS);
7258 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7259 rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7260 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7261 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7262 rms_bind_fab_nam(myfab, mynam);
7263 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7264 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
2497a41f
JM		 7265 if (decc_efs_case_preserve)
7266 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
ea0c9945 7267#ifdef NAML$M_OPEN_SPECIAL
2497a41f 7268 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
ea0c9945 7269#endif
2497a41f
JM		 7270
7271 /* Set up the remaining naml fields */
7272 sts = sys$parse(&myfab);
7273
7274 /* It failed! Try again as a UNIX filespec */
7275 if (!(sts & 1)) {
d584a1c6 7276 PerlMem_free(esal);
367e4b85 7277 PerlMem_free(esa);
d584a1c6
JM		 7278 PerlMem_free(rsal);
7279 PerlMem_free(rsa);
2497a41f
JM		 7280 return sts;
7281 }
7282
7283 /* get the Device ID and the FID */
7284 sts = sys$search(&myfab);
d584a1c6
JM		 7285
7286 /* These are no longer needed */
7287 PerlMem_free(esa);
7288 PerlMem_free(rsal);
7289 PerlMem_free(rsa);
7290
2497a41f
JM		 7291 /* on any failure, returned the POSIX ^UP^ filespec */
7292 if (!(sts & 1)) {
d584a1c6 7293 PerlMem_free(esal);
2497a41f
JM		 7294 return sts;
7295 }
7296 specdsc.dsc$a_pointer = vmspath;
7297 specdsc.dsc$w_length = vmspath_len;
7298
7299 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7300 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7301 sts = lib$fid_to_name
7302 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7303
7304 /* on any failure, returned the POSIX ^UP^ filespec */
7305 if (!(sts & 1)) {
7306 /* This can happen if user does not have permission to read directories */
7307 if (strncmp(unixpath,"\"^UP^",5) != 0)
7308 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7309 else
7310 strcpy(vmspath, unixpath);
7311 }
7312 else {
7313 vmspath[specdsc.dsc$w_length] = 0;
7314
7315 /* Are we expecting a directory? */
7316 if (dir_flag != 0) {
7317 int i;
7318 char *eptr;
7319
7320 eptr = NULL;
7321
7322 i = specdsc.dsc$w_length - 1;
7323 while (i > 0) {
7324 int zercnt;
7325 zercnt = 0;
7326 /* Version must be '1' */
7327 if (vmspath[i--] != '1')
7328 break;
7329 /* Version delimiter is one of ".;" */
7330 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7331 break;
7332 i--;
7333 if (vmspath[i--] != 'R')
7334 break;
7335 if (vmspath[i--] != 'I')
7336 break;
7337 if (vmspath[i--] != 'D')
7338 break;
7339 if (vmspath[i--] != '.')
7340 break;
7341 eptr = &vmspath[i+1];
7342 while (i > 0) {
7343 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7344 if (vmspath[i-1] != '^') {
7345 if (zercnt != 6) {
7346 *eptr = vmspath[i];
7347 eptr[1] = '\0';
7348 vmspath[i] = '.';
7349 break;
7350 }
7351 else {
7352 /* Get rid of 6 imaginary zero directory filename */
7353 vmspath[i+1] = '\0';
7354 }
7355 }
7356 }
7357 if (vmspath[i] == '0')
7358 zercnt++;
7359 else
7360 zercnt = 10;
7361 i--;
7362 }
7363 break;
7364 }
7365 }
7366 }
d584a1c6 7367 PerlMem_free(esal);
2497a41f
JM		 7368 return sts;
7369}
7370
360732b5
JM		 7371/* /dev/mumble needs to be handled special.
7372 /dev/null becomes NLA0:, And there is the potential for other stuff
7373 like /dev/tty which may need to be mapped to something.
7374*/
7375
7376static int
7377slash_dev_special_to_vms
7378 (const char * unixptr,
7379 char * vmspath,
7380 int vmspath_len)
7381{
7382char * nextslash;
7383int len;
7384int cmp;
7385int islnm;
7386
7387 unixptr += 4;
7388 nextslash = strchr(unixptr, '/');
7389 len = strlen(unixptr);
7390 if (nextslash != NULL)
7391 len = nextslash - unixptr;
7392 cmp = strncmp("null", unixptr, 5);
7393 if (cmp == 0) {
7394 if (vmspath_len >= 6) {
7395 strcpy(vmspath, "_NLA0:");
7396 return SS$_NORMAL;
7397 }
7398 }
7399}
7400
7401
7402/* The built in routines do not understand perl's special needs, so
7403 doing a manual conversion from UNIX to VMS
7404
7405 If the utf8_fl is not null and points to a non-zero value, then
7406 treat 8 bit characters as UTF-8.
7407
7408 The sequence starting with '$(' and ending with ')' will be passed
7409 through with out interpretation instead of being escaped.
7410
7411 */
2497a41f 7412static int posix_to_vmsspec_hardway
360732b5
JM		 7413 (char *vmspath, int vmspath_len,
7414 const char *unixpath,
7415 int dir_flag,
7416 int * utf8_fl) {
2497a41f
JM		 7417
7418char *esa;
7419const char *unixptr;
360732b5 7420const char *unixend;
2497a41f
JM		 7421char *vmsptr;
7422const char *lastslash;
7423const char *lastdot;
7424int unixlen;
7425int vmslen;
7426int dir_start;
7427int dir_dot;
7428int quoted;
360732b5
JM		 7429char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7430int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
2497a41f 7431
360732b5
JM		 7432 if (utf8_fl != NULL)
7433 *utf8_fl = 0;
2497a41f
JM		 7434
7435 unixptr = unixpath;
7436 dir_dot = 0;
7437
7438 /* Ignore leading "/" characters */
7439 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7440 unixptr++;
7441 }
7442 unixlen = strlen(unixptr);
7443
7444 /* Do nothing with blank paths */
7445 if (unixlen == 0) {
7446 vmspath[0] = '\0';
7447 return SS$_NORMAL;
7448 }
7449
360732b5
JM		 7450 quoted = 0;
7451 /* This could have a "^UP^ on the front */
7452 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7453 quoted = 1;
7454 unixptr+= 5;
7455 unixlen-= 5;
7456 }
7457
2497a41f
JM		 7458 lastslash = strrchr(unixptr,'/');
7459 lastdot = strrchr(unixptr,'.');
360732b5
JM		 7460 unixend = strrchr(unixptr,'\"');
7461 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7462 unixend = unixptr + unixlen;
7463 }
2497a41f
JM		 7464
7465 /* last dot is last dot or past end of string */
7466 if (lastdot == NULL)
7467 lastdot = unixptr + unixlen;
7468
7469 /* if no directories, set last slash to beginning of string */
7470 if (lastslash == NULL) {
7471 lastslash = unixptr;
7472 }
7473 else {
7474 /* Watch out for trailing "." after last slash, still a directory */
7475 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7476 lastslash = unixptr + unixlen;
7477 }
7478
7479 /* Watch out for traiing ".." after last slash, still a directory */
7480 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7481 lastslash = unixptr + unixlen;
7482 }
7483
7484 /* dots in directories are aways escaped */
7485 if (lastdot < lastslash)
7486 lastdot = unixptr + unixlen;
7487 }
7488
7489 /* if (unixptr < lastslash) then we are in a directory */
7490
7491 dir_start = 0;
2497a41f
JM		 7492
7493 vmsptr = vmspath;
7494 vmslen = 0;
7495
2497a41f
JM		 7496 /* Start with the UNIX path */
7497 if (*unixptr != '/') {
7498 /* relative paths */
360732b5
JM		 7499
7500 /* If allowing logical names on relative pathnames, then handle here */
7501 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7502 !decc_posix_compliant_pathnames) {
7503 char * nextslash;
7504 int seg_len;
7505 char * trn;
7506 int islnm;
7507
7508 /* Find the next slash */
7509 nextslash = strchr(unixptr,'/');
7510
7511 esa = PerlMem_malloc(vmspath_len);
7512 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7513
7514 trn = PerlMem_malloc(VMS_MAXRSS);
7515 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7516
7517 if (nextslash != NULL) {
7518
7519 seg_len = nextslash - unixptr;
7520 strncpy(esa, unixptr, seg_len);
7521 esa[seg_len] = 0;
7522 }
7523 else {
7524 strcpy(esa, unixptr);
7525 seg_len = strlen(unixptr);
7526 }
7527 /* trnlnm(section) */
7528 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7529
7530 if (islnm) {
7531 /* Now fix up the directory */
7532
7533 /* Split up the path to find the components */
7534 sts = vms_split_path
7535 (trn,
7536 &v_spec,
7537 &v_len,
7538 &r_spec,
7539 &r_len,
7540 &d_spec,
7541 &d_len,
7542 &n_spec,
7543 &n_len,
7544 &e_spec,
7545 &e_len,
7546 &vs_spec,
7547 &vs_len);
7548
7549 while (sts == 0) {
7550 char * strt;
7551 int cmp;
7552
7553 /* A logical name must be a directory or the full
7554 specification. It is only a full specification if
7555 it is the only component */
7556 if ((unixptr[seg_len] == '\0') ||
7557 (unixptr[seg_len+1] == '\0')) {
7558
7559 /* Is a directory being required? */
7560 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7561 /* Not a logical name */
7562 break;
7563 }
7564
7565
7566 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7567 /* This must be a directory */
7568 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7569 strcpy(vmsptr, esa);
7570 vmslen=strlen(vmsptr);
7571 vmsptr[vmslen] = ':';
7572 vmslen++;
7573 vmsptr[vmslen] = '\0';
7574 return SS$_NORMAL;
7575 }
7576 }
7577
7578 }
7579
7580
7581 /* must be dev/directory - ignore version */
7582 if ((n_len + e_len) != 0)
7583 break;
7584
7585 /* transfer the volume */
7586 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7587 strncpy(vmsptr, v_spec, v_len);
7588 vmsptr += v_len;
7589 vmsptr[0] = '\0';
7590 vmslen += v_len;
7591 }
7592
7593 /* unroot the rooted directory */
7594 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7595 r_spec[0] = '[';
7596 r_spec[r_len - 1] = ']';
7597
7598 /* This should not be there, but nothing is perfect */
7599 if (r_len > 9) {
7600 cmp = strcmp(&r_spec[1], "000000.");
7601 if (cmp == 0) {
7602 r_spec += 7;
7603 r_spec[7] = '[';
7604 r_len -= 7;
7605 if (r_len == 2)
7606 r_len = 0;
7607 }
7608 }
7609 if (r_len > 0) {
7610 strncpy(vmsptr, r_spec, r_len);
7611 vmsptr += r_len;
7612 vmslen += r_len;
7613 vmsptr[0] = '\0';
7614 }
7615 }
7616 /* Bring over the directory. */
7617 if ((d_len > 0) &&
7618 ((d_len + vmslen) < vmspath_len)) {
7619 d_spec[0] = '[';
7620 d_spec[d_len - 1] = ']';
7621 if (d_len > 9) {
7622 cmp = strcmp(&d_spec[1], "000000.");
7623 if (cmp == 0) {
7624 d_spec += 7;
7625 d_spec[7] = '[';
7626 d_len -= 7;
7627 if (d_len == 2)
7628 d_len = 0;
7629 }
7630 }
7631
7632 if (r_len > 0) {
7633 /* Remove the redundant root */
7634 if (r_len > 0) {
7635 /* remove the ][ */
7636 vmsptr--;
7637 vmslen--;
7638 d_spec++;
7639 d_len--;
7640 }
7641 strncpy(vmsptr, d_spec, d_len);
7642 vmsptr += d_len;
7643 vmslen += d_len;
7644 vmsptr[0] = '\0';
7645 }
7646 }
7647 break;
7648 }
7649 }
7650
7651 PerlMem_free(esa);
7652 PerlMem_free(trn);
7653 }
7654
2497a41f
JM		 7655 if (lastslash > unixptr) {
7656 int dotdir_seen;
7657
7658 /* skip leading ./ */
7659 dotdir_seen = 0;
7660 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7661 dotdir_seen = 1;
7662 unixptr++;
7663 unixptr++;
7664 }
7665
7666 /* Are we still in a directory? */
7667 if (unixptr <= lastslash) {
7668 *vmsptr++ = '[';
7669 vmslen = 1;
7670 dir_start = 1;
7671
7672 /* if not backing up, then it is relative forward. */
7673 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
360732b5 7674 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
2497a41f
JM		 7675 *vmsptr++ = '.';
7676 vmslen++;
7677 dir_dot = 1;
360732b5 7678 }
2497a41f
JM		 7679 }
7680 else {
7681 if (dotdir_seen) {
7682 /* Perl wants an empty directory here to tell the difference
7683 * between a DCL commmand and a filename
7684 */
7685 *vmsptr++ = '[';
7686 *vmsptr++ = ']';
7687 vmslen = 2;
7688 }
7689 }
7690 }
7691 else {
7692 /* Handle two special files . and .. */
7693 if (unixptr[0] == '.') {
360732b5 7694 if (&unixptr[1] == unixend) {
2497a41f
JM		 7695 *vmsptr++ = '[';
7696 *vmsptr++ = ']';
7697 vmslen += 2;
7698 *vmsptr++ = '\0';
7699 return SS$_NORMAL;
7700 }
360732b5 7701 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
2497a41f
JM		 7702 *vmsptr++ = '[';
7703 *vmsptr++ = '-';
7704 *vmsptr++ = ']';
7705 vmslen += 3;
7706 *vmsptr++ = '\0';
7707 return SS$_NORMAL;
7708 }
7709 }
7710 }
7711 }
7712 else { /* Absolute PATH handling */
7713 int sts;
7714 char * nextslash;
7715 int seg_len;
7716 /* Need to find out where root is */
7717
7718 /* In theory, this procedure should never get an absolute POSIX pathname
7719 * that can not be found on the POSIX root.
7720 * In practice, that can not be relied on, and things will show up
7721 * here that are a VMS device name or concealed logical name instead.
7722 * So to make things work, this procedure must be tolerant.
7723 */
c5375c28
JM		 7724 esa = PerlMem_malloc(vmspath_len);
7725 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2497a41f
JM		 7726
7727 sts = SS$_NORMAL;
7728 nextslash = strchr(&unixptr[1],'/');
7729 seg_len = 0;
7730 if (nextslash != NULL) {
360732b5 7731 int cmp;
2497a41f
JM		 7732 seg_len = nextslash - &unixptr[1];
7733 strncpy(vmspath, unixptr, seg_len + 1);
7734 vmspath[seg_len+1] = 0;
360732b5
JM		 7735 cmp = 1;
7736 if (seg_len == 3) {
7737 cmp = strncmp(vmspath, "dev", 4);
7738 if (cmp == 0) {
7739 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7740 if (sts = SS$_NORMAL)
7741 return SS$_NORMAL;
7742 }
7743 }
7744 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
2497a41f
JM		 7745 }
7746
360732b5 7747 if ($VMS_STATUS_SUCCESS(sts)) {
2497a41f
JM		 7748 /* This is verified to be a real path */
7749
360732b5
JM		 7750 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7751 if ($VMS_STATUS_SUCCESS(sts)) {
7752 strcpy(vmspath, esa);
7753 vmslen = strlen(vmspath);
7754 vmsptr = vmspath + vmslen;
7755 unixptr++;
7756 if (unixptr < lastslash) {
7757 char * rptr;
7758 vmsptr--;
7759 *vmsptr++ = '.';
7760 dir_start = 1;
7761 dir_dot = 1;
7762 if (vmslen > 7) {
7763 int cmp;
7764 rptr = vmsptr - 7;
7765 cmp = strcmp(rptr,"000000.");
7766 if (cmp == 0) {
7767 vmslen -= 7;
7768 vmsptr -= 7;
7769 vmsptr[1] = '\0';
7770 } /* removing 6 zeros */
7771 } /* vmslen < 7, no 6 zeros possible */
7772 } /* Not in a directory */
7773 } /* Posix root found */
7774 else {
7775 /* No posix root, fall back to default directory */
7776 strcpy(vmspath, "SYS$DISK:[");
7777 vmsptr = &vmspath[10];
7778 vmslen = 10;
7779 if (unixptr > lastslash) {
7780 *vmsptr = ']';
7781 vmsptr++;
7782 vmslen++;
7783 }
7784 else {
7785 dir_start = 1;
7786 }
7787 }
2497a41f
JM		 7788 } /* end of verified real path handling */
7789 else {
7790 int add_6zero;
7791 int islnm;
7792
7793 /* Ok, we have a device or a concealed root that is not in POSIX
7794 * or we have garbage. Make the best of it.
7795 */
7796
7797 /* Posix to VMS destroyed this, so copy it again */
7798 strncpy(vmspath, &unixptr[1], seg_len);
7799 vmspath[seg_len] = 0;
7800 vmslen = seg_len;
7801 vmsptr = &vmsptr[vmslen];
7802 islnm = 0;
7803
7804 /* Now do we need to add the fake 6 zero directory to it? */
7805 add_6zero = 1;
7806 if ((*lastslash == '/') && (nextslash < lastslash)) {
7807 /* No there is another directory */
7808 add_6zero = 0;
7809 }
7810 else {
7811 int trnend;
360732b5 7812 int cmp;
2497a41f
JM		 7813
7814 /* now we have foo:bar or foo:[000000]bar to decide from */
7ded3206 7815 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
360732b5
JM		 7816
7817 if (!islnm && !decc_posix_compliant_pathnames) {
7818
7819 cmp = strncmp("bin", vmspath, 4);
7820 if (cmp == 0) {
7821 /* bin => SYS$SYSTEM: */
7822 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7823 }
7824 else {
7825 /* tmp => SYS$SCRATCH: */
7826 cmp = strncmp("tmp", vmspath, 4);
7827 if (cmp == 0) {
7828 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7829 }
7830 }
7831 }
7832
7ded3206 7833 trnend = islnm ? islnm - 1 : 0;
2497a41f
JM		 7834
7835 /* if this was a logical name, ']' or '>' must be present */
7836 /* if not a logical name, then assume a device and hope. */
7837 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7838
7839 /* if log name and trailing '.' then rooted - treat as device */
7840 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7841
7842 /* Fix me, if not a logical name, a device lookup should be
7843 * done to see if the device is file structured. If the device
7844 * is not file structured, the 6 zeros should not be put on.
7845 *
7846 * As it is, perl is occasionally looking for dev:[000000]tty.
7847 * which looks a little strange.
360732b5
JM		 7848 *
7849 * Not that easy to detect as "/dev" may be file structured with
7850 * special device files.
2497a41f
JM		 7851 */
7852
360732b5
JM		 7853 if ((add_6zero == 0) && (*nextslash == '/') &&
7854 (&nextslash[1] == unixend)) {
2497a41f
JM		 7855 /* No real directory present */
7856 add_6zero = 1;
7857 }
7858 }
7859
7860 /* Put the device delimiter on */
7861 *vmsptr++ = ':';
7862 vmslen++;
7863 unixptr = nextslash;
7864 unixptr++;
7865
7866 /* Start directory if needed */
7867 if (!islnm || add_6zero) {
7868 *vmsptr++ = '[';
7869 vmslen++;
7870 dir_start = 1;
7871 }
7872
7873 /* add fake 000000] if needed */
7874 if (add_6zero) {
7875 *vmsptr++ = '0';
7876 *vmsptr++ = '0';
7877 *vmsptr++ = '0';
7878 *vmsptr++ = '0';
7879 *vmsptr++ = '0';
7880 *vmsptr++ = '0';
7881 *vmsptr++ = ']';
7882 vmslen += 7;
7883 dir_start = 0;
7884 }
7885
7886 } /* non-POSIX translation */
367e4b85 7887 PerlMem_free(esa);
2497a41f
JM		 7888 } /* End of relative/absolute path handling */
7889
360732b5 7890 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
2497a41f 7891 int dash_flag;
360732b5
JM		 7892 int in_cnt;
7893 int out_cnt;
2497a41f
JM		 7894
7895 dash_flag = 0;
7896
7897 if (dir_start != 0) {
7898
7899 /* First characters in a directory are handled special */
7900 while ((*unixptr == '/') ||
7901 ((*unixptr == '.') &&
360732b5
JM		 7902 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7903 (&unixptr[1]==unixend)))) {
2497a41f
JM		 7904 int loop_flag;
7905
7906 loop_flag = 0;
7907
7908 /* Skip redundant / in specification */
7909 while ((*unixptr == '/') && (dir_start != 0)) {
7910 loop_flag = 1;
7911 unixptr++;
7912 if (unixptr == lastslash)
7913 break;
7914 }
7915 if (unixptr == lastslash)
7916 break;
7917
7918 /* Skip redundant ./ characters */
7919 while ((*unixptr == '.') &&
360732b5 7920 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
2497a41f
JM		 7921 loop_flag = 1;
7922 unixptr++;
7923 if (unixptr == lastslash)
7924 break;
7925 if (*unixptr == '/')
7926 unixptr++;
7927 }
7928 if (unixptr == lastslash)
7929 break;
7930
7931 /* Skip redundant ../ characters */
7932 while ((*unixptr == '.') && (unixptr[1] == '.') &&
360732b5 7933 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
2497a41f
JM		 7934 /* Set the backing up flag */
7935 loop_flag = 1;
7936 dir_dot = 0;
7937 dash_flag = 1;
7938 *vmsptr++ = '-';
7939 vmslen++;
7940 unixptr++; /* first . */
7941 unixptr++; /* second . */
7942 if (unixptr == lastslash)
7943 break;
7944 if (*unixptr == '/') /* The slash */
7945 unixptr++;
7946 }
7947 if (unixptr == lastslash)
7948 break;
7949
7950 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7951 /* Not needed when VMS is pretending to be UNIX. */
7952
7953 /* Is this loop stuck because of too many dots? */
7954 if (loop_flag == 0) {
7955 /* Exit the loop and pass the rest through */
7956 break;
7957 }
7958 }
7959
7960 /* Are we done with directories yet? */
7961 if (unixptr >= lastslash) {
7962
7963 /* Watch out for trailing dots */
7964 if (dir_dot != 0) {
7965 vmslen --;
7966 vmsptr--;
7967 }
7968 *vmsptr++ = ']';
7969 vmslen++;
7970 dash_flag = 0;
7971 dir_start = 0;
7972 if (*unixptr == '/')
7973 unixptr++;
7974 }
7975 else {
7976 /* Have we stopped backing up? */
7977 if (dash_flag) {
7978 *vmsptr++ = '.';
7979 vmslen++;
7980 dash_flag = 0;
7981 /* dir_start continues to be = 1 */
7982 }
7983 if (*unixptr == '-') {
7984 *vmsptr++ = '^';
7985 *vmsptr++ = *unixptr++;
7986 vmslen += 2;
7987 dir_start = 0;
7988
7989 /* Now are we done with directories yet? */
7990 if (unixptr >= lastslash) {
7991
7992 /* Watch out for trailing dots */
7993 if (dir_dot != 0) {
7994 vmslen --;
7995 vmsptr--;
7996 }
7997
7998 *vmsptr++ = ']';
7999 vmslen++;
8000 dash_flag = 0;
8001 dir_start = 0;
8002 }
8003 }
8004 }
8005 }
8006
8007 /* All done? */
360732b5 8008 if (unixptr >= unixend)
2497a41f
JM		 8009 break;
8010
8011 /* Normal characters - More EFS work probably needed */
8012 dir_start = 0;
8013 dir_dot = 0;
8014
8015 switch(*unixptr) {
8016 case '/':
8017 /* remove multiple / */
8018 while (unixptr[1] == '/') {
8019 unixptr++;
8020 }
8021 if (unixptr == lastslash) {
8022 /* Watch out for trailing dots */
8023 if (dir_dot != 0) {
8024 vmslen --;
8025 vmsptr--;
8026 }
8027 *vmsptr++ = ']';
8028 }
8029 else {
8030 dir_start = 1;
8031 *vmsptr++ = '.';
8032 dir_dot = 1;
8033
8034 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8035 /* Not needed when VMS is pretending to be UNIX. */
8036
8037 }
8038 dash_flag = 0;
360732b5 8039 if (unixptr != unixend)
2497a41f
JM		 8040 unixptr++;
8041 vmslen++;
8042 break;
2497a41f 8043 case '.':
360732b5
JM		 8044 if ((unixptr < lastdot) || (unixptr < lastslash) ||
8045 (&unixptr[1] == unixend)) {
2497a41f
JM		 8046 *vmsptr++ = '^';
8047 *vmsptr++ = '.';
8048 vmslen += 2;
8049 unixptr++;
8050
8051 /* trailing dot ==> '^..' on VMS */
360732b5 8052 if (unixptr == unixend) {
2497a41f
JM		 8053 *vmsptr++ = '.';
8054 vmslen++;
360732b5 8055 unixptr++;
2497a41f 8056 }
2497a41f
JM		 8057 break;
8058 }
360732b5 8059
2497a41f 8060 *vmsptr++ = *unixptr++;
360732b5
JM		 8061 vmslen ++;
8062 break;
8063 case '"':
8064 if (quoted && (&unixptr[1] == unixend)) {
8065 unixptr++;
8066 break;
8067 }
8068 in_cnt = copy_expand_unix_filename_escape
8069 (vmsptr, unixptr, &out_cnt, utf8_fl);
8070 vmsptr += out_cnt;
8071 unixptr += in_cnt;
2497a41f
JM		 8072 break;
8073 case '~':
8074 case ';':
8075 case '\\':
360732b5
JM		 8076 case '?':
8077 case ' ':
2497a41f 8078 default:
360732b5
JM		 8079 in_cnt = copy_expand_unix_filename_escape
8080 (vmsptr, unixptr, &out_cnt, utf8_fl);
8081 vmsptr += out_cnt;
8082 unixptr += in_cnt;
2497a41f
JM		 8083 break;
8084 }
8085 }
8086
8087 /* Make sure directory is closed */
8088 if (unixptr == lastslash) {
8089 char *vmsptr2;
8090 vmsptr2 = vmsptr - 1;
8091
8092 if (*vmsptr2 != ']') {
8093 *vmsptr2--;
8094
8095 /* directories do not end in a dot bracket */
8096 if (*vmsptr2 == '.') {
8097 vmsptr2--;
8098
8099 /* ^. is allowed */
8100 if (*vmsptr2 != '^') {
8101 vmsptr--; /* back up over the dot */
8102 }
8103 }
8104 *vmsptr++ = ']';
8105 }
8106 }
8107 else {
8108 char *vmsptr2;
8109 /* Add a trailing dot if a file with no extension */
8110 vmsptr2 = vmsptr - 1;
360732b5
JM		 8111 if ((vmslen > 1) &&
8112 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8113 (*vmsptr2 != ')') && (*lastdot != '.')) {
2497a41f
JM		 8114 *vmsptr++ = '.';
8115 vmslen++;
8116 }
8117 }
8118
8119 *vmsptr = '\0';
8120 return SS$_NORMAL;
8121}
8122#endif
8123
360732b5
JM		 8124 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8125static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8126{
8127char * result;
8128int utf8_flag;
8129
8130 /* If a UTF8 flag is being passed, honor it */
8131 utf8_flag = 0;
8132 if (utf8_fl != NULL) {
8133 utf8_flag = *utf8_fl;
8134 *utf8_fl = 0;
8135 }
8136
8137 if (utf8_flag) {
8138 /* If there is a possibility of UTF8, then if any UTF8 characters
8139 are present, then they must be converted to VTF-7
8140 */
8141 result = strcpy(rslt, path); /* FIX-ME */
8142 }
8143 else
8144 result = strcpy(rslt, path);
8145
8146 return result;
8147}
8148
8149
df278665 8150
360732b5 8151/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
df278665
JM		 8152static char *int_tovmsspec
8153 (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8154 char *dirend;
f7ddb74a
JM		 8155 char *lastdot;
8156 char *vms_delim;
b8ffc8df
RGS		 8157 register char *cp1;
8158 const char *cp2;
e518068a 8159 unsigned long int infront = 0, hasdir = 1;
f7ddb74a
JM		 8160 int rslt_len;
8161 int no_type_seen;
360732b5
JM		 8162 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8163 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e 8164
df278665
JM		 8165 if (vms_debug_fileify) {
8166 if (path == NULL)
8167 fprintf(stderr, "int_tovmsspec: path = NULL\n");
8168 else
8169 fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8170 }
8171
8172 if (path == NULL) {
8173 /* If we fail, we should be setting errno */
8174 set_errno(EINVAL);
8175 set_vaxc_errno(SS$_BADPARAM);
8176 return NULL;
8177 }
4d743a9b 8178 rslt_len = VMS_MAXRSS-1;
360732b5
JM		 8179
8180 /* '.' and '..' are "[]" and "[-]" for a quick check */
8181 if (path[0] == '.') {
8182 if (path[1] == '\0') {
8183 strcpy(rslt,"[]");
8184 if (utf8_flag != NULL)
8185 *utf8_flag = 0;
8186 return rslt;
8187 }
8188 else {
8189 if (path[1] == '.' && path[2] == '\0') {
8190 strcpy(rslt,"[-]");
8191 if (utf8_flag != NULL)
8192 *utf8_flag = 0;
8193 return rslt;
8194 }
8195 }
a0d0e21e 8196 }
f7ddb74a 8197
2497a41f
JM		 8198 /* Posix specifications are now a native VMS format */
8199 /*--------------------------------------------------*/
8200#if __CRTL_VER >= 80200000 && !defined(__VAX)
8201 if (decc_posix_compliant_pathnames) {
8202 if (strncmp(path,"\"^UP^",5) == 0) {
360732b5 8203 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
2497a41f
JM		 8204 return rslt;
8205 }
8206 }
8207#endif
8208
360732b5
JM		 8209 /* This is really the only way to see if this is already in VMS format */
8210 sts = vms_split_path
8211 (path,
8212 &v_spec,
8213 &v_len,
8214 &r_spec,
8215 &r_len,
8216 &d_spec,
8217 &d_len,
8218 &n_spec,
8219 &n_len,
8220 &e_spec,
8221 &e_len,
8222 &vs_spec,
8223 &vs_len);
8224 if (sts == 0) {
8225 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8226 replacement, because the above parse just took care of most of
8227 what is needed to do vmspath when the specification is already
8228 in VMS format.
8229
8230 And if it is not already, it is easier to do the conversion as
8231 part of this routine than to call this routine and then work on
8232 the result.
8233 */
2497a41f 8234
360732b5
JM		 8235 /* If VMS punctuation was found, it is already VMS format */
8236 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8237 if (utf8_flag != NULL)
8238 *utf8_flag = 0;
8239 strcpy(rslt, path);
df278665
JM		 8240 if (vms_debug_fileify) {
8241 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8242 }
360732b5
JM		 8243 return rslt;
8244 }
8245 /* Now, what to do with trailing "." cases where there is no
8246 extension? If this is a UNIX specification, and EFS characters
8247 are enabled, then the trailing "." should be converted to a "^.".
8248 But if this was already a VMS specification, then it should be
8249 left alone.
2497a41f 8250
360732b5
JM		 8251 So in the case of ambiguity, leave the specification alone.
8252 */
2497a41f 8253
2497a41f 8254
360732b5
JM		 8255 /* If there is a possibility of UTF8, then if any UTF8 characters
8256 are present, then they must be converted to VTF-7
8257 */
8258 if (utf8_flag != NULL)
8259 *utf8_flag = 0;
8260 strcpy(rslt, path);
df278665
JM		 8261 if (vms_debug_fileify) {
8262 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8263 }
2497a41f
JM		 8264 return rslt;
8265 }
8266
360732b5
JM		 8267 dirend = strrchr(path,'/');
8268
8269 if (dirend == NULL) {
df278665
JM		 8270 char *macro_start;
8271 int has_macro;
8272
360732b5
JM		 8273 /* If we get here with no UNIX directory delimiters, then this is
8274 not a complete file specification, either garbage a UNIX glob
8275 specification that can not be converted to a VMS wildcard, or
df278665
JM		 8276 it a UNIX shell macro. MakeMaker wants shell macros passed
8277 through AS-IS,
360732b5
JM		 8278
8279 utf8 flag setting needs to be preserved.
8280 */
df278665
JM		 8281 hasdir = 0;
8282
8283 has_macro = 0;
8284 macro_start = strchr(path,'$');
8285 if (macro_start != NULL) {
8286 if (macro_start[1] == '(') {
8287 has_macro = 1;
8288 }
8289 }
8290 if ((decc_efs_charset == 0) || (has_macro)) {
8291 strcpy(rslt, path);
8292 if (vms_debug_fileify) {
8293 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8294 }
8295 return rslt;
8296 }
360732b5
JM		 8297 }
8298
2497a41f
JM		 8299/* If POSIX mode active, handle the conversion */
8300#if __CRTL_VER >= 80200000 && !defined(__VAX)
360732b5
JM		 8301 if (decc_efs_charset) {
8302 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
df278665
JM		 8303 if (vms_debug_fileify) {
8304 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8305 }
2497a41f
JM		 8306 return rslt;
8307 }
8308#endif
f7ddb74a 8309
f86702cc 8310 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
748a9306
LW		 8311 if (!*(dirend+2)) dirend +=2;
8312 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
360732b5
JM		 8313 if (decc_efs_charset == 0) {
8314 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8315 }
748a9306 8316 }
f7ddb74a 8317
a0d0e21e
LW		 8318 cp1 = rslt;
8319 cp2 = path;
f7ddb74a 8320 lastdot = strrchr(cp2,'.');
a0d0e21e 8321 if (*cp2 == '/') {
a480973c 8322 char *trndev;
e518068a 8323 int islnm, rooted;
8324 STRLEN trnend;
8325
b7ae7a0d 8326 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
61bb5906 8327 if (!*(cp2+1)) {
f7ddb74a
JM		 8328 if (decc_disable_posix_root) {
8329 strcpy(rslt,"sys$disk:[000000]");
8330 }
8331 else {
8332 strcpy(rslt,"sys$posix_root:[000000]");
8333 }
360732b5
JM		 8334 if (utf8_flag != NULL)
8335 *utf8_flag = 0;
df278665
JM		 8336 if (vms_debug_fileify) {
8337 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8338 }
61bb5906
CB		 8339 return rslt;
8340 }
a0d0e21e 8341 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
e518068a 8342 *cp1 = '\0';
c5375c28 8343 trndev = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 8344 if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
b8486b9d 8345 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8346
8347 /* DECC special handling */
8348 if (!islnm) {
8349 if (strcmp(rslt,"bin") == 0) {
8350 strcpy(rslt,"sys$system");
8351 cp1 = rslt + 10;
8352 *cp1 = 0;
b8486b9d 8353 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8354 }
8355 else if (strcmp(rslt,"tmp") == 0) {
8356 strcpy(rslt,"sys$scratch");
8357 cp1 = rslt + 11;
8358 *cp1 = 0;
b8486b9d 8359 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8360 }
8361 else if (!decc_disable_posix_root) {
8362 strcpy(rslt, "sys$posix_root");
b8486b9d 8363 cp1 = rslt + 14;
f7ddb74a
JM		 8364 *cp1 = 0;
8365 cp2 = path;
8366 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
b8486b9d 8367 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8368 }
8369 else if (strcmp(rslt,"dev") == 0) {
8370 if (strncmp(cp2,"/null", 5) == 0) {
8371 if ((cp2[5] == 0) || (cp2[5] == '/')) {
8372 strcpy(rslt,"NLA0");
8373 cp1 = rslt + 4;
8374 *cp1 = 0;
8375 cp2 = cp2 + 5;
b8486b9d 8376 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8377 }
8378 }
8379 }
8380 }
8381
e518068a 8382 trnend = islnm ? strlen(trndev) - 1 : 0;
8383 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8384 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8385 /* If the first element of the path is a logical name, determine
8386 * whether it has to be translated so we can add more directories. */
8387 if (!islnm || rooted) {
8388 *(cp1++) = ':';
8389 *(cp1++) = '[';
8390 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8391 else cp2++;
8392 }
8393 else {
8394 if (cp2 != dirend) {
e518068a 8395 strcpy(rslt,trndev);
8396 cp1 = rslt + trnend;
755b3d5d
JM		 8397 if (*cp2 != 0) {
8398 *(cp1++) = '.';
8399 cp2++;
8400 }
e518068a 8401 }
8402 else {
f7ddb74a
JM		 8403 if (decc_disable_posix_root) {
8404 *(cp1++) = ':';
8405 hasdir = 0;
8406 }
e518068a 8407 }
8408 }
367e4b85 8409 PerlMem_free(trndev);
748a9306 8410 }
a0d0e21e
LW		 8411 else {
8412 *(cp1++) = '[';
748a9306
LW		 8413 if (*cp2 == '.') {
8414 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8415 cp2 += 2; /* skip over "./" - it's redundant */
8416 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8417 }
8418 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8419 *(cp1++) = '-'; /* "../" --> "-" */
8420 cp2 += 3;
8421 }
f86702cc 8422 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8423 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8424 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8425 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8426 cp2 += 4;
8427 }
f7ddb74a
JM		 8428 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8429 /* Escape the extra dots in EFS file specifications */
8430 *(cp1++) = '^';
8431 }
748a9306
LW		 8432 if (cp2 > dirend) cp2 = dirend;
8433 }
8434 else *(cp1++) = '.';
8435 }
8436 for (; cp2 < dirend; cp2++) {
8437 if (*cp2 == '/') {
01b8edb6 8438 if (*(cp2-1) == '/') continue;
748a9306
LW		 8439 if (*(cp1-1) != '.') *(cp1++) = '.';
8440 infront = 0;
8441 }
8442 else if (!infront && *cp2 == '.') {
01b8edb6 8443 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8444 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
fd7385b9
CB		 8445 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8446 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
748a9306 8447 else if (*(cp1-2) == '[') *(cp1-1) = '-';
fd7385b9
CB		 8448 else { /* back up over previous directory name */
8449 cp1--;
8450 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8451 if (*(cp1-1) == '[') {
8452 memcpy(cp1,"000000.",7);
8453 cp1 += 7;
8454 }
748a9306
LW		 8455 }
8456 cp2 += 2;
01b8edb6 8457 if (cp2 == dirend) break;
748a9306 8458 }
f86702cc 8459 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8460 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8461 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8462 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8463 if (!*(cp2+3)) {
8464 *(cp1++) = '.'; /* Simulate trailing '/' */
8465 cp2 += 2; /* for loop will incr this to == dirend */
8466 }
8467 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8468 }
f7ddb74a
JM		 8469 else {
8470 if (decc_efs_charset == 0)
8471 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8472 else {
8473 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8474 *(cp1++) = '.';
8475 }
8476 }
748a9306
LW		 8477 }
8478 else {
e518068a 8479 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
f7ddb74a
JM		 8480 if (*cp2 == '.') {
8481 if (decc_efs_charset == 0)
8482 *(cp1++) = '_';
8483 else {
8484 *(cp1++) = '^';
8485 *(cp1++) = '.';
8486 }
8487 }
748a9306
LW		 8488 else *(cp1++) = *cp2;
8489 infront = 1;
8490 }
a0d0e21e 8491 }
748a9306 8492 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
e518068a 8493 if (hasdir) *(cp1++) = ']';
748a9306 8494 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
f7ddb74a
JM		 8495 /* fixme for ODS5 */
8496 no_type_seen = 0;
8497 if (cp2 > lastdot)
8498 no_type_seen = 1;
8499 while (*cp2) {
8500 switch(*cp2) {
8501 case '?':
360732b5
JM		 8502 if (decc_efs_charset == 0)
8503 *(cp1++) = '%';
8504 else
8505 *(cp1++) = '?';
f7ddb74a
JM		 8506 cp2++;
8507 case ' ':
8508 *(cp1)++ = '^';
8509 *(cp1)++ = '_';
8510 cp2++;
8511 break;
8512 case '.':
8513 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8514 decc_readdir_dropdotnotype) {
8515 *(cp1)++ = '^';
8516 *(cp1)++ = '.';
8517 cp2++;
8518
8519 /* trailing dot ==> '^..' on VMS */
8520 if (*cp2 == '\0') {
8521 *(cp1++) = '.';
8522 no_type_seen = 0;
8523 }
8524 }
8525 else {
8526 *(cp1++) = *(cp2++);
8527 no_type_seen = 0;
8528 }
8529 break;
360732b5
JM		 8530 case '$':
8531 /* This could be a macro to be passed through */
8532 *(cp1++) = *(cp2++);
8533 if (*cp2 == '(') {
8534 const char * save_cp2;
8535 char * save_cp1;
8536 int is_macro;
8537
8538 /* paranoid check */
8539 save_cp2 = cp2;
8540 save_cp1 = cp1;
8541 is_macro = 0;
8542
8543 /* Test through */
8544 *(cp1++) = *(cp2++);
8545 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8546 *(cp1++) = *(cp2++);
8547 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8548 *(cp1++) = *(cp2++);
8549 }
8550 if (*cp2 == ')') {
8551 *(cp1++) = *(cp2++);
8552 is_macro = 1;
8553 }
8554 }
8555 if (is_macro == 0) {
8556 /* Not really a macro - never mind */
8557 cp2 = save_cp2;
8558 cp1 = save_cp1;
8559 }
8560 }
8561 break;
f7ddb74a
JM		 8562 case '\"':
8563 case '~':
8564 case '`':
8565 case '!':
8566 case '#':
8567 case '%':
8568 case '^':
adc11f0b
CB		 8569 /* Don't escape again if following character is
8570 * already something we escape.
8571 */
8572 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8573 *(cp1++) = *(cp2++);
8574 break;
8575 }
8576 /* But otherwise fall through and escape it. */
f7ddb74a
JM		 8577 case '&':
8578 case '(':
8579 case ')':
8580 case '=':
8581 case '+':
8582 case '\'':
8583 case '@':
8584 case '[':
8585 case ']':
8586 case '{':
8587 case '}':
8588 case ':':
8589 case '\\':
8590 case '|':
8591 case '<':
8592 case '>':
8593 *(cp1++) = '^';
8594 *(cp1++) = *(cp2++);
8595 break;
8596 case ';':
8597 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
657054d4 8598 * which is wrong. UNIX notation should be ".dir." unless
f7ddb74a
JM		 8599 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8600 * changing this behavior could break more things at this time.
2497a41f
JM		 8601 * efs character set effectively does not allow "." to be a version
8602 * delimiter as a further complication about changing this.
f7ddb74a
JM		 8603 */
8604 if (decc_filename_unix_report != 0) {
8605 *(cp1++) = '^';
8606 }
8607 *(cp1++) = *(cp2++);
8608 break;
8609 default:
8610 *(cp1++) = *(cp2++);
8611 }
8612 }
8613 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8614 char *lcp1;
8615 lcp1 = cp1;
8616 lcp1--;
8617 /* Fix me for "^]", but that requires making sure that you do
8618 * not back up past the start of the filename
8619 */
8620 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8621 *cp1++ = '.';
8622 }
a0d0e21e
LW		 8623 *cp1 = '\0';
8624
360732b5
JM		 8625 if (utf8_flag != NULL)
8626 *utf8_flag = 0;
df278665
JM		 8627 if (vms_debug_fileify) {
8628 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8629 }
a0d0e21e
LW		 8630 return rslt;
8631
df278665
JM		 8632} /* end of int_tovmsspec() */
8633
8634
8635/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8636static char *mp_do_tovmsspec
8637 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8638 static char __tovmsspec_retbuf[VMS_MAXRSS];
8639 char * vmsspec, *ret_spec, *ret_buf;
8640
8641 vmsspec = NULL;
8642 ret_buf = buf;
8643 if (ret_buf == NULL) {
8644 if (ts) {
8645 Newx(vmsspec, VMS_MAXRSS, char);
8646 if (vmsspec == NULL)
8647 _ckvmssts(SS$_INSFMEM);
8648 ret_buf = vmsspec;
8649 } else {
8650 ret_buf = __tovmsspec_retbuf;
8651 }
8652 }
8653
8654 ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8655
8656 if (ret_spec == NULL) {
8657 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8658 if (vmsspec)
8659 Safefree(vmsspec);
8660 }
8661
8662 return ret_spec;
8663
8664} /* end of mp_do_tovmsspec() */
a0d0e21e
LW		 8665/*}}}*/
8666/* External entry points */
360732b5
JM		 8667char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8668 { return do_tovmsspec(path,buf,0,NULL); }
8669char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8670 { return do_tovmsspec(path,buf,1,NULL); }
8671char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8672 { return do_tovmsspec(path,buf,0,utf8_fl); }
8673char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8674 { return do_tovmsspec(path,buf,1,utf8_fl); }
8675
8676/*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8677static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
a480973c 8678 static char __tovmspath_retbuf[VMS_MAXRSS];
a0d0e21e 8679 int vmslen;
a480973c 8680 char *pathified, *vmsified, *cp;
a0d0e21e 8681
748a9306 8682 if (path == NULL) return NULL;
c5375c28
JM		 8683 pathified = PerlMem_malloc(VMS_MAXRSS);
8684 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
360732b5 8685 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
c5375c28 8686 PerlMem_free(pathified);
a480973c
JM		 8687 return NULL;
8688 }
c5375c28
JM		 8689
8690 vmsified = NULL;
8691 if (buf == NULL)
8692 Newx(vmsified, VMS_MAXRSS, char);
360732b5 8693 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
c5375c28
JM		 8694 PerlMem_free(pathified);
8695 if (vmsified) Safefree(vmsified);
a480973c
JM		 8696 return NULL;
8697 }
c5375c28 8698 PerlMem_free(pathified);
a480973c 8699 if (buf) {
a480973c
JM		 8700 return buf;
8701 }
a0d0e21e
LW		 8702 else if (ts) {
8703 vmslen = strlen(vmsified);
a02a5408 8704 Newx(cp,vmslen+1,char);
a0d0e21e
LW		 8705 memcpy(cp,vmsified,vmslen);
8706 cp[vmslen] = '\0';
a480973c 8707 Safefree(vmsified);
a0d0e21e
LW		 8708 return cp;
8709 }
8710 else {
8711 strcpy(__tovmspath_retbuf,vmsified);
a480973c 8712 Safefree(vmsified);
a0d0e21e
LW		 8713 return __tovmspath_retbuf;
8714 }
8715
8716} /* end of do_tovmspath() */
8717/*}}}*/
8718/* External entry points */
360732b5
JM		 8719char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8720 { return do_tovmspath(path,buf,0, NULL); }
8721char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8722 { return do_tovmspath(path,buf,1, NULL); }
8723char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8724 { return do_tovmspath(path,buf,0,utf8_fl); }
8725char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8726 { return do_tovmspath(path,buf,1,utf8_fl); }
8727
8728
8729/*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8730static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
a480973c 8731 static char __tounixpath_retbuf[VMS_MAXRSS];
a0d0e21e 8732 int unixlen;
a480973c 8733 char *pathified, *unixified, *cp;
a0d0e21e 8734
748a9306 8735 if (path == NULL) return NULL;
c5375c28
JM		 8736 pathified = PerlMem_malloc(VMS_MAXRSS);
8737 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
360732b5 8738 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
c5375c28 8739 PerlMem_free(pathified);
a480973c
JM		 8740 return NULL;
8741 }
c5375c28
JM		 8742
8743 unixified = NULL;
8744 if (buf == NULL) {
8745 Newx(unixified, VMS_MAXRSS, char);
8746 }
360732b5 8747 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
c5375c28
JM		 8748 PerlMem_free(pathified);
8749 if (unixified) Safefree(unixified);
a480973c
JM		 8750 return NULL;
8751 }
c5375c28 8752 PerlMem_free(pathified);
a480973c 8753 if (buf) {
a480973c
JM		 8754 return buf;
8755 }
a0d0e21e
LW		 8756 else if (ts) {
8757 unixlen = strlen(unixified);
a02a5408 8758 Newx(cp,unixlen+1,char);
a0d0e21e
LW		 8759 memcpy(cp,unixified,unixlen);
8760 cp[unixlen] = '\0';
a480973c 8761 Safefree(unixified);
a0d0e21e
LW		 8762 return cp;
8763 }
8764 else {
8765 strcpy(__tounixpath_retbuf,unixified);
a480973c 8766 Safefree(unixified);
a0d0e21e
LW		 8767 return __tounixpath_retbuf;
8768 }
8769
8770} /* end of do_tounixpath() */
8771/*}}}*/
8772/* External entry points */
360732b5
JM		 8773char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8774 { return do_tounixpath(path,buf,0,NULL); }
8775char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8776 { return do_tounixpath(path,buf,1,NULL); }
8777char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8778 { return do_tounixpath(path,buf,0,utf8_fl); }
8779char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8780 { return do_tounixpath(path,buf,1,utf8_fl); }
a0d0e21e
LW		 8781
8782/*
cbb8049c 8783 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
a0d0e21e
LW		 8784 *
8785 *****************************************************************************
8786 * *
cbb8049c 8787 * Copyright (C) 1989-1994, 2007 by *
a0d0e21e
LW		 8788 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
8789 * *
cbb8049c
MP		 8790 * Permission is hereby granted for the reproduction of this software *
8791 * on condition that this copyright notice is included in source *
8792 * distributions of the software. The code may be modified and *
8793 * distributed under the same terms as Perl itself. *
a0d0e21e
LW		 8794 * *
8795 * 27-Aug-1994 Modified for inclusion in perl5 *
cbb8049c 8796 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
a0d0e21e
LW		 8797 *****************************************************************************
8798 */
8799
8800/*
8801 * getredirection() is intended to aid in porting C programs
8802 * to VMS (Vax-11 C). The native VMS environment does not support
8803 * '>' and '<' I/O redirection, or command line wild card expansion,
8804 * or a command line pipe mechanism using the '|' AND background
8805 * command execution '&'. All of these capabilities are provided to any
8806 * C program which calls this procedure as the first thing in the
8807 * main program.
8808 * The piping mechanism will probably work with almost any 'filter' type
8809 * of program. With suitable modification, it may useful for other
8810 * portability problems as well.
8811 *
cbb8049c 8812 * Author: Mark Pizzolato (mark AT infocomm DOT com)
a0d0e21e
LW		 8813 */
8814struct list_item
8815 {
8816 struct list_item *next;
8817 char *value;
8818 };
8819
8820static void add_item(struct list_item **head,
8821 struct list_item **tail,
8822 char *value,
8823 int *count);
8824
4b19af01
CB		 8825static void mp_expand_wild_cards(pTHX_ char *item,
8826 struct list_item **head,
8827 struct list_item **tail,
8828 int *count);
a0d0e21e 8829
8df869cb 8830static int background_process(pTHX_ int argc, char **argv);
a0d0e21e 8831
fd8cd3a3 8832static void pipe_and_fork(pTHX_ char **cmargv);
a0d0e21e
LW		 8833
8834/*{{{ void getredirection(int *ac, char ***av)*/
84902520 8835static void
4b19af01 8836mp_getredirection(pTHX_ int *ac, char ***av)
a0d0e21e
LW		 8837/*
8838 * Process vms redirection arg's. Exit if any error is seen.
8839 * If getredirection() processes an argument, it is erased
8840 * from the vector. getredirection() returns a new argc and argv value.
8841 * In the event that a background command is requested (by a trailing "&"),
8842 * this routine creates a background subprocess, and simply exits the program.
8843 *
8844 * Warning: do not try to simplify the code for vms. The code
8845 * presupposes that getredirection() is called before any data is
8846 * read from stdin or written to stdout.
8847 *
8848 * Normal usage is as follows:
8849 *
8850 * main(argc, argv)
8851 * int argc;
8852 * char *argv[];
8853 * {
8854 * getredirection(&argc, &argv);
8855 * }
8856 */
8857{
8858 int argc = *ac; /* Argument Count */
8859 char **argv = *av; /* Argument Vector */
8860 char *ap; /* Argument pointer */
8861 int j; /* argv[] index */
8862 int item_count = 0; /* Count of Items in List */
8863 struct list_item *list_head = 0; /* First Item in List */
8864 struct list_item *list_tail; /* Last Item in List */
8865 char *in = NULL; /* Input File Name */
8866 char *out = NULL; /* Output File Name */
8867 char *outmode = "w"; /* Mode to Open Output File */
8868 char *err = NULL; /* Error File Name */
8869 char *errmode = "w"; /* Mode to Open Error File */
8870 int cmargc = 0; /* Piped Command Arg Count */
8871 char **cmargv = NULL;/* Piped Command Arg Vector */
a0d0e21e
LW		 8872
8873 /*
8874 * First handle the case where the last thing on the line ends with
8875 * a '&'. This indicates the desire for the command to be run in a
8876 * subprocess, so we satisfy that desire.
8877 */
8878 ap = argv[argc-1];
8879 if (0 == strcmp("&", ap))
8c3eed29 8880 exit(background_process(aTHX_ --argc, argv));
e518068a 8881 if (*ap && '&' == ap[strlen(ap)-1])
a0d0e21e
LW		 8882 {
8883 ap[strlen(ap)-1] = '\0';
8c3eed29 8884 exit(background_process(aTHX_ argc, argv));
a0d0e21e
LW		 8885 }
8886 /*
8887 * Now we handle the general redirection cases that involve '>', '>>',
8888 * '<', and pipes '|'.
8889 */
8890 for (j = 0; j < argc; ++j)
8891 {
8892 if (0 == strcmp("<", argv[j]))
8893 {
8894 if (j+1 >= argc)
8895 {
fd71b04b 8896 fprintf(stderr,"No input file after < on command line");
748a9306 8897 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8898 }
8899 in = argv[++j];
8900 continue;
8901 }
8902 if ('<' == *(ap = argv[j]))
8903 {
8904 in = 1 + ap;
8905 continue;
8906 }
8907 if (0 == strcmp(">", ap))
8908 {
8909 if (j+1 >= argc)
8910 {
fd71b04b 8911 fprintf(stderr,"No output file after > on command line");
748a9306 8912 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8913 }
8914 out = argv[++j];
8915 continue;
8916 }
8917 if ('>' == *ap)
8918 {
8919 if ('>' == ap[1])
8920 {
8921 outmode = "a";
8922 if ('\0' == ap[2])
8923 out = argv[++j];
8924 else
8925 out = 2 + ap;
8926 }
8927 else
8928 out = 1 + ap;
8929 if (j >= argc)
8930 {
fd71b04b 8931 fprintf(stderr,"No output file after > or >> on command line");
748a9306 8932 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8933 }
8934 continue;
8935 }
8936 if (('2' == *ap) && ('>' == ap[1]))
8937 {
8938 if ('>' == ap[2])
8939 {
8940 errmode = "a";
8941 if ('\0' == ap[3])
8942 err = argv[++j];
8943 else
8944 err = 3 + ap;
8945 }
8946 else
8947 if ('\0' == ap[2])
8948 err = argv[++j];
8949 else
748a9306 8950 err = 2 + ap;
a0d0e21e
LW		 8951 if (j >= argc)
8952 {
fd71b04b 8953 fprintf(stderr,"No output file after 2> or 2>> on command line");
748a9306 8954 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8955 }
8956 continue;
8957 }
8958 if (0 == strcmp("|", argv[j]))
8959 {
8960 if (j+1 >= argc)
8961 {
fd71b04b 8962 fprintf(stderr,"No command into which to pipe on command line");
748a9306 8963 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8964 }
8965 cmargc = argc-(j+1);
8966 cmargv = &argv[j+1];
8967 argc = j;
8968 continue;
8969 }
8970 if ('|' == *(ap = argv[j]))
8971 {
8972 ++argv[j];
8973 cmargc = argc-j;
8974 cmargv = &argv[j];
8975 argc = j;
8976 continue;
8977 }
8978 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8979 }
8980 /*
8981 * Allocate and fill in the new argument vector, Some Unix's terminate
8982 * the list with an extra null pointer.
8983 */
e0ef6b43 8984 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
c5375c28 8985 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 8986 *av = argv;
8987 for (j = 0; j < item_count; ++j, list_head = list_head->next)
8988 argv[j] = list_head->value;
8989 *ac = item_count;
8990 if (cmargv != NULL)
8991 {
8992 if (out != NULL)
8993 {
fd71b04b 8994 fprintf(stderr,"'|' and '>' may not both be specified on command line");
748a9306 8995 exit(LIB$_INVARGORD);
a0d0e21e 8996 }
fd8cd3a3 8997 pipe_and_fork(aTHX_ cmargv);
a0d0e21e
LW		 8998 }
8999
9000 /* Check for input from a pipe (mailbox) */
9001
a5f75d66 9002 if (in == NULL && 1 == isapipe(0))
a0d0e21e
LW		 9003 {
9004 char mbxname[L_tmpnam];
9005 long int bufsize;
9006 long int dvi_item = DVI$_DEVBUFSIZ;
9007 $DESCRIPTOR(mbxnam, "");
9008 $DESCRIPTOR(mbxdevnam, "");
9009
9010 /* Input from a pipe, reopen it in binary mode to disable */
9011 /* carriage control processing. */
9012
fd71b04b 9013 fgetname(stdin, mbxname);
a0d0e21e
LW		 9014 mbxnam.dsc$a_pointer = mbxname;
9015 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9016 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9017 mbxdevnam.dsc$a_pointer = mbxname;
9018 mbxdevnam.dsc$w_length = sizeof(mbxname);
9019 dvi_item = DVI$_DEVNAM;
9020 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9021 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
748a9306
LW		 9022 set_errno(0);
9023 set_vaxc_errno(1);
a0d0e21e
LW		 9024 freopen(mbxname, "rb", stdin);
9025 if (errno != 0)
9026 {
fd71b04b 9027 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
748a9306 9028 exit(vaxc$errno);
a0d0e21e
LW		 9029 }
9030 }
9031 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9032 {
fd71b04b 9033 fprintf(stderr,"Can't open input file %s as stdin",in);
748a9306 9034 exit(vaxc$errno);
a0d0e21e
LW		 9035 }
9036 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9037 {
fd71b04b 9038 fprintf(stderr,"Can't open output file %s as stdout",out);
748a9306 9039 exit(vaxc$errno);
a0d0e21e 9040 }
fd8cd3a3 9041 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
0e06870b 9042
748a9306 9043 if (err != NULL) {
71d7ec5d 9044 if (strcmp(err,"&1") == 0) {
a15cef0c 9045 dup2(fileno(stdout), fileno(stderr));
fd8cd3a3 9046 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
71d7ec5d 9047 } else {
748a9306
LW		 9048 FILE *tmperr;
9049 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9050 {
fd71b04b 9051 fprintf(stderr,"Can't open error file %s as stderr",err);
748a9306
LW		 9052 exit(vaxc$errno);
9053 }
9054 fclose(tmperr);
a15cef0c 9055 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
748a9306
LW		 9056 {
9057 exit(vaxc$errno);
9058 }
fd8cd3a3 9059 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
a0d0e21e 9060 }
71d7ec5d 9061 }
a0d0e21e 9062#ifdef ARGPROC_DEBUG
740ce14c 9063 PerlIO_printf(Perl_debug_log, "Arglist:\n");
a0d0e21e 9064 for (j = 0; j < *ac; ++j)
740ce14c 9065 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
a0d0e21e 9066#endif
b7ae7a0d 9067 /* Clear errors we may have hit expanding wildcards, so they don't
9068 show up in Perl's $! later */
9069 set_errno(0); set_vaxc_errno(1);
a0d0e21e
LW		 9070} /* end of getredirection() */
9071/*}}}*/
9072
9073static void add_item(struct list_item **head,
9074 struct list_item **tail,
9075 char *value,
9076 int *count)
9077{
9078 if (*head == 0)
9079 {
e0ef6b43 9080 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 9081 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9082 *tail = *head;
9083 }
9084 else {
e0ef6b43 9085 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 9086 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9087 *tail = (*tail)->next;
9088 }
9089 (*tail)->value = value;
9090 ++(*count);
9091}
9092
4b19af01 9093static void mp_expand_wild_cards(pTHX_ char *item,
a0d0e21e
LW		 9094 struct list_item **head,
9095 struct list_item **tail,
9096 int *count)
9097{
9098int expcount = 0;
748a9306 9099unsigned long int context = 0;
a0d0e21e 9100int isunix = 0;
773da73d 9101int item_len = 0;
a0d0e21e
LW		 9102char *had_version;
9103char *had_device;
9104int had_directory;
f675dbe5 9105char *devdir,*cp;
a480973c 9106char *vmsspec;
a0d0e21e 9107$DESCRIPTOR(filespec, "");
748a9306 9108$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
a0d0e21e 9109$DESCRIPTOR(resultspec, "");
a480973c
JM		 9110unsigned long int lff_flags = 0;
9111int sts;
dca5a913 9112int rms_sts;
a480973c
JM		 9113
9114#ifdef VMS_LONGNAME_SUPPORT
9115 lff_flags = LIB$M_FIL_LONG_NAMES;
9116#endif
a0d0e21e 9117
f675dbe5
CB		 9118 for (cp = item; *cp; cp++) {
9119 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9120 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9121 }
9122 if (!*cp || isspace(*cp))
a0d0e21e
LW		 9123 {
9124 add_item(head, tail, item, count);
9125 return;
9126 }
773da73d
JH		 9127 else
9128 {
9129 /* "double quoted" wild card expressions pass as is */
9130 /* From DCL that means using e.g.: */
9131 /* perl program """perl.*""" */
9132 item_len = strlen(item);
9133 if ( '"' == *item && '"' == item[item_len-1] )
9134 {
9135 item++;
9136 item[item_len-2] = '\0';
9137 add_item(head, tail, item, count);
9138 return;
9139 }
9140 }
a0d0e21e
LW		 9141 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9142 resultspec.dsc$b_class = DSC$K_CLASS_D;
9143 resultspec.dsc$a_pointer = NULL;
c5375c28
JM		 9144 vmsspec = PerlMem_malloc(VMS_MAXRSS);
9145 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
748a9306 9146 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
df278665 9147 filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
a0d0e21e
LW		 9148 if (!isunix || !filespec.dsc$a_pointer)
9149 filespec.dsc$a_pointer = item;
9150 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9151 /*
9152 * Only return version specs, if the caller specified a version
9153 */
9154 had_version = strchr(item, ';');
9155 /*
9156 * Only return device and directory specs, if the caller specifed either.
9157 */
9158 had_device = strchr(item, ':');
9159 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9160
a480973c
JM		 9161 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9162 (&filespec, &resultspec, &context,
dca5a913 9163 &defaultspec, 0, &rms_sts, &lff_flags)))
a0d0e21e
LW		 9164 {
9165 char *string;
9166 char *c;
9167
c5375c28
JM		 9168 string = PerlMem_malloc(resultspec.dsc$w_length+1);
9169 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9170 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9171 string[resultspec.dsc$w_length] = '\0';
9172 if (NULL == had_version)
f7ddb74a 9173 *(strrchr(string, ';')) = '\0';
a0d0e21e
LW		 9174 if ((!had_directory) && (had_device == NULL))
9175 {
9176 if (NULL == (devdir = strrchr(string, ']')))
9177 devdir = strrchr(string, '>');
9178 strcpy(string, devdir + 1);
9179 }
9180 /*
9181 * Be consistent with what the C RTL has already done to the rest of
9182 * the argv items and lowercase all of these names.
9183 */
f7ddb74a
JM		 9184 if (!decc_efs_case_preserve) {
9185 for (c = string; *c; ++c)
a0d0e21e
LW		 9186 if (isupper(*c))
9187 *c = tolower(*c);
f7ddb74a 9188 }
f86702cc 9189 if (isunix) trim_unixpath(string,item,1);
a0d0e21e
LW		 9190 add_item(head, tail, string, count);
9191 ++expcount;
a480973c 9192 }
367e4b85 9193 PerlMem_free(vmsspec);
c07a80fd 9194 if (sts != RMS$_NMF)
9195 {
9196 set_vaxc_errno(sts);
9197 switch (sts)
9198 {
f282b18d 9199 case RMS$_FNF: case RMS$_DNF:
c07a80fd 9200 set_errno(ENOENT); break;
f282b18d
CB		 9201 case RMS$_DIR:
9202 set_errno(ENOTDIR); break;
c07a80fd 9203 case RMS$_DEV:
9204 set_errno(ENODEV); break;
f282b18d 9205 case RMS$_FNM: case RMS$_SYN:
c07a80fd 9206 set_errno(EINVAL); break;
9207 case RMS$_PRV:
9208 set_errno(EACCES); break;
9209 default:
b7ae7a0d 9210 _ckvmssts_noperl(sts);
c07a80fd 9211 }
9212 }
a0d0e21e
LW		 9213 if (expcount == 0)
9214 add_item(head, tail, item, count);
b7ae7a0d 9215 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9216 _ckvmssts_noperl(lib$find_file_end(&context));
a0d0e21e
LW		 9217}
9218
9219static int child_st[2];/* Event Flag set when child process completes */
9220
748a9306 9221static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
a0d0e21e 9222
748a9306 9223static unsigned long int exit_handler(int *status)
a0d0e21e
LW		 9224{
9225short iosb[4];
9226
9227 if (0 == child_st[0])
9228 {
9229#ifdef ARGPROC_DEBUG
740ce14c 9230 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
a0d0e21e
LW		 9231#endif
9232 fflush(stdout); /* Have to flush pipe for binary data to */
9233 /* terminate properly -- <tp@mccall.com> */
9234 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9235 sys$dassgn(child_chan);
9236 fclose(stdout);
9237 sys$synch(0, child_st);
9238 }
9239 return(1);
9240}
9241
9242static void sig_child(int chan)
9243{
9244#ifdef ARGPROC_DEBUG
740ce14c 9245 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
a0d0e21e
LW		 9246#endif
9247 if (child_st[0] == 0)
9248 child_st[0] = 1;
9249}
9250
748a9306 9251static struct exit_control_block exit_block =
a0d0e21e
LW		 9252 {
9253 0,
9254 exit_handler,
9255 1,
9256 &exit_block.exit_status,
9257 0
9258 };
9259
ff7adb52
CL		 9260static void
9261pipe_and_fork(pTHX_ char **cmargv)
a0d0e21e 9262{
ff7adb52 9263 PerlIO *fp;
218fdd94 9264 struct dsc$descriptor_s *vmscmd;
ff7adb52
CL		 9265 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9266 int sts, j, l, ismcr, quote, tquote = 0;
9267
218fdd94
CL		 9268 sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9269 vms_execfree(vmscmd);
ff7adb52
CL		 9270
9271 j = l = 0;
9272 p = subcmd;
9273 q = cmargv[0];
9274 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
9275 && toupper(*(q+2)) == 'R' && !*(q+3);
9276
9277 while (q && l < MAX_DCL_LINE_LENGTH) {
9278 if (!*q) {
9279 if (j > 0 && quote) {
9280 *p++ = '"';
9281 l++;
9282 }
9283 q = cmargv[++j];
9284 if (q) {
9285 if (ismcr && j > 1) quote = 1;
9286 tquote = (strchr(q,' ')) != NULL || *q == '\0';
9287 *p++ = ' ';
9288 l++;
9289 if (quote || tquote) {
9290 *p++ = '"';
9291 l++;
9292 }
988c775c 9293 }
ff7adb52
CL		 9294 } else {
9295 if ((quote||tquote) && *q == '"') {
9296 *p++ = '"';
9297 l++;
988c775c 9298 }
ff7adb52
CL		 9299 *p++ = *q++;
9300 l++;
9301 }
9302 }
9303 *p = '\0';
a0d0e21e 9304
218fdd94 9305 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4e205ed6 9306 if (fp == NULL) {
ff7adb52 9307 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
988c775c 9308 }
a0d0e21e
LW		 9309}
9310
8df869cb 9311static int background_process(pTHX_ int argc, char **argv)
a0d0e21e 9312{
a480973c 9313char command[MAX_DCL_SYMBOL + 1] = "$";
a0d0e21e
LW		 9314$DESCRIPTOR(value, "");
9315static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9316static $DESCRIPTOR(null, "NLA0:");
9317static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9318char pidstring[80];
9319$DESCRIPTOR(pidstr, "");
9320int pid;
748a9306 9321unsigned long int flags = 17, one = 1, retsts;
a480973c 9322int len;
a0d0e21e
LW		 9323
9324 strcat(command, argv[0]);
a480973c
JM		 9325 len = strlen(command);
9326 while (--argc && (len < MAX_DCL_SYMBOL))
a0d0e21e
LW		 9327 {
9328 strcat(command, " \"");
9329 strcat(command, *(++argv));
9330 strcat(command, "\"");
a480973c 9331 len = strlen(command);
a0d0e21e
LW		 9332 }
9333 value.dsc$a_pointer = command;
9334 value.dsc$w_length = strlen(value.dsc$a_pointer);
b7ae7a0d 9335 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
748a9306
LW		 9336 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9337 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
b7ae7a0d 9338 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
748a9306
LW		 9339 }
9340 else {
b7ae7a0d 9341 _ckvmssts_noperl(retsts);
748a9306 9342 }
a0d0e21e 9343#ifdef ARGPROC_DEBUG
740ce14c 9344 PerlIO_printf(Perl_debug_log, "%s\n", command);
a0d0e21e
LW		 9345#endif
9346 sprintf(pidstring, "%08X", pid);
740ce14c 9347 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
a0d0e21e
LW		 9348 pidstr.dsc$a_pointer = pidstring;
9349 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9350 lib$set_symbol(&pidsymbol, &pidstr);
9351 return(SS$_NORMAL);
9352}
9353/*}}}*/
9354/***** End of code taken from Mark Pizzolato's argproc.c package *****/
9355
84902520
TB		 9356
9357/* OS-specific initialization at image activation (not thread startup) */
61bb5906
CB		 9358/* Older VAXC header files lack these constants */
9359#ifndef JPI$_RIGHTS_SIZE
9360# define JPI$_RIGHTS_SIZE 817
9361#endif
9362#ifndef KGB$M_SUBSYSTEM
9363# define KGB$M_SUBSYSTEM 0x8
9364#endif
a480973c 9365
e0ef6b43
CB		 9366/* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9367
84902520
TB		 9368/*{{{void vms_image_init(int *, char ***)*/
9369void
9370vms_image_init(int *argcp, char ***argvp)
9371{
b53f3677
JM		 9372 int status;
9373 char val_str[10];
f675dbe5
CB		 9374 char eqv[LNM$C_NAMLENGTH+1] = "";
9375 unsigned int len, tabct = 8, tabidx = 0;
9376 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
61bb5906
CB		 9377 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9378 unsigned short int dummy, rlen;
f675dbe5 9379 struct dsc$descriptor_s **tabvec;
fd8cd3a3
DS		 9380#if defined(PERL_IMPLICIT_CONTEXT)
9381 pTHX = NULL;
9382#endif
61bb5906
CB		 9383 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
9384 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
9385 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9386 { 0, 0, 0, 0} };
84902520 9387
2e34cc90 9388#ifdef KILL_BY_SIGPRC
f7ddb74a 9389 Perl_csighandler_init();
2e34cc90
CL		 9390#endif
9391
b53f3677
JM		 9392 /* This was moved from the pre-image init handler because on threaded */
9393 /* Perl it was always returning 0 for the default value. */
9394 status = simple_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
9395 if (status > 0) {
9396 int s;
9397 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9398 if (s > 0) {
9399 int initial;
9400 initial = decc$feature_get_value(s, 4);
9401 if (initial >= 0) {
9402 /* initial is -1 if nothing has set the feature */
9403 /* initial is 1 if the logical name is present */
9404 decc_disable_posix_root = decc$feature_get_value(s, 1);
9405
9406 /* If the value is not valid, force the feature off */
9407 if (decc_disable_posix_root < 0) {
9408 decc$feature_set_value(s, 1, 1);
9409 decc_disable_posix_root = 1;
9410 }
9411 }
9412 else {
9413 /* Traditionally Perl assumes this is off */
9414 decc_disable_posix_root = 1;
9415 decc$feature_set_value(s, 1, 1);
9416 }
9417 }
9418 }
9419
9420
fd8cd3a3
DS		 9421 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9422 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 9423 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9424 if (iprv[i]) { /* Running image installed with privs? */
fd8cd3a3 9425 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
f675dbe5 9426 will_taint = TRUE;
84902520
TB		 9427 break;
9428 }
9429 }
61bb5906 9430 /* Rights identifiers might trigger tainting as well. */
f675dbe5 9431 if (!will_taint && (rlen || rsz)) {
61bb5906
CB		 9432 while (rlen < rsz) {
9433 /* We didn't get all the identifiers on the first pass. Allocate a
9434 * buffer much larger than $GETJPI wants (rsz is size in bytes that
9435 * were needed to hold all identifiers at time of last call; we'll
9436 * allocate that many unsigned long ints), and go back and get 'em.
22d4bb9c
CB		 9437 * If it gave us less than it wanted to despite ample buffer space,
9438 * something's broken. Is your system missing a system identifier?
61bb5906 9439 */
22d4bb9c
CB		 9440 if (rsz <= jpilist[1].buflen) {
9441 /* Perl_croak accvios when used this early in startup. */
9442 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9443 rsz, (unsigned long) jpilist[1].buflen,
9444 "Check your rights database for corruption.\n");
9445 exit(SS$_ABORT);
9446 }
e0ef6b43
CB		 9447 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9448 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
c5375c28 9449 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
61bb5906 9450 jpilist[1].buflen = rsz * sizeof(unsigned long int);
fd8cd3a3
DS		 9451 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9452 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 9453 }
9454 mask = jpilist[1].bufadr;
9455 /* Check attribute flags for each identifier (2nd longword); protected
9456 * subsystem identifiers trigger tainting.
9457 */
9458 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9459 if (mask[i] & KGB$M_SUBSYSTEM) {
f675dbe5 9460 will_taint = TRUE;
61bb5906
CB		 9461 break;
9462 }
9463 }
367e4b85 9464 if (mask != rlst) PerlMem_free(mask);
61bb5906 9465 }
f7ddb74a
JM		 9466
9467 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9468 * logical, some versions of the CRTL will add a phanthom /000000/
9469 * directory. This needs to be removed.
9470 */
9471 if (decc_filename_unix_report) {
9472 char * zeros;
9473 int ulen;
9474 ulen = strlen(argvp[0][0]);
9475 if (ulen > 7) {
9476 zeros = strstr(argvp[0][0], "/000000/");
9477 if (zeros != NULL) {
9478 int mlen;
9479 mlen = ulen - (zeros - argvp[0][0]) - 7;
9480 memmove(zeros, &zeros[7], mlen);
9481 ulen = ulen - 7;
9482 argvp[0][0][ulen] = '\0';
9483 }
9484 }
9485 /* It also may have a trailing dot that needs to be removed otherwise
9486 * it will be converted to VMS mode incorrectly.
9487 */
9488 ulen--;
9489 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9490 argvp[0][0][ulen] = '\0';
9491 }
9492
61bb5906 9493 /* We need to use this hack to tell Perl it should run with tainting,
6b88bc9c 9494 * since its tainting flag may be part of the PL_curinterp struct, which
61bb5906
CB		 9495 * hasn't been allocated when vms_image_init() is called.
9496 */
f675dbe5 9497 if (will_taint) {
ec618cdf
CB		 9498 char **newargv, **oldargv;
9499 oldargv = *argvp;
e0ef6b43 9500 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
c5375c28 9501 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf 9502 newargv[0] = oldargv[0];
c5375c28
JM		 9503 newargv[1] = PerlMem_malloc(3 * sizeof(char));
9504 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf
CB		 9505 strcpy(newargv[1], "-T");
9506 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9507 (*argcp)++;
9508 newargv[*argcp] = NULL;
61bb5906
CB		 9509 /* We orphan the old argv, since we don't know where it's come from,
9510 * so we don't know how to free it.
9511 */
ec618cdf 9512 *argvp = newargv;
61bb5906 9513 }
f675dbe5
CB		 9514 else { /* Did user explicitly request tainting? */
9515 int i;
9516 char *cp, **av = *argvp;
9517 for (i = 1; i < *argcp; i++) {
9518 if (*av[i] != '-') break;
9519 for (cp = av[i]+1; *cp; cp++) {
9520 if (*cp == 'T') { will_taint = 1; break; }
9521 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9522 strchr("DFIiMmx",*cp)) break;
9523 }
9524 if (will_taint) break;
9525 }
9526 }
9527
9528 for (tabidx = 0;
9529 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9530 tabidx++) {
c5375c28
JM		 9531 if (!tabidx) {
9532 tabvec = (struct dsc$descriptor_s **)
9533 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9534 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9535 }
f675dbe5
CB		 9536 else if (tabidx >= tabct) {
9537 tabct += 8;
e0ef6b43 9538 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
c5375c28 9539 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f675dbe5 9540 }
e0ef6b43 9541 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
c5375c28 9542 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f675dbe5
CB		 9543 tabvec[tabidx]->dsc$w_length = 0;
9544 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9545 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9546 tabvec[tabidx]->dsc$a_pointer = NULL;
fd8cd3a3 9547 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
f675dbe5
CB		 9548 }
9549 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9550
84902520 9551 getredirection(argcp,argvp);
3bc25146
CB		 9552#if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9553 {
9554# include <reentrancy.h>
f7ddb74a 9555 decc$set_reentrancy(C$C_MULTITHREAD);
3bc25146
CB		 9556 }
9557#endif
84902520
TB		 9558 return;
9559}
9560/*}}}*/
9561
9562
a0d0e21e
LW		 9563/* trim_unixpath()
9564 * Trim Unix-style prefix off filespec, so it looks like what a shell
9565 * glob expansion would return (i.e. from specified prefix on, not
9566 * full path). Note that returned filespec is Unix-style, regardless
9567 * of whether input filespec was VMS-style or Unix-style.
9568 *
a3e9d8c9 9569 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
f86702cc 9570 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9571 * vector of options; at present, only bit 0 is used, and if set tells
9572 * trim unixpath to try the current default directory as a prefix when
9573 * presented with a possibly ambiguous ... wildcard.
a3e9d8c9 9574 *
9575 * Returns !=0 on success, with trimmed filespec replacing contents of
9576 * fspec, and 0 on failure, with contents of fpsec unchanged.
a0d0e21e 9577 */
f86702cc 9578/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
a0d0e21e 9579int
2fbb330f 9580Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
a0d0e21e 9581{
a480973c 9582 char *unixified, *unixwild,
f86702cc 9583 *template, *base, *end, *cp1, *cp2;
9584 register int tmplen, reslen = 0, dirs = 0;
a0d0e21e 9585
a3e9d8c9 9586 if (!wildspec || !fspec) return 0;
ebd4d70b
JM		 9587
9588 unixwild = PerlMem_malloc(VMS_MAXRSS);
9589 if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2fbb330f 9590 template = unixwild;
a3e9d8c9 9591 if (strpbrk(wildspec,"]>:") != NULL) {
0e5ce2c7 9592 if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
367e4b85 9593 PerlMem_free(unixwild);
a480973c
JM		 9594 return 0;
9595 }
a3e9d8c9 9596 }
2fbb330f 9597 else {
a480973c
JM		 9598 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9599 unixwild[VMS_MAXRSS-1] = 0;
2fbb330f 9600 }
c5375c28 9601 unixified = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9602 if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e 9603 if (strpbrk(fspec,"]>:") != NULL) {
0e5ce2c7 9604 if (int_tounixspec(fspec, unixified, NULL) == NULL) {
367e4b85
JM		 9605 PerlMem_free(unixwild);
9606 PerlMem_free(unixified);
a480973c
JM		 9607 return 0;
9608 }
a0d0e21e 9609 else base = unixified;
a3e9d8c9 9610 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9611 * check to see that final result fits into (isn't longer than) fspec */
9612 reslen = strlen(fspec);
a0d0e21e
LW		 9613 }
9614 else base = fspec;
a3e9d8c9 9615
9616 /* No prefix or absolute path on wildcard, so nothing to remove */
9617 if (!*template || *template == '/') {
367e4b85 9618 PerlMem_free(unixwild);
a480973c 9619 if (base == fspec) {
367e4b85 9620 PerlMem_free(unixified);
a480973c
JM		 9621 return 1;
9622 }
a3e9d8c9 9623 tmplen = strlen(unixified);
a480973c 9624 if (tmplen > reslen) {
367e4b85 9625 PerlMem_free(unixified);
a480973c
JM		 9626 return 0; /* not enough space */
9627 }
a3e9d8c9 9628 /* Copy unixified resultant, including trailing NUL */
9629 memmove(fspec,unixified,tmplen+1);
367e4b85 9630 PerlMem_free(unixified);
a3e9d8c9 9631 return 1;
9632 }
a0d0e21e 9633
f86702cc 9634 for (end = base; *end; end++) ; /* Find end of resultant filespec */
9635 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9636 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9637 for (cp1 = end ;cp1 >= base; cp1--)
9638 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9639 { cp1++; break; }
9640 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
367e4b85
JM		 9641 PerlMem_free(unixified);
9642 PerlMem_free(unixwild);
a3e9d8c9 9643 return 1;
9644 }
f86702cc 9645 else {
a480973c 9646 char *tpl, *lcres;
f86702cc 9647 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9648 int ells = 1, totells, segdirs, match;
a480973c 9649 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
f86702cc 9650 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9651
9652 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9653 totells = ells;
9654 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
367e4b85 9655 tpl = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9656 if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f86702cc 9657 if (ellipsis == template && opts & 1) {
9658 /* Template begins with an ellipsis. Since we can't tell how many
9659 * directory names at the front of the resultant to keep for an
9660 * arbitrary starting point, we arbitrarily choose the current
9661 * default directory as a starting point. If it's there as a prefix,
9662 * clip it off. If not, fall through and act as if the leading
9663 * ellipsis weren't there (i.e. return shortest possible path that
9664 * could match template).
9665 */
a480973c 9666 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
367e4b85
JM		 9667 PerlMem_free(tpl);
9668 PerlMem_free(unixified);
9669 PerlMem_free(unixwild);
a480973c
JM		 9670 return 0;
9671 }
f7ddb74a
JM		 9672 if (!decc_efs_case_preserve) {
9673 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9674 if (_tolower(*cp1) != _tolower(*cp2)) break;
9675 }
f86702cc 9676 segdirs = dirs - totells; /* Min # of dirs we must have left */
9677 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9678 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
18a3d61e 9679 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 9680 PerlMem_free(tpl);
9681 PerlMem_free(unixified);
9682 PerlMem_free(unixwild);
f86702cc 9683 return 1;
a3e9d8c9 9684 }
a3e9d8c9 9685 }
f86702cc 9686 /* First off, back up over constant elements at end of path */
9687 if (dirs) {
9688 for (front = end ; front >= base; front--)
9689 if (*front == '/' && !dirs--) { front++; break; }
a3e9d8c9 9690 }
c5375c28 9691 lcres = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9692 if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c
JM		 9693 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9694 cp1++,cp2++) {
9695 if (!decc_efs_case_preserve) {
9696 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9697 }
9698 else {
9699 *cp2 = *cp1;
9700 }
9701 }
9702 if (cp1 != '\0') {
367e4b85
JM		 9703 PerlMem_free(tpl);
9704 PerlMem_free(unixified);
9705 PerlMem_free(unixwild);
c5375c28 9706 PerlMem_free(lcres);
a480973c 9707 return 0; /* Path too long. */
f7ddb74a 9708 }
f86702cc 9709 lcend = cp2;
9710 *cp2 = '\0'; /* Pick up with memcpy later */
9711 lcfront = lcres + (front - base);
9712 /* Now skip over each ellipsis and try to match the path in front of it. */
9713 while (ells--) {
9714 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9715 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9716 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
9717 if (cp1 < template) break; /* template started with an ellipsis */
9718 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9719 ellipsis = cp1; continue;
9720 }
a480973c 9721 wilddsc.dsc$a_pointer = tpl;
f86702cc 9722 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9723 nextell = cp1;
9724 for (segdirs = 0, cp2 = tpl;
a480973c 9725 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
f86702cc 9726 cp1++, cp2++) {
9727 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
f7ddb74a
JM		 9728 else {
9729 if (!decc_efs_case_preserve) {
9730 *cp2 = _tolower(*cp1); /* else lowercase for match */
9731 }
9732 else {
9733 *cp2 = *cp1; /* else preserve case for match */
9734 }
9735 }
f86702cc 9736 if (*cp2 == '/') segdirs++;
9737 }
a480973c 9738 if (cp1 != ellipsis - 1) {
367e4b85
JM		 9739 PerlMem_free(tpl);
9740 PerlMem_free(unixified);
9741 PerlMem_free(unixwild);
9742 PerlMem_free(lcres);
a480973c
JM		 9743 return 0; /* Path too long */
9744 }
f86702cc 9745 /* Back up at least as many dirs as in template before matching */
9746 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9747 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9748 for (match = 0; cp1 > lcres;) {
9749 resdsc.dsc$a_pointer = cp1;
9750 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9751 match++;
9752 if (match == 1) lcfront = cp1;
9753 }
9754 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9755 }
a480973c 9756 if (!match) {
367e4b85
JM		 9757 PerlMem_free(tpl);
9758 PerlMem_free(unixified);
9759 PerlMem_free(unixwild);
9760 PerlMem_free(lcres);
a480973c
JM		 9761 return 0; /* Can't find prefix ??? */
9762 }
f86702cc 9763 if (match > 1 && opts & 1) {
9764 /* This ... wildcard could cover more than one set of dirs (i.e.
9765 * a set of similar dir names is repeated). If the template
9766 * contains more than 1 ..., upstream elements could resolve the
9767 * ambiguity, but it's not worth a full backtracking setup here.
9768 * As a quick heuristic, clip off the current default directory
9769 * if it's present to find the trimmed spec, else use the
9770 * shortest string that this ... could cover.
9771 */
9772 char def[NAM$C_MAXRSS+1], *st;
9773
a480973c 9774 if (getcwd(def, sizeof def,0) == NULL) {
827f156d
JM		 9775 PerlMem_free(unixified);
9776 PerlMem_free(unixwild);
9777 PerlMem_free(lcres);
9778 PerlMem_free(tpl);
a480973c
JM		 9779 return 0;
9780 }
f7ddb74a
JM		 9781 if (!decc_efs_case_preserve) {
9782 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9783 if (_tolower(*cp1) != _tolower(*cp2)) break;
9784 }
f86702cc 9785 segdirs = dirs - totells; /* Min # of dirs we must have left */
9786 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9787 if (*cp1 == '\0' && *cp2 == '/') {
18a3d61e 9788 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 9789 PerlMem_free(tpl);
9790 PerlMem_free(unixified);
9791 PerlMem_free(unixwild);
9792 PerlMem_free(lcres);
f86702cc 9793 return 1;
9794 }
9795 /* Nope -- stick with lcfront from above and keep going. */
9796 }
9797 }
18a3d61e 9798 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
367e4b85
JM		 9799 PerlMem_free(tpl);
9800 PerlMem_free(unixified);
9801 PerlMem_free(unixwild);
9802 PerlMem_free(lcres);
a3e9d8c9 9803 return 1;
f86702cc 9804 ellipsis = nextell;
a0d0e21e 9805 }
a0d0e21e
LW		 9806
9807} /* end of trim_unixpath() */
9808/*}}}*/
9809
a0d0e21e
LW		 9810
9811/*
9812 * VMS readdir() routines.
9813 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
a0d0e21e 9814 *
bd3fa61c 9815 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
a0d0e21e
LW		 9816 * Minor modifications to original routines.
9817 */
9818
a9852f7c
CB		 9819/* readdir may have been redefined by reentr.h, so make sure we get
9820 * the local version for what we do here.
9821 */
9822#ifdef readdir
9823# undef readdir
9824#endif
9825#if !defined(PERL_IMPLICIT_CONTEXT)
9826# define readdir Perl_readdir
9827#else
9828# define readdir(a) Perl_readdir(aTHX_ a)
9829#endif
9830
a0d0e21e
LW		 9831 /* Number of elements in vms_versions array */
9832#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
9833
9834/*
9835 * Open a directory, return a handle for later use.
9836 */
9837/*{{{ DIR *opendir(char*name) */
ddcbaa1c 9838DIR *
b8ffc8df 9839Perl_opendir(pTHX_ const char *name)
a0d0e21e 9840{
ddcbaa1c 9841 DIR *dd;
657054d4 9842 char *dir;
61bb5906 9843 Stat_t sb;
657054d4
JM		 9844
9845 Newx(dir, VMS_MAXRSS, char);
360732b5 9846 if (do_tovmspath(name,dir,0,NULL) == NULL) {
657054d4 9847 Safefree(dir);
61bb5906 9848 return NULL;
a0d0e21e 9849 }
ada67d10
CB		 9850 /* Check access before stat; otherwise stat does not
9851 * accurately report whether it's a directory.
9852 */
a1887106 9853 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
fac786e7 9854 /* cando_by_name has already set errno */
657054d4 9855 Safefree(dir);
ada67d10
CB		 9856 return NULL;
9857 }
61bb5906
CB		 9858 if (flex_stat(dir,&sb) == -1) return NULL;
9859 if (!S_ISDIR(sb.st_mode)) {
657054d4 9860 Safefree(dir);
61bb5906
CB		 9861 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
9862 return NULL;
9863 }
61bb5906 9864 /* Get memory for the handle, and the pattern. */
ddcbaa1c 9865 Newx(dd,1,DIR);
a02a5408 9866 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
a0d0e21e
LW		 9867
9868 /* Fill in the fields; mainly playing with the descriptor. */
f7ddb74a 9869 sprintf(dd->pattern, "%s*.*",dir);
657054d4 9870 Safefree(dir);
a0d0e21e
LW		 9871 dd->context = 0;
9872 dd->count = 0;
657054d4 9873 dd->flags = 0;
a096370a
CB		 9874 /* By saying we always want the result of readdir() in unix format, we
9875 * are really saying we want all the escapes removed. Otherwise the caller,
9876 * having no way to know whether it's already in VMS format, might send it
9877 * through tovmsspec again, thus double escaping.
9878 */
9879 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
a0d0e21e
LW		 9880 dd->pat.dsc$a_pointer = dd->pattern;
9881 dd->pat.dsc$w_length = strlen(dd->pattern);
9882 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9883 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3bc25146 9884#if defined(USE_ITHREADS)
a02a5408 9885 Newx(dd->mutex,1,perl_mutex);
a9852f7c
CB		 9886 MUTEX_INIT( (perl_mutex *) dd->mutex );
9887#else
9888 dd->mutex = NULL;
9889#endif
a0d0e21e
LW		 9890
9891 return dd;
9892} /* end of opendir() */
9893/*}}}*/
9894
9895/*
9896 * Set the flag to indicate we want versions or not.
9897 */
9898/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9899void
ddcbaa1c 9900vmsreaddirversions(DIR *dd, int flag)
a0d0e21e 9901{
657054d4
JM		 9902 if (flag)
9903 dd->flags |= PERL_VMSDIR_M_VERSIONS;
9904 else
9905 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
a0d0e21e
LW		 9906}
9907/*}}}*/
9908
9909/*
9910 * Free up an opened directory.
9911 */
9912/*{{{ void closedir(DIR *dd)*/
9913void
ddcbaa1c 9914Perl_closedir(DIR *dd)
a0d0e21e 9915{
f7ddb74a
JM		 9916 int sts;
9917
9918 sts = lib$find_file_end(&dd->context);
a0d0e21e 9919 Safefree(dd->pattern);
3bc25146 9920#if defined(USE_ITHREADS)
a9852f7c
CB		 9921 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9922 Safefree(dd->mutex);
9923#endif
f7ddb74a 9924 Safefree(dd);
a0d0e21e
LW		 9925}
9926/*}}}*/
9927
9928/*
9929 * Collect all the version numbers for the current file.
9930 */
9931static void
ddcbaa1c 9932collectversions(pTHX_ DIR *dd)
a0d0e21e
LW		 9933{
9934 struct dsc$descriptor_s pat;
9935 struct dsc$descriptor_s res;
ddcbaa1c 9936 struct dirent *e;
657054d4 9937 char *p, *text, *buff;
a0d0e21e
LW		 9938 int i;
9939 unsigned long context, tmpsts;
9940
9941 /* Convenient shorthand. */
9942 e = &dd->entry;
9943
9944 /* Add the version wildcard, ignoring the "*.*" put on before */
9945 i = strlen(dd->pattern);
a02a5408 9946 Newx(text,i + e->d_namlen + 3,char);
f7ddb74a
JM		 9947 strcpy(text, dd->pattern);
9948 sprintf(&text[i - 3], "%s;*", e->d_name);
a0d0e21e
LW		 9949
9950 /* Set up the pattern descriptor. */
9951 pat.dsc$a_pointer = text;
9952 pat.dsc$w_length = i + e->d_namlen - 1;
9953 pat.dsc$b_dtype = DSC$K_DTYPE_T;
9954 pat.dsc$b_class = DSC$K_CLASS_S;
9955
9956 /* Set up result descriptor. */
657054d4 9957 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 9958 res.dsc$a_pointer = buff;
657054d4 9959 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 9960 res.dsc$b_dtype = DSC$K_DTYPE_T;
9961 res.dsc$b_class = DSC$K_CLASS_S;
9962
9963 /* Read files, collecting versions. */
9964 for (context = 0, e->vms_verscount = 0;
9965 e->vms_verscount < VERSIZE(e);
9966 e->vms_verscount++) {
657054d4
JM		 9967 unsigned long rsts;
9968 unsigned long flags = 0;
9969
9970#ifdef VMS_LONGNAME_SUPPORT
988c775c 9971 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 9972#endif
9973 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
a0d0e21e 9974 if (tmpsts == RMS$_NMF || context == 0) break;
748a9306 9975 _ckvmssts(tmpsts);
657054d4 9976 buff[VMS_MAXRSS - 1] = '\0';
748a9306 9977 if ((p = strchr(buff, ';')))
a0d0e21e
LW		 9978 e->vms_versions[e->vms_verscount] = atoi(p + 1);
9979 else
9980 e->vms_versions[e->vms_verscount] = -1;
9981 }
9982
748a9306 9983 _ckvmssts(lib$find_file_end(&context));
a0d0e21e 9984 Safefree(text);
657054d4 9985 Safefree(buff);
a0d0e21e
LW		 9986
9987} /* end of collectversions() */
9988
9989/*
9990 * Read the next entry from the directory.
9991 */
9992/*{{{ struct dirent *readdir(DIR *dd)*/
ddcbaa1c
CB		 9993struct dirent *
9994Perl_readdir(pTHX_ DIR *dd)
a0d0e21e
LW		 9995{
9996 struct dsc$descriptor_s res;
657054d4 9997 char *p, *buff;
a0d0e21e 9998 unsigned long int tmpsts;
657054d4
JM		 9999 unsigned long rsts;
10000 unsigned long flags = 0;
dca5a913 10001 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
657054d4 10002 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e
LW		 10003
10004 /* Set up result descriptor, and get next file. */
657054d4 10005 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 10006 res.dsc$a_pointer = buff;
657054d4 10007 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 10008 res.dsc$b_dtype = DSC$K_DTYPE_T;
10009 res.dsc$b_class = DSC$K_CLASS_S;
657054d4
JM		 10010
10011#ifdef VMS_LONGNAME_SUPPORT
988c775c 10012 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 10013#endif
10014
10015 tmpsts = lib$find_file
10016 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
4633a7c4
LW		 10017 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
10018 if (!(tmpsts & 1)) {
10019 set_vaxc_errno(tmpsts);
10020 switch (tmpsts) {
10021 case RMS$_PRV:
c07a80fd 10022 set_errno(EACCES); break;
4633a7c4 10023 case RMS$_DEV:
c07a80fd 10024 set_errno(ENODEV); break;
4633a7c4 10025 case RMS$_DIR:
f282b18d
CB		 10026 set_errno(ENOTDIR); break;
10027 case RMS$_FNF: case RMS$_DNF:
c07a80fd 10028 set_errno(ENOENT); break;
4633a7c4
LW		 10029 default:
10030 set_errno(EVMSERR);
10031 }
657054d4 10032 Safefree(buff);
4633a7c4
LW		 10033 return NULL;
10034 }
10035 dd->count++;
a0d0e21e 10036 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
c43a0d1c
CB		 10037 buff[res.dsc$w_length] = '\0';
10038 p = buff + res.dsc$w_length;
10039 while (--p >= buff) if (!isspace(*p)) break;
10040 *p = '\0';
f7ddb74a 10041 if (!decc_efs_case_preserve) {
f7ddb74a 10042 for (p = buff; *p; p++) *p = _tolower(*p);
f7ddb74a 10043 }
a0d0e21e
LW		 10044
10045 /* Skip any directory component and just copy the name. */
657054d4 10046 sts = vms_split_path
360732b5 10047 (buff,
657054d4
JM		 10048 &v_spec,
10049 &v_len,
10050 &r_spec,
10051 &r_len,
10052 &d_spec,
10053 &d_len,
10054 &n_spec,
10055 &n_len,
10056 &e_spec,
10057 &e_len,
10058 &vs_spec,
10059 &vs_len);
10060
0dddfaca
JM		 10061 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10062
10063 /* In Unix report mode, remove the ".dir;1" from the name */
10064 /* if it is a real directory. */
10065 if (decc_filename_unix_report || decc_efs_charset) {
10066 if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
10067 if ((toupper(e_spec[1]) == 'D') &&
10068 (toupper(e_spec[2]) == 'I') &&
10069 (toupper(e_spec[3]) == 'R')) {
10070 Stat_t statbuf;
10071 int ret_sts;
10072
10073 ret_sts = stat(buff, (stat_t *)&statbuf);
10074 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10075 e_len = 0;
10076 e_spec[0] = 0;
10077 }
10078 }
10079 }
10080 }
10081
10082 /* Drop NULL extensions on UNIX file specification */
10083 if ((e_len == 1) && decc_readdir_dropdotnotype) {
10084 e_len = 0;
10085 e_spec[0] = '\0';
10086 }
dca5a913
JM		 10087 }
10088
657054d4
JM		 10089 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10090 dd->entry.d_name[n_len + e_len] = '\0';
10091 dd->entry.d_namlen = strlen(dd->entry.d_name);
a0d0e21e 10092
657054d4
JM		 10093 /* Convert the filename to UNIX format if needed */
10094 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10095
10096 /* Translate the encoded characters. */
38a44b82 10097 /* Fixme: Unicode handling could result in embedded 0 characters */
657054d4
JM		 10098 if (strchr(dd->entry.d_name, '^') != NULL) {
10099 char new_name[256];
10100 char * q;
657054d4
JM		 10101 p = dd->entry.d_name;
10102 q = new_name;
10103 while (*p != 0) {
f617045b
CB		 10104 int inchars_read, outchars_added;
10105 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10106 p += inchars_read;
10107 q += outchars_added;
dca5a913 10108 /* fix-me */
f617045b 10109 /* if outchars_added > 1, then this is a wide file specification */
dca5a913 10110 /* Wide file specifications need to be passed in Perl */
38a44b82 10111 /* counted strings apparently with a Unicode flag */
657054d4
JM		 10112 }
10113 *q = 0;
10114 strcpy(dd->entry.d_name, new_name);
f617045b 10115 dd->entry.d_namlen = strlen(dd->entry.d_name);
657054d4 10116 }
657054d4 10117 }
a0d0e21e 10118
a0d0e21e 10119 dd->entry.vms_verscount = 0;
657054d4
JM		 10120 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10121 Safefree(buff);
a0d0e21e
LW		 10122 return &dd->entry;
10123
10124} /* end of readdir() */
10125/*}}}*/
10126
10127/*
a9852f7c
CB		 10128 * Read the next entry from the directory -- thread-safe version.
10129 */
10130/*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10131int
ddcbaa1c 10132Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
a9852f7c
CB		 10133{
10134 int retval;
10135
10136 MUTEX_LOCK( (perl_mutex *) dd->mutex );
10137
7ded3206 10138 entry = readdir(dd);
a9852f7c
CB		 10139 *result = entry;
10140 retval = ( *result == NULL ? errno : 0 );
10141
10142 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10143
10144 return retval;
10145
10146} /* end of readdir_r() */
10147/*}}}*/
10148
10149/*
a0d0e21e
LW		 10150 * Return something that can be used in a seekdir later.
10151 */
10152/*{{{ long telldir(DIR *dd)*/
10153long
ddcbaa1c 10154Perl_telldir(DIR *dd)
a0d0e21e
LW		 10155{
10156 return dd->count;
10157}
10158/*}}}*/
10159
10160/*
10161 * Return to a spot where we used to be. Brute force.
10162 */
10163/*{{{ void seekdir(DIR *dd,long count)*/
10164void
ddcbaa1c 10165Perl_seekdir(pTHX_ DIR *dd, long count)
a0d0e21e 10166{
657054d4 10167 int old_flags;
a0d0e21e
LW		 10168
10169 /* If we haven't done anything yet... */
10170 if (dd->count == 0)
10171 return;
10172
10173 /* Remember some state, and clear it. */
657054d4
JM		 10174 old_flags = dd->flags;
10175 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
748a9306 10176 _ckvmssts(lib$find_file_end(&dd->context));
a0d0e21e
LW		 10177 dd->context = 0;
10178
10179 /* The increment is in readdir(). */
10180 for (dd->count = 0; dd->count < count; )
f7ddb74a 10181 readdir(dd);
a0d0e21e 10182
657054d4 10183 dd->flags = old_flags;
a0d0e21e
LW		 10184
10185} /* end of seekdir() */
10186/*}}}*/
10187
10188/* VMS subprocess management
10189 *
10190 * my_vfork() - just a vfork(), after setting a flag to record that
10191 * the current script is trying a Unix-style fork/exec.
10192 *
10193 * vms_do_aexec() and vms_do_exec() are called in response to the
10194 * perl 'exec' function. If this follows a vfork call, then they
a6d05634 10195 * call out the regular perl routines in doio.c which do an
a0d0e21e
LW		 10196 * execvp (for those who really want to try this under VMS).
10197 * Otherwise, they do exactly what the perl docs say exec should
10198 * do - terminate the current script and invoke a new command
10199 * (See below for notes on command syntax.)
10200 *
10201 * do_aspawn() and do_spawn() implement the VMS side of the perl
10202 * 'system' function.
10203 *
10204 * Note on command arguments to perl 'exec' and 'system': When handled
10205 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
eed5d6a1
CB		 10206 * are concatenated to form a DCL command string. If the first non-numeric
10207 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
a6d05634 10208 * the command string is handed off to DCL directly. Otherwise,
a0d0e21e
LW		 10209 * the first token of the command is taken as the filespec of an image
10210 * to run. The filespec is expanded using a default type of '.EXE' and
3eeba6fb 10211 * the process defaults for device, directory, etc., and if found, the resultant
a0d0e21e 10212 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3eeba6fb 10213 * the command string as parameters. This is perhaps a bit complicated,
a0d0e21e
LW		 10214 * but I hope it will form a happy medium between what VMS folks expect
10215 * from lib$spawn and what Unix folks expect from exec.
10216 */
10217
10218static int vfork_called;
10219
10220/*{{{int my_vfork()*/
10221int
10222my_vfork()
10223{
748a9306 10224 vfork_called++;
a0d0e21e
LW		 10225 return vfork();
10226}
10227/*}}}*/
10228
4633a7c4 10229
a0d0e21e 10230static void
218fdd94
CL		 10231vms_execfree(struct dsc$descriptor_s *vmscmd)
10232{
10233 if (vmscmd) {
10234 if (vmscmd->dsc$a_pointer) {
c5375c28 10235 PerlMem_free(vmscmd->dsc$a_pointer);
218fdd94 10236 }
c5375c28 10237 PerlMem_free(vmscmd);
4633a7c4
LW		 10238 }
10239}
10240
10241static char *
fd8cd3a3 10242setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
a0d0e21e 10243{
4e205ed6 10244 char *junk, *tmps = NULL;
a0d0e21e
LW		 10245 register size_t cmdlen = 0;
10246 size_t rlen;
10247 register SV **idx;
2d8e6c8d 10248 STRLEN n_a;
a0d0e21e
LW		 10249
10250 idx = mark;
4633a7c4
LW		 10251 if (really) {
10252 tmps = SvPV(really,rlen);
10253 if (*tmps) {
10254 cmdlen += rlen + 1;
10255 idx++;
10256 }
a0d0e21e
LW		 10257 }
10258
10259 for (idx++; idx <= sp; idx++) {
10260 if (*idx) {
10261 junk = SvPVx(*idx,rlen);
10262 cmdlen += rlen ? rlen + 1 : 0;
10263 }
10264 }
c5375c28 10265 Newx(PL_Cmd, cmdlen+1, char);
a0d0e21e 10266
4633a7c4 10267 if (tmps && *tmps) {
6b88bc9c 10268 strcpy(PL_Cmd,tmps);
a0d0e21e
LW		 10269 mark++;
10270 }
6b88bc9c 10271 else *PL_Cmd = '\0';
a0d0e21e
LW		 10272 while (++mark <= sp) {
10273 if (*mark) {
3eeba6fb
CB		 10274 char *s = SvPVx(*mark,n_a);
10275 if (!*s) continue;
10276 if (*PL_Cmd) strcat(PL_Cmd," ");
10277 strcat(PL_Cmd,s);
a0d0e21e
LW		 10278 }
10279 }
6b88bc9c 10280 return PL_Cmd;
a0d0e21e
LW		 10281
10282} /* end of setup_argstr() */
10283
4633a7c4 10284
a0d0e21e 10285static unsigned long int
2fbb330f 10286setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
218fdd94 10287 struct dsc$descriptor_s **pvmscmd)
a0d0e21e 10288{
e919cd19
JM		 10289 char * vmsspec;
10290 char * resspec;
e886094b
JM		 10291 char image_name[NAM$C_MAXRSS+1];
10292 char image_argv[NAM$C_MAXRSS+1];
a0d0e21e 10293 $DESCRIPTOR(defdsc,".EXE");
8012a33e 10294 $DESCRIPTOR(defdsc2,".");
e919cd19 10295 struct dsc$descriptor_s resdsc;
218fdd94 10296 struct dsc$descriptor_s *vmscmd;
a0d0e21e 10297 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3eeba6fb 10298 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
aa779de1 10299 register char *s, *rest, *cp, *wordbreak;
2fbb330f
JM		 10300 char * cmd;
10301 int cmdlen;
aa779de1 10302 register int isdcl;
a0d0e21e 10303
c5375c28 10304 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
ebd4d70b 10305 if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2fbb330f 10306
e919cd19
JM		 10307 /* vmsspec is a DCL command buffer, not just a filename */
10308 vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10309 if (vmsspec == NULL)
10310 _ckvmssts_noperl(SS$_INSFMEM);
10311
10312 resspec = PerlMem_malloc(VMS_MAXRSS);
10313 if (resspec == NULL)
10314 _ckvmssts_noperl(SS$_INSFMEM);
10315
2fbb330f
JM		 10316 /* Make a copy for modification */
10317 cmdlen = strlen(incmd);
c5375c28 10318 cmd = PerlMem_malloc(cmdlen+1);
ebd4d70b 10319 if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2fbb330f
JM		 10320 strncpy(cmd, incmd, cmdlen);
10321 cmd[cmdlen] = 0;
e886094b
JM		 10322 image_name[0] = 0;
10323 image_argv[0] = 0;
2fbb330f 10324
e919cd19
JM		 10325 resdsc.dsc$a_pointer = resspec;
10326 resdsc.dsc$b_dtype = DSC$K_DTYPE_T;
10327 resdsc.dsc$b_class = DSC$K_CLASS_S;
10328 resdsc.dsc$w_length = VMS_MAXRSS - 1;
10329
218fdd94
CL		 10330 vmscmd->dsc$a_pointer = NULL;
10331 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
10332 vmscmd->dsc$b_class = DSC$K_CLASS_S;
10333 vmscmd->dsc$w_length = 0;
10334 if (pvmscmd) *pvmscmd = vmscmd;
10335
ff7adb52
CL		 10336 if (suggest_quote) *suggest_quote = 0;
10337
2fbb330f 10338 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
c5375c28 10339 PerlMem_free(cmd);
e919cd19
JM		 10340 PerlMem_free(vmsspec);
10341 PerlMem_free(resspec);
a2669cfc 10342 return CLI$_BUFOVF; /* continuation lines currently unsupported */
2fbb330f
JM		 10343 }
10344
a0d0e21e 10345 s = cmd;
2fbb330f 10346
a0d0e21e 10347 while (*s && isspace(*s)) s++;
aa779de1
CB		 10348
10349 if (*s == '@' || *s == '$') {
10350 vmsspec[0] = *s; rest = s + 1;
10351 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10352 }
10353 else { cp = vmsspec; rest = s; }
10354 if (*rest == '.' || *rest == '/') {
10355 char *cp2;
10356 for (cp2 = resspec;
e919cd19 10357 *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
aa779de1
CB		 10358 rest++, cp2++) *cp2 = *rest;
10359 *cp2 = '\0';
df278665 10360 if (int_tovmsspec(resspec, cp, 0, NULL)) {
aa779de1 10361 s = vmsspec;
cfbf46cd
JM		 10362
10363 /* When a UNIX spec with no file type is translated to VMS, */
10364 /* A trailing '.' is appended under ODS-5 rules. */
10365 /* Here we do not want that trailing "." as it prevents */
10366 /* Looking for a implied ".exe" type. */
10367 if (decc_efs_charset) {
10368 int i;
10369 i = strlen(vmsspec);
10370 if (vmsspec[i-1] == '.') {
10371 vmsspec[i-1] = '\0';
10372 }
10373 }
10374
aa779de1
CB		 10375 if (*rest) {
10376 for (cp2 = vmsspec + strlen(vmsspec);
e919cd19 10377 *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
aa779de1
CB		 10378 rest++, cp2++) *cp2 = *rest;
10379 *cp2 = '\0';
a0d0e21e
LW		 10380 }
10381 }
10382 }
aa779de1
CB		 10383 /* Intuit whether verb (first word of cmd) is a DCL command:
10384 * - if first nonspace char is '@', it's a DCL indirection
10385 * otherwise
10386 * - if verb contains a filespec separator, it's not a DCL command
10387 * - if it doesn't, caller tells us whether to default to a DCL
10388 * command, or to a local image unless told it's DCL (by leading '$')
10389 */
ff7adb52
CL		 10390 if (*s == '@') {
10391 isdcl = 1;
10392 if (suggest_quote) *suggest_quote = 1;
10393 } else {
aa779de1
CB		 10394 register char *filespec = strpbrk(s,":<[.;");
10395 rest = wordbreak = strpbrk(s," \"\t/");
10396 if (!wordbreak) wordbreak = s + strlen(s);
10397 if (*s == '$') check_img = 0;
10398 if (filespec && (filespec < wordbreak)) isdcl = 0;
10399 else isdcl = !check_img;
10400 }
10401
3eeba6fb 10402 if (!isdcl) {
dca5a913 10403 int rsts;
aa779de1
CB		 10404 imgdsc.dsc$a_pointer = s;
10405 imgdsc.dsc$w_length = wordbreak - s;
dca5a913 10406 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8012a33e 10407 if (!(retsts&1)) {
ebd4d70b 10408 _ckvmssts_noperl(lib$find_file_end(&cxt));
dca5a913 10409 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f 10410 if (!(retsts & 1) && *s == '$') {
ebd4d70b 10411 _ckvmssts_noperl(lib$find_file_end(&cxt));
2497a41f 10412 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
dca5a913 10413 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
2497a41f 10414 if (!(retsts&1)) {
ebd4d70b 10415 _ckvmssts_noperl(lib$find_file_end(&cxt));
dca5a913 10416 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f
JM		 10417 }
10418 }
aa779de1 10419 }
ebd4d70b 10420 _ckvmssts_noperl(lib$find_file_end(&cxt));
8012a33e 10421
aa779de1 10422 if (retsts & 1) {
8012a33e 10423 FILE *fp;
a0d0e21e
LW		 10424 s = resspec;
10425 while (*s && !isspace(*s)) s++;
10426 *s = '\0';
8012a33e
CB		 10427
10428 /* check that it's really not DCL with no file extension */
e886094b 10429 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8012a33e 10430 if (fp) {
2497a41f
JM		 10431 char b[256] = {0,0,0,0};
10432 read(fileno(fp), b, 256);
8012a33e 10433 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
2497a41f 10434 if (isdcl) {
e886094b
JM		 10435 int shebang_len;
10436
2497a41f 10437 /* Check for script */
e886094b
JM		 10438 shebang_len = 0;
10439 if ((b[0] == '#') && (b[1] == '!'))
10440 shebang_len = 2;
10441#ifdef ALTERNATE_SHEBANG
10442 else {
10443 shebang_len = strlen(ALTERNATE_SHEBANG);
10444 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10445 char * perlstr;
10446 perlstr = strstr("perl",b);
10447 if (perlstr == NULL)
10448 shebang_len = 0;
10449 }
10450 else
10451 shebang_len = 0;
10452 }
10453#endif
10454
10455 if (shebang_len > 0) {
10456 int i;
10457 int j;
10458 char tmpspec[NAM$C_MAXRSS + 1];
10459
10460 i = shebang_len;
10461 /* Image is following after white space */
10462 /*--------------------------------------*/
10463 while (isprint(b[i]) && isspace(b[i]))
10464 i++;
10465
10466 j = 0;
10467 while (isprint(b[i]) && !isspace(b[i])) {
10468 tmpspec[j++] = b[i++];
10469 if (j >= NAM$C_MAXRSS)
10470 break;
10471 }
10472 tmpspec[j] = '\0';
10473
10474 /* There may be some default parameters to the image */
10475 /*---------------------------------------------------*/
10476 j = 0;
10477 while (isprint(b[i])) {
10478 image_argv[j++] = b[i++];
10479 if (j >= NAM$C_MAXRSS)
10480 break;
10481 }
10482 while ((j > 0) && !isprint(image_argv[j-1]))
10483 j--;
10484 image_argv[j] = 0;
10485
2497a41f 10486 /* It will need to be converted to VMS format and validated */
e886094b
JM		 10487 if (tmpspec[0] != '\0') {
10488 char * iname;
10489
10490 /* Try to find the exact program requested to be run */
10491 /*---------------------------------------------------*/
10492 iname = do_rmsexpand
360732b5
JM		 10493 (tmpspec, image_name, 0, ".exe",
10494 PERL_RMSEXPAND_M_VMS, NULL, NULL);
e886094b 10495 if (iname != NULL) {
a1887106
JM		 10496 if (cando_by_name_int
10497 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 10498 /* MCR prefix needed */
10499 isdcl = 0;
10500 }
10501 else {
10502 /* Try again with a null type */
10503 /*----------------------------*/
10504 iname = do_rmsexpand
360732b5
JM		 10505 (tmpspec, image_name, 0, ".",
10506 PERL_RMSEXPAND_M_VMS, NULL, NULL);
e886094b 10507 if (iname != NULL) {
a1887106
JM		 10508 if (cando_by_name_int
10509 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 10510 /* MCR prefix needed */
10511 isdcl = 0;
10512 }
10513 }
10514 }
10515
10516 /* Did we find the image to run the script? */
10517 /*------------------------------------------*/
10518 if (isdcl) {
10519 char *tchr;
10520
10521 /* Assume DCL or foreign command exists */
10522 /*--------------------------------------*/
10523 tchr = strrchr(tmpspec, '/');
10524 if (tchr != NULL) {
10525 tchr++;
10526 }
10527 else {
10528 tchr = tmpspec;
10529 }
10530 strcpy(image_name, tchr);
10531 }
10532 }
10533 }
2497a41f
JM		 10534 }
10535 }
8012a33e
CB		 10536 fclose(fp);
10537 }
e919cd19
JM		 10538 if (check_img && isdcl) {
10539 PerlMem_free(cmd);
10540 PerlMem_free(resspec);
10541 PerlMem_free(vmsspec);
10542 return RMS$_FNF;
10543 }
8012a33e 10544
3eeba6fb 10545 if (cando_by_name(S_IXUSR,0,resspec)) {
c5375c28 10546 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
ebd4d70b 10547 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8012a33e 10548 if (!isdcl) {
218fdd94 10549 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
e886094b
JM		 10550 if (image_name[0] != 0) {
10551 strcat(vmscmd->dsc$a_pointer, image_name);
10552 strcat(vmscmd->dsc$a_pointer, " ");
10553 }
10554 } else if (image_name[0] != 0) {
10555 strcpy(vmscmd->dsc$a_pointer, image_name);
10556 strcat(vmscmd->dsc$a_pointer, " ");
8012a33e 10557 } else {
218fdd94 10558 strcpy(vmscmd->dsc$a_pointer,"@");
8012a33e 10559 }
e886094b
JM		 10560 if (suggest_quote) *suggest_quote = 1;
10561
10562 /* If there is an image name, use original command */
10563 if (image_name[0] == 0)
10564 strcat(vmscmd->dsc$a_pointer,resspec);
10565 else {
10566 rest = cmd;
10567 while (*rest && isspace(*rest)) rest++;
10568 }
10569
10570 if (image_argv[0] != 0) {
10571 strcat(vmscmd->dsc$a_pointer,image_argv);
10572 strcat(vmscmd->dsc$a_pointer, " ");
10573 }
10574 if (rest) {
10575 int rest_len;
10576 int vmscmd_len;
10577
10578 rest_len = strlen(rest);
10579 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10580 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10581 strcat(vmscmd->dsc$a_pointer,rest);
10582 else
10583 retsts = CLI$_BUFOVF;
10584 }
218fdd94 10585 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
c5375c28 10586 PerlMem_free(cmd);
e919cd19
JM		 10587 PerlMem_free(vmsspec);
10588 PerlMem_free(resspec);
218fdd94 10589 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
3eeba6fb 10590 }
c5375c28
JM		 10591 else
10592 retsts = RMS$_PRV;
a0d0e21e
LW		 10593 }
10594 }
3eeba6fb 10595 /* It's either a DCL command or we couldn't find a suitable image */
218fdd94 10596 vmscmd->dsc$w_length = strlen(cmd);
ff7adb52 10597
b011c7bd 10598 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
c5375c28 10599 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
b011c7bd 10600 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
c5375c28
JM		 10601
10602 PerlMem_free(cmd);
e919cd19
JM		 10603 PerlMem_free(resspec);
10604 PerlMem_free(vmsspec);
2fbb330f 10605
ff7adb52
CL		 10606 /* check if it's a symbol (for quoting purposes) */
10607 if (suggest_quote && !*suggest_quote) {
10608 int iss;
10609 char equiv[LNM$C_NAMLENGTH];
10610 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10611 eqvdsc.dsc$a_pointer = equiv;
10612
218fdd94 10613 iss = lib$get_symbol(vmscmd,&eqvdsc);
ff7adb52
CL		 10614 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10615 }
3eeba6fb
CB		 10616 if (!(retsts & 1)) {
10617 /* just hand off status values likely to be due to user error */
10618 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10619 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10620 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
ebd4d70b 10621 else { _ckvmssts_noperl(retsts); }
3eeba6fb 10622 }
a0d0e21e 10623
218fdd94 10624 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
a3e9d8c9 10625
a0d0e21e
LW		 10626} /* end of setup_cmddsc() */
10627
a3e9d8c9 10628
a0d0e21e
LW		 10629/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10630bool
fd8cd3a3 10631Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
a0d0e21e 10632{
c5375c28
JM		 10633bool exec_sts;
10634char * cmd;
10635
a0d0e21e
LW		 10636 if (sp > mark) {
10637 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 10638 vfork_called--;
10639 if (vfork_called < 0) {
5c84aa53 10640 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 10641 vfork_called = 0;
10642 }
10643 else return do_aexec(really,mark,sp);
a0d0e21e 10644 }
4633a7c4 10645 /* no vfork - act VMSish */
c5375c28
JM		 10646 cmd = setup_argstr(aTHX_ really,mark,sp);
10647 exec_sts = vms_do_exec(cmd);
10648 Safefree(cmd); /* Clean up from setup_argstr() */
10649 return exec_sts;
a0d0e21e
LW		 10650 }
10651
10652 return FALSE;
10653} /* end of vms_do_aexec() */
10654/*}}}*/
10655
10656/* {{{bool vms_do_exec(char *cmd) */
10657bool
2fbb330f 10658Perl_vms_do_exec(pTHX_ const char *cmd)
a0d0e21e 10659{
218fdd94 10660 struct dsc$descriptor_s *vmscmd;
a0d0e21e
LW		 10661
10662 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 10663 vfork_called--;
10664 if (vfork_called < 0) {
5c84aa53 10665 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 10666 vfork_called = 0;
10667 }
10668 else return do_exec(cmd);
a0d0e21e 10669 }
748a9306
LW		 10670
10671 { /* no vfork - act VMSish */
748a9306 10672 unsigned long int retsts;
a0d0e21e 10673
1e422769 10674 TAINT_ENV();
10675 TAINT_PROPER("exec");
218fdd94
CL		 10676 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10677 retsts = lib$do_command(vmscmd);
a0d0e21e 10678
09b7f37c 10679 switch (retsts) {
f282b18d 10680 case RMS$_FNF: case RMS$_DNF:
09b7f37c 10681 set_errno(ENOENT); break;
f282b18d 10682 case RMS$_DIR:
09b7f37c 10683 set_errno(ENOTDIR); break;
f282b18d
CB		 10684 case RMS$_DEV:
10685 set_errno(ENODEV); break;
09b7f37c
CB		 10686 case RMS$_PRV:
10687 set_errno(EACCES); break;
10688 case RMS$_SYN:
10689 set_errno(EINVAL); break;
a2669cfc 10690 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
09b7f37c
CB		 10691 set_errno(E2BIG); break;
10692 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 10693 _ckvmssts_noperl(retsts); /* fall through */
09b7f37c
CB		 10694 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10695 set_errno(EVMSERR);
10696 }
748a9306 10697 set_vaxc_errno(retsts);
3eeba6fb 10698 if (ckWARN(WARN_EXEC)) {
f98bc0c6 10699 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
218fdd94 10700 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
3eeba6fb 10701 }
218fdd94 10702 vms_execfree(vmscmd);
a0d0e21e
LW		 10703 }
10704
10705 return FALSE;
10706
10707} /* end of vms_do_exec() */
10708/*}}}*/
10709
9ec7171b 10710int do_spawn2(pTHX_ const char *, int);
a0d0e21e 10711
9ec7171b
CB		 10712int
10713Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
a0d0e21e 10714{
c5375c28
JM		 10715unsigned long int sts;
10716char * cmd;
eed5d6a1 10717int flags = 0;
a0d0e21e 10718
c5375c28 10719 if (sp > mark) {
eed5d6a1
CB		 10720
10721 /* We'll copy the (undocumented?) Win32 behavior and allow a
10722 * numeric first argument. But the only value we'll support
10723 * through do_aspawn is a value of 1, which means spawn without
10724 * waiting for completion -- other values are ignored.
10725 */
9ec7171b 10726 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
eed5d6a1 10727 ++mark;
9ec7171b 10728 flags = SvIVx(*mark);
eed5d6a1
CB		 10729 }
10730
10731 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
10732 flags = CLI$M_NOWAIT;
10733 else
10734 flags = 0;
10735
9ec7171b 10736 cmd = setup_argstr(aTHX_ really, mark, sp);
eed5d6a1 10737 sts = do_spawn2(aTHX_ cmd, flags);
c5375c28
JM		 10738 /* pp_sys will clean up cmd */
10739 return sts;
10740 }
a0d0e21e
LW		 10741 return SS$_ABORT;
10742} /* end of do_aspawn() */
10743/*}}}*/
10744
eed5d6a1 10745
9ec7171b
CB		 10746/* {{{int do_spawn(char* cmd) */
10747int
10748Perl_do_spawn(pTHX_ char* cmd)
a0d0e21e 10749{
7918f24d
NC		 10750 PERL_ARGS_ASSERT_DO_SPAWN;
10751
eed5d6a1
CB		 10752 return do_spawn2(aTHX_ cmd, 0);
10753}
10754/*}}}*/
10755
9ec7171b
CB		 10756/* {{{int do_spawn_nowait(char* cmd) */
10757int
10758Perl_do_spawn_nowait(pTHX_ char* cmd)
10759{
10760 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10761
10762 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10763}
10764/*}}}*/
10765
10766/* {{{int do_spawn2(char *cmd) */
10767int
eed5d6a1
CB		 10768do_spawn2(pTHX_ const char *cmd, int flags)
10769{
209030df 10770 unsigned long int sts, substs;
a0d0e21e 10771
c5375c28
JM		 10772 /* The caller of this routine expects to Safefree(PL_Cmd) */
10773 Newx(PL_Cmd,10,char);
10774
1e422769 10775 TAINT_ENV();
10776 TAINT_PROPER("spawn");
748a9306 10777 if (!cmd || !*cmd) {
eed5d6a1 10778 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
c8795d8b
JH		 10779 if (!(sts & 1)) {
10780 switch (sts) {
209030df
JH		 10781 case RMS$_FNF: case RMS$_DNF:
10782 set_errno(ENOENT); break;
10783 case RMS$_DIR:
10784 set_errno(ENOTDIR); break;
10785 case RMS$_DEV:
10786 set_errno(ENODEV); break;
10787 case RMS$_PRV:
10788 set_errno(EACCES); break;
10789 case RMS$_SYN:
10790 set_errno(EINVAL); break;
10791 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10792 set_errno(E2BIG); break;
10793 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 10794 _ckvmssts_noperl(sts); /* fall through */
209030df
JH		 10795 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10796 set_errno(EVMSERR);
c8795d8b
JH		 10797 }
10798 set_vaxc_errno(sts);
10799 if (ckWARN(WARN_EXEC)) {
f98bc0c6 10800 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
c8795d8b
JH		 10801 Strerror(errno));
10802 }
09b7f37c 10803 }
c8795d8b 10804 sts = substs;
48023aa8
CL		 10805 }
10806 else {
eed5d6a1 10807 char mode[3];
2fbb330f 10808 PerlIO * fp;
eed5d6a1
CB		 10809 if (flags & CLI$M_NOWAIT)
10810 strcpy(mode, "n");
10811 else
10812 strcpy(mode, "nW");
10813
10814 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
2fbb330f
JM		 10815 if (fp != NULL)
10816 my_pclose(fp);
eed5d6a1 10817 /* sts will be the pid in the nowait case */
48023aa8 10818 }
48023aa8 10819 return sts;
eed5d6a1 10820} /* end of do_spawn2() */
a0d0e21e
LW		 10821/*}}}*/
10822
bc10a425
CB		 10823
10824static unsigned int *sockflags, sockflagsize;
10825
10826/*
10827 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10828 * routines found in some versions of the CRTL can't deal with sockets.
10829 * We don't shim the other file open routines since a socket isn't
10830 * likely to be opened by a name.
10831 */
275feba9
CB		 10832/*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10833FILE *my_fdopen(int fd, const char *mode)
bc10a425 10834{
f7ddb74a 10835 FILE *fp = fdopen(fd, mode);
bc10a425
CB		 10836
10837 if (fp) {
10838 unsigned int fdoff = fd / sizeof(unsigned int);
2497a41f 10839 Stat_t sbuf; /* native stat; we don't need flex_stat */
bc10a425
CB		 10840 if (!sockflagsize || fdoff > sockflagsize) {
10841 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
a02a5408 10842 else Newx (sockflags,fdoff+2,unsigned int);
bc10a425
CB		 10843 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10844 sockflagsize = fdoff + 2;
10845 }
2497a41f 10846 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
bc10a425
CB		 10847 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10848 }
10849 return fp;
10850
10851}
10852/*}}}*/
10853
10854
10855/*
10856 * Clear the corresponding bit when the (possibly) socket stream is closed.
10857 * There still a small hole: we miss an implicit close which might occur
10858 * via freopen(). >> Todo
10859 */
10860/*{{{ int my_fclose(FILE *fp)*/
10861int my_fclose(FILE *fp) {
10862 if (fp) {
10863 unsigned int fd = fileno(fp);
10864 unsigned int fdoff = fd / sizeof(unsigned int);
10865
e0951028 10866 if (sockflagsize && fdoff < sockflagsize)
bc10a425
CB		 10867 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10868 }
10869 return fclose(fp);
10870}
10871/*}}}*/
10872
10873
a0d0e21e
LW		 10874/*
10875 * A simple fwrite replacement which outputs itmsz*nitm chars without
10876 * introducing record boundaries every itmsz chars.
22d4bb9c
CB		 10877 * We are using fputs, which depends on a terminating null. We may
10878 * well be writing binary data, so we need to accommodate not only
10879 * data with nulls sprinkled in the middle but also data with no null
10880 * byte at the end.
a0d0e21e 10881 */
a15cef0c 10882/*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
a0d0e21e 10883int
a15cef0c 10884my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
a0d0e21e 10885{
22d4bb9c 10886 register char *cp, *end, *cpd, *data;
bc10a425
CB		 10887 register unsigned int fd = fileno(dest);
10888 register unsigned int fdoff = fd / sizeof(unsigned int);
22d4bb9c 10889 int retval;
bc10a425
CB		 10890 int bufsize = itmsz * nitm + 1;
10891
10892 if (fdoff < sockflagsize &&
10893 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10894 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10895 return nitm;
10896 }
22d4bb9c 10897
bc10a425 10898 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
22d4bb9c
CB		 10899 memcpy( data, src, itmsz*nitm );
10900 data[itmsz*nitm] = '\0';
a0d0e21e 10901
22d4bb9c
CB		 10902 end = data + itmsz * nitm;
10903 retval = (int) nitm; /* on success return # items written */
a0d0e21e 10904
22d4bb9c
CB		 10905 cpd = data;
10906 while (cpd <= end) {
10907 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10908 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
a0d0e21e 10909 if (cp < end)
22d4bb9c
CB		 10910 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10911 cpd = cp + 1;
a0d0e21e
LW		 10912 }
10913
bc10a425 10914 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
22d4bb9c 10915 return retval;
a0d0e21e
LW		 10916
10917} /* end of my_fwrite() */
10918/*}}}*/
10919
d27fe803
JH		 10920/*{{{ int my_flush(FILE *fp)*/
10921int
fd8cd3a3 10922Perl_my_flush(pTHX_ FILE *fp)
d27fe803
JH		 10923{
10924 int res;
93948341 10925 if ((res = fflush(fp)) == 0 && fp) {
d27fe803 10926#ifdef VMS_DO_SOCKETS
61bb5906 10927 Stat_t s;
ed1b9de0 10928 if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
d27fe803
JH		 10929#endif
10930 res = fsync(fileno(fp));
10931 }
22d4bb9c
CB		 10932/*
10933 * If the flush succeeded but set end-of-file, we need to clear
10934 * the error because our caller may check ferror(). BTW, this
10935 * probably means we just flushed an empty file.
10936 */
10937 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10938
d27fe803
JH		 10939 return res;
10940}
10941/*}}}*/
10942
748a9306
LW		 10943/*
10944 * Here are replacements for the following Unix routines in the VMS environment:
10945 * getpwuid Get information for a particular UIC or UID
10946 * getpwnam Get information for a named user
10947 * getpwent Get information for each user in the rights database
10948 * setpwent Reset search to the start of the rights database
10949 * endpwent Finish searching for users in the rights database
10950 *
10951 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10952 * (defined in pwd.h), which contains the following fields:-
10953 * struct passwd {
10954 * char *pw_name; Username (in lower case)
10955 * char *pw_passwd; Hashed password
10956 * unsigned int pw_uid; UIC
10957 * unsigned int pw_gid; UIC group number
10958 * char *pw_unixdir; Default device/directory (VMS-style)
10959 * char *pw_gecos; Owner name
10960 * char *pw_dir; Default device/directory (Unix-style)
10961 * char *pw_shell; Default CLI name (eg. DCL)
10962 * };
10963 * If the specified user does not exist, getpwuid and getpwnam return NULL.
10964 *
10965 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10966 * not the UIC member number (eg. what's returned by getuid()),
10967 * getpwuid() can accept either as input (if uid is specified, the caller's
10968 * UIC group is used), though it won't recognise gid=0.
10969 *
10970 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10971 * information about other users in your group or in other groups, respectively.
10972 * If the required privilege is not available, then these routines fill only
10973 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10974 * string).
10975 *
10976 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10977 */
10978
10979/* sizes of various UAF record fields */
10980#define UAI$S_USERNAME 12
10981#define UAI$S_IDENT 31
10982#define UAI$S_OWNER 31
10983#define UAI$S_DEFDEV 31
10984#define UAI$S_DEFDIR 63
10985#define UAI$S_DEFCLI 31
10986#define UAI$S_PWD 8
10987
10988#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
10989 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10990 (uic).uic$v_group != UIC$K_WILD_GROUP)
10991
4633a7c4
LW		 10992static char __empty[]= "";
10993static struct passwd __passwd_empty=
748a9306
LW		 10994 {(char *) __empty, (char *) __empty, 0, 0,
10995 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10996static int contxt= 0;
10997static struct passwd __pwdcache;
10998static char __pw_namecache[UAI$S_IDENT+1];
10999
748a9306
LW		 11000/*
11001 * This routine does most of the work extracting the user information.
11002 */
fd8cd3a3 11003static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
a0d0e21e 11004{
748a9306
LW		 11005 static struct {
11006 unsigned char length;
11007 char pw_gecos[UAI$S_OWNER+1];
11008 } owner;
11009 static union uicdef uic;
11010 static struct {
11011 unsigned char length;
11012 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11013 } defdev;
11014 static struct {
11015 unsigned char length;
11016 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11017 } defdir;
11018 static struct {
11019 unsigned char length;
11020 char pw_shell[UAI$S_DEFCLI+1];
11021 } defcli;
11022 static char pw_passwd[UAI$S_PWD+1];
11023
11024 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11025 struct dsc$descriptor_s name_desc;
c07a80fd 11026 unsigned long int sts;
748a9306 11027
4633a7c4 11028 static struct itmlst_3 itmlst[]= {
748a9306
LW		 11029 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
11030 {sizeof(uic), UAI$_UIC, &uic, &luic},
11031 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
11032 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
11033 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
11034 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
11035 {0, 0, NULL, NULL}};
11036
11037 name_desc.dsc$w_length= strlen(name);
11038 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11039 name_desc.dsc$b_class= DSC$K_CLASS_S;
f7ddb74a 11040 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
748a9306
LW		 11041
11042/* Note that sys$getuai returns many fields as counted strings. */
c07a80fd 11043 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11044 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11045 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11046 }
11047 else { _ckvmssts(sts); }
11048 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
748a9306
LW		 11049
11050 if ((int) owner.length < lowner) lowner= (int) owner.length;
11051 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11052 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11053 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11054 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11055 owner.pw_gecos[lowner]= '\0';
11056 defdev.pw_dir[ldefdev+ldefdir]= '\0';
11057 defcli.pw_shell[ldefcli]= '\0';
11058 if (valid_uic(uic)) {
11059 pwd->pw_uid= uic.uic$l_uic;
11060 pwd->pw_gid= uic.uic$v_group;
11061 }
11062 else
5c84aa53 11063 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
748a9306
LW		 11064 pwd->pw_passwd= pw_passwd;
11065 pwd->pw_gecos= owner.pw_gecos;
11066 pwd->pw_dir= defdev.pw_dir;
360732b5 11067 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
748a9306
LW		 11068 pwd->pw_shell= defcli.pw_shell;
11069 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11070 int ldir;
11071 ldir= strlen(pwd->pw_unixdir) - 1;
11072 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11073 }
11074 else
11075 strcpy(pwd->pw_unixdir, pwd->pw_dir);
f7ddb74a
JM		 11076 if (!decc_efs_case_preserve)
11077 __mystrtolower(pwd->pw_unixdir);
c07a80fd 11078 return 1;
a0d0e21e 11079}
748a9306
LW		 11080
11081/*
11082 * Get information for a named user.
11083*/
11084/*{{{struct passwd *getpwnam(char *name)*/
2fbb330f 11085struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
748a9306
LW		 11086{
11087 struct dsc$descriptor_s name_desc;
11088 union uicdef uic;
aa689395 11089 unsigned long int status, sts;
748a9306
LW		 11090
11091 __pwdcache = __passwd_empty;
fd8cd3a3 11092 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
748a9306
LW		 11093 /* We still may be able to determine pw_uid and pw_gid */
11094 name_desc.dsc$w_length= strlen(name);
11095 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11096 name_desc.dsc$b_class= DSC$K_CLASS_S;
11097 name_desc.dsc$a_pointer= (char *) name;
aa689395 11098 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
748a9306
LW		 11099 __pwdcache.pw_uid= uic.uic$l_uic;
11100 __pwdcache.pw_gid= uic.uic$v_group;
11101 }
c07a80fd 11102 else {
aa689395 11103 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11104 set_vaxc_errno(sts);
11105 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
c07a80fd 11106 return NULL;
11107 }
aa689395 11108 else { _ckvmssts(sts); }
c07a80fd 11109 }
748a9306 11110 }
748a9306
LW		 11111 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11112 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11113 __pwdcache.pw_name= __pw_namecache;
11114 return &__pwdcache;
11115} /* end of my_getpwnam() */
a0d0e21e
LW		 11116/*}}}*/
11117
748a9306
LW		 11118/*
11119 * Get information for a particular UIC or UID.
11120 * Called by my_getpwent with uid=-1 to list all users.
11121*/
11122/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
fd8cd3a3 11123struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
a0d0e21e 11124{
748a9306
LW		 11125 const $DESCRIPTOR(name_desc,__pw_namecache);
11126 unsigned short lname;
11127 union uicdef uic;
11128 unsigned long int status;
11129
11130 if (uid == (unsigned int) -1) {
11131 do {
11132 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11133 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
c07a80fd 11134 set_vaxc_errno(status);
11135 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
748a9306
LW		 11136 my_endpwent();
11137 return NULL;
11138 }
11139 else { _ckvmssts(status); }
11140 } while (!valid_uic (uic));
11141 }
11142 else {
11143 uic.uic$l_uic= uid;
c07a80fd 11144 if (!uic.uic$v_group)
76e3520e 11145 uic.uic$v_group= PerlProc_getgid();
748a9306
LW		 11146 if (valid_uic(uic))
11147 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11148 else status = SS$_IVIDENT;
c07a80fd 11149 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11150 status == RMS$_PRV) {
11151 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11152 return NULL;
11153 }
11154 else { _ckvmssts(status); }
748a9306
LW		 11155 }
11156 __pw_namecache[lname]= '\0';
01b8edb6 11157 __mystrtolower(__pw_namecache);
748a9306
LW		 11158
11159 __pwdcache = __passwd_empty;
11160 __pwdcache.pw_name = __pw_namecache;
11161
11162/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11163 The identifier's value is usually the UIC, but it doesn't have to be,
11164 so if we can, we let fillpasswd update this. */
11165 __pwdcache.pw_uid = uic.uic$l_uic;
11166 __pwdcache.pw_gid = uic.uic$v_group;
11167
fd8cd3a3 11168 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
748a9306 11169 return &__pwdcache;
a0d0e21e 11170
748a9306
LW		 11171} /* end of my_getpwuid() */
11172/*}}}*/
11173
11174/*
11175 * Get information for next user.
11176*/
11177/*{{{struct passwd *my_getpwent()*/
fd8cd3a3 11178struct passwd *Perl_my_getpwent(pTHX)
748a9306
LW		 11179{
11180 return (my_getpwuid((unsigned int) -1));
11181}
11182/*}}}*/
a0d0e21e 11183
748a9306
LW		 11184/*
11185 * Finish searching rights database for users.
11186*/
11187/*{{{void my_endpwent()*/
fd8cd3a3 11188void Perl_my_endpwent(pTHX)
748a9306
LW		 11189{
11190 if (contxt) {
11191 _ckvmssts(sys$finish_rdb(&contxt));
11192 contxt= 0;
11193 }
a0d0e21e
LW		 11194}
11195/*}}}*/
748a9306 11196
61bb5906
CB		 11197#ifdef HOMEGROWN_POSIX_SIGNALS
11198 /* Signal handling routines, pulled into the core from POSIX.xs.
11199 *
11200 * We need these for threads, so they've been rolled into the core,
11201 * rather than left in POSIX.xs.
11202 *
11203 * (DRS, Oct 23, 1997)
11204 */
5b411029 11205
61bb5906
CB		 11206 /* sigset_t is atomic under VMS, so these routines are easy */
11207/*{{{int my_sigemptyset(sigset_t *) */
5b411029 11208int my_sigemptyset(sigset_t *set) {
61bb5906
CB		 11209 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11210 *set = 0; return 0;
5b411029 11211}
61bb5906
CB		 11212/*}}}*/
11213
11214
11215/*{{{int my_sigfillset(sigset_t *)*/
5b411029 11216int my_sigfillset(sigset_t *set) {
61bb5906
CB		 11217 int i;
11218 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11219 for (i = 0; i < NSIG; i++) *set |= (1 << i);
11220 return 0;
5b411029 11221}
61bb5906
CB		 11222/*}}}*/
11223
11224
11225/*{{{int my_sigaddset(sigset_t *set, int sig)*/
5b411029 11226int my_sigaddset(sigset_t *set, int sig) {
61bb5906
CB		 11227 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11228 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11229 *set |= (1 << (sig - 1));
11230 return 0;
5b411029 11231}
61bb5906
CB		 11232/*}}}*/
11233
11234
11235/*{{{int my_sigdelset(sigset_t *set, int sig)*/
5b411029 11236int my_sigdelset(sigset_t *set, int sig) {
61bb5906
CB		 11237 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11238 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11239 *set &= ~(1 << (sig - 1));
11240 return 0;
5b411029 11241}
61bb5906
CB		 11242/*}}}*/
11243
11244
11245/*{{{int my_sigismember(sigset_t *set, int sig)*/
5b411029 11246int my_sigismember(sigset_t *set, int sig) {
61bb5906
CB		 11247 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11248 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
73e350d9 11249 return *set & (1 << (sig - 1));
5b411029 11250}
61bb5906 11251/*}}}*/
5b411029 11252
5b411029 11253
61bb5906
CB		 11254/*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11255int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11256 sigset_t tempmask;
11257
11258 /* If set and oset are both null, then things are badly wrong. Bail out. */
11259 if ((oset == NULL) && (set == NULL)) {
11260 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5b411029
MB		 11261 return -1;
11262 }
5b411029 11263
61bb5906
CB		 11264 /* If set's null, then we're just handling a fetch. */
11265 if (set == NULL) {
11266 tempmask = sigblock(0);
11267 }
11268 else {
11269 switch (how) {
11270 case SIG_SETMASK:
11271 tempmask = sigsetmask(*set);
11272 break;
11273 case SIG_BLOCK:
11274 tempmask = sigblock(*set);
11275 break;
11276 case SIG_UNBLOCK:
11277 tempmask = sigblock(0);
11278 sigsetmask(*oset & ~tempmask);
11279 break;
11280 default:
11281 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11282 return -1;
11283 }
11284 }
11285
11286 /* Did they pass us an oset? If so, stick our holding mask into it */
11287 if (oset)
11288 *oset = tempmask;
5b411029 11289
61bb5906 11290 return 0;
5b411029 11291}
61bb5906
CB		 11292/*}}}*/
11293#endif /* HOMEGROWN_POSIX_SIGNALS */
11294
5b411029 11295
ff0cee69 11296/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11297 * my_utime(), and flex_stat(), all of which operate on UTC unless
11298 * VMSISH_TIMES is true.
11299 */
11300/* method used to handle UTC conversions:
11301 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
e518068a 11302 */
ff0cee69 11303static int gmtime_emulation_type;
11304/* number of secs to add to UTC POSIX-style time to get local time */
11305static long int utc_offset_secs;
e518068a 11306
ff0cee69 11307/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11308 * in vmsish.h. #undef them here so we can call the CRTL routines
11309 * directly.
e518068a 11310 */
11311#undef gmtime
ff0cee69 11312#undef localtime
11313#undef time
11314
61bb5906 11315
a44ceb8e
CB		 11316/*
11317 * DEC C previous to 6.0 corrupts the behavior of the /prefix
11318 * qualifier with the extern prefix pragma. This provisional
11319 * hack circumvents this prefix pragma problem in previous
11320 * precompilers.
11321 */
11322#if defined(__VMS_VER) && __VMS_VER >= 70000000
11323# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11324# pragma __extern_prefix save
11325# pragma __extern_prefix "" /* set to empty to prevent prefixing */
11326# define gmtime decc$__utctz_gmtime
11327# define localtime decc$__utctz_localtime
11328# define time decc$__utc_time
11329# pragma __extern_prefix restore
11330
11331 struct tm *gmtime(), *localtime();
11332
11333# endif
11334#endif
11335
11336
61bb5906
CB		 11337static time_t toutc_dst(time_t loc) {
11338 struct tm *rsltmp;
11339
11340 if ((rsltmp = localtime(&loc)) == NULL) return -1;
11341 loc -= utc_offset_secs;
11342 if (rsltmp->tm_isdst) loc -= 3600;
11343 return loc;
11344}
32da55ab 11345#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 11346 ((gmtime_emulation_type || my_time(NULL)), \
11347 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11348 ((secs) - utc_offset_secs))))
11349
11350static time_t toloc_dst(time_t utc) {
11351 struct tm *rsltmp;
11352
11353 utc += utc_offset_secs;
11354 if ((rsltmp = localtime(&utc)) == NULL) return -1;
11355 if (rsltmp->tm_isdst) utc += 3600;
11356 return utc;
11357}
32da55ab 11358#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 11359 ((gmtime_emulation_type || my_time(NULL)), \
11360 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11361 ((secs) + utc_offset_secs))))
11362
22d4bb9c
CB		 11363#ifndef RTL_USES_UTC
11364/*
11365
11366 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
11367 DST starts on 1st sun of april at 02:00 std time
11368 ends on last sun of october at 02:00 dst time
11369 see the UCX management command reference, SET CONFIG TIMEZONE
11370 for formatting info.
11371
11372 No, it's not as general as it should be, but then again, NOTHING
11373 will handle UK times in a sensible way.
11374*/
11375
11376
11377/*
11378 parse the DST start/end info:
11379 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11380*/
11381
11382static char *
11383tz_parse_startend(char *s, struct tm *w, int *past)
11384{
11385 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11386 int ly, dozjd, d, m, n, hour, min, sec, j, k;
11387 time_t g;
11388
11389 if (!s) return 0;
11390 if (!w) return 0;
11391 if (!past) return 0;
11392
11393 ly = 0;
11394 if (w->tm_year % 4 == 0) ly = 1;
11395 if (w->tm_year % 100 == 0) ly = 0;
11396 if (w->tm_year+1900 % 400 == 0) ly = 1;
11397 if (ly) dinm[1]++;
11398
11399 dozjd = isdigit(*s);
11400 if (*s == 'J' || *s == 'j' || dozjd) {
11401 if (!dozjd && !isdigit(*++s)) return 0;
11402 d = *s++ - '0';
11403 if (isdigit(*s)) {
11404 d = d*10 + *s++ - '0';
11405 if (isdigit(*s)) {
11406 d = d*10 + *s++ - '0';
11407 }
11408 }
11409 if (d == 0) return 0;
11410 if (d > 366) return 0;
11411 d--;
11412 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
11413 g = d * 86400;
11414 dozjd = 1;
11415 } else if (*s == 'M' || *s == 'm') {
11416 if (!isdigit(*++s)) return 0;
11417 m = *s++ - '0';
11418 if (isdigit(*s)) m = 10*m + *s++ - '0';
11419 if (*s != '.') return 0;
11420 if (!isdigit(*++s)) return 0;
11421 n = *s++ - '0';
11422 if (n < 1 || n > 5) return 0;
11423 if (*s != '.') return 0;
11424 if (!isdigit(*++s)) return 0;
11425 d = *s++ - '0';
11426 if (d > 6) return 0;
11427 }
11428
11429 if (*s == '/') {
11430 if (!isdigit(*++s)) return 0;
11431 hour = *s++ - '0';
11432 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11433 if (*s == ':') {
11434 if (!isdigit(*++s)) return 0;
11435 min = *s++ - '0';
11436 if (isdigit(*s)) min = 10*min + *s++ - '0';
11437 if (*s == ':') {
11438 if (!isdigit(*++s)) return 0;
11439 sec = *s++ - '0';
11440 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11441 }
11442 }
11443 } else {
11444 hour = 2;
11445 min = 0;
11446 sec = 0;
11447 }
11448
11449 if (dozjd) {
11450 if (w->tm_yday < d) goto before;
11451 if (w->tm_yday > d) goto after;
11452 } else {
11453 if (w->tm_mon+1 < m) goto before;
11454 if (w->tm_mon+1 > m) goto after;
11455
11456 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
11457 k = d - j; /* mday of first d */
11458 if (k <= 0) k += 7;
11459 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
11460 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11461 if (w->tm_mday < k) goto before;
11462 if (w->tm_mday > k) goto after;
11463 }
11464
11465 if (w->tm_hour < hour) goto before;
11466 if (w->tm_hour > hour) goto after;
11467 if (w->tm_min < min) goto before;
11468 if (w->tm_min > min) goto after;
11469 if (w->tm_sec < sec) goto before;
11470 goto after;
11471
11472before:
11473 *past = 0;
11474 return s;
11475after:
11476 *past = 1;
11477 return s;
11478}
11479
11480
11481
11482
11483/* parse the offset: (+|-)hh[:mm[:ss]] */
11484
11485static char *
11486tz_parse_offset(char *s, int *offset)
11487{
11488 int hour = 0, min = 0, sec = 0;
11489 int neg = 0;
11490 if (!s) return 0;
11491 if (!offset) return 0;
11492
11493 if (*s == '-') {neg++; s++;}
11494 if (*s == '+') s++;
11495 if (!isdigit(*s)) return 0;
11496 hour = *s++ - '0';
11497 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11498 if (hour > 24) return 0;
11499 if (*s == ':') {
11500 if (!isdigit(*++s)) return 0;
11501 min = *s++ - '0';
11502 if (isdigit(*s)) min = min*10 + (*s++ - '0');
11503 if (min > 59) return 0;
11504 if (*s == ':') {
11505 if (!isdigit(*++s)) return 0;
11506 sec = *s++ - '0';
11507 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11508 if (sec > 59) return 0;
11509 }
11510 }
11511
11512 *offset = (hour*60+min)*60 + sec;
11513 if (neg) *offset = -*offset;
11514 return s;
11515}
11516
11517/*
11518 input time is w, whatever type of time the CRTL localtime() uses.
11519 sets dst, the zone, and the gmtoff (seconds)
11520
11521 caches the value of TZ and UCX$TZ env variables; note that
11522 my_setenv looks for these and sets a flag if they're changed
11523 for efficiency.
11524
11525 We have to watch out for the "australian" case (dst starts in
11526 october, ends in april)...flagged by "reverse" and checked by
11527 scanning through the months of the previous year.
11528
11529*/
11530
11531static int
fd8cd3a3 11532tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
22d4bb9c
CB		 11533{
11534 time_t when;
11535 struct tm *w2;
11536 char *s,*s2;
11537 char *dstzone, *tz, *s_start, *s_end;
11538 int std_off, dst_off, isdst;
11539 int y, dststart, dstend;
11540 static char envtz[1025]; /* longer than any logical, symbol, ... */
11541 static char ucxtz[1025];
11542 static char reversed = 0;
11543
11544 if (!w) return 0;
11545
11546 if (tz_updated) {
11547 tz_updated = 0;
11548 reversed = -1; /* flag need to check */
11549 envtz[0] = ucxtz[0] = '\0';
11550 tz = my_getenv("TZ",0);
11551 if (tz) strcpy(envtz, tz);
11552 tz = my_getenv("UCX$TZ",0);
11553 if (tz) strcpy(ucxtz, tz);
11554 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
11555 }
11556 tz = envtz;
11557 if (!*tz) tz = ucxtz;
11558
11559 s = tz;
11560 while (isalpha(*s)) s++;
11561 s = tz_parse_offset(s, &std_off);
11562 if (!s) return 0;
11563 if (!*s) { /* no DST, hurray we're done! */
11564 isdst = 0;
11565 goto done;
11566 }
11567
11568 dstzone = s;
11569 while (isalpha(*s)) s++;
11570 s2 = tz_parse_offset(s, &dst_off);
11571 if (s2) {
11572 s = s2;
11573 } else {
11574 dst_off = std_off - 3600;
11575 }
11576
11577 if (!*s) { /* default dst start/end?? */
11578 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
11579 s = strchr(ucxtz,',');
11580 }
11581 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
11582 }
11583 if (*s != ',') return 0;
11584
11585 when = *w;
11586 when = _toutc(when); /* convert to utc */
11587 when = when - std_off; /* convert to pseudolocal time*/
11588
11589 w2 = localtime(&when);
11590 y = w2->tm_year;
11591 s_start = s+1;
11592 s = tz_parse_startend(s_start,w2,&dststart);
11593 if (!s) return 0;
11594 if (*s != ',') return 0;
11595
11596 when = *w;
11597 when = _toutc(when); /* convert to utc */
11598 when = when - dst_off; /* convert to pseudolocal time*/
11599 w2 = localtime(&when);
11600 if (w2->tm_year != y) { /* spans a year, just check one time */
11601 when += dst_off - std_off;
11602 w2 = localtime(&when);
11603 }
11604 s_end = s+1;
11605 s = tz_parse_startend(s_end,w2,&dstend);
11606 if (!s) return 0;
11607
11608 if (reversed == -1) { /* need to check if start later than end */
11609 int j, ds, de;
11610
11611 when = *w;
11612 if (when < 2*365*86400) {
11613 when += 2*365*86400;
11614 } else {
11615 when -= 365*86400;
11616 }
11617 w2 =localtime(&when);
11618 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
11619
11620 for (j = 0; j < 12; j++) {
11621 w2 =localtime(&when);
f7ddb74a
JM		 11622 tz_parse_startend(s_start,w2,&ds);
11623 tz_parse_startend(s_end,w2,&de);
22d4bb9c
CB		 11624 if (ds != de) break;
11625 when += 30*86400;
11626 }
11627 reversed = 0;
11628 if (de && !ds) reversed = 1;
11629 }
11630
11631 isdst = dststart && !dstend;
11632 if (reversed) isdst = dststart || !dstend;
11633
11634done:
11635 if (dst) *dst = isdst;
11636 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11637 if (isdst) tz = dstzone;
11638 if (zone) {
11639 while(isalpha(*tz)) *zone++ = *tz++;
11640 *zone = '\0';
11641 }
11642 return 1;
11643}
11644
11645#endif /* !RTL_USES_UTC */
61bb5906 11646
ff0cee69 11647/* my_time(), my_localtime(), my_gmtime()
61bb5906 11648 * By default traffic in UTC time values, using CRTL gmtime() or
ff0cee69 11649 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
61bb5906
CB		 11650 * Note: We need to use these functions even when the CRTL has working
11651 * UTC support, since they also handle C<use vmsish qw(times);>
11652 *
ff0cee69 11653 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
bd3fa61c 11654 * Modified by Charles Bailey <bailey@newman.upenn.edu>
ff0cee69 11655 */
11656
11657/*{{{time_t my_time(time_t *timep)*/
fd8cd3a3 11658time_t Perl_my_time(pTHX_ time_t *timep)
e518068a 11659{
e518068a 11660 time_t when;
61bb5906 11661 struct tm *tm_p;
e518068a 11662
11663 if (gmtime_emulation_type == 0) {
61bb5906
CB		 11664 int dstnow;
11665 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11666 /* results of calls to gmtime() and localtime() */
11667 /* for same &base */
ff0cee69 11668
e518068a 11669 gmtime_emulation_type++;
ff0cee69 11670 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
f675dbe5 11671 char off[LNM$C_NAMLENGTH+1];;
ff0cee69 11672
e518068a 11673 gmtime_emulation_type++;
f675dbe5 11674 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
e518068a 11675 gmtime_emulation_type++;
22d4bb9c 11676 utc_offset_secs = 0;
5c84aa53 11677 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
ff0cee69 11678 }
11679 else { utc_offset_secs = atol(off); }
e518068a 11680 }
ff0cee69 11681 else { /* We've got a working gmtime() */
11682 struct tm gmt, local;
e518068a 11683
ff0cee69 11684 gmt = *tm_p;
11685 tm_p = localtime(&base);
11686 local = *tm_p;
11687 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11688 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11689 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11690 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11691 }
e518068a 11692 }
ff0cee69 11693
11694 when = time(NULL);
61bb5906
CB		 11695# ifdef VMSISH_TIME
11696# ifdef RTL_USES_UTC
11697 if (VMSISH_TIME) when = _toloc(when);
11698# else
11699 if (!VMSISH_TIME) when = _toutc(when);
11700# endif
11701# endif
ff0cee69 11702 if (timep != NULL) *timep = when;
11703 return when;
11704
11705} /* end of my_time() */
11706/*}}}*/
11707
11708
11709/*{{{struct tm *my_gmtime(const time_t *timep)*/
11710struct tm *
fd8cd3a3 11711Perl_my_gmtime(pTHX_ const time_t *timep)
ff0cee69 11712{
11713 char *p;
11714 time_t when;
61bb5906 11715 struct tm *rsltmp;
ff0cee69 11716
68dc0745 11717 if (timep == NULL) {
11718 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11719 return NULL;
11720 }
11721 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
ff0cee69 11722
11723 when = *timep;
11724# ifdef VMSISH_TIME
61bb5906
CB		 11725 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11726# endif
11727# ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
11728 return gmtime(&when);
11729# else
ff0cee69 11730 /* CRTL localtime() wants local time as input, so does no tz correction */
61bb5906
CB		 11731 rsltmp = localtime(&when);
11732 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
11733 return rsltmp;
11734#endif
e518068a 11735} /* end of my_gmtime() */
e518068a 11736/*}}}*/
11737
11738
ff0cee69 11739/*{{{struct tm *my_localtime(const time_t *timep)*/
11740struct tm *
fd8cd3a3 11741Perl_my_localtime(pTHX_ const time_t *timep)
ff0cee69 11742{
22d4bb9c 11743 time_t when, whenutc;
61bb5906 11744 struct tm *rsltmp;
22d4bb9c 11745 int dst, offset;
ff0cee69 11746
68dc0745 11747 if (timep == NULL) {
11748 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11749 return NULL;
11750 }
11751 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
f7ddb74a 11752 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
ff0cee69 11753
11754 when = *timep;
61bb5906 11755# ifdef RTL_USES_UTC
ff0cee69 11756# ifdef VMSISH_TIME
61bb5906 11757 if (VMSISH_TIME) when = _toutc(when);
ff0cee69 11758# endif
61bb5906 11759 /* CRTL localtime() wants UTC as input, does tz correction itself */
ff0cee69 11760 return localtime(&when);
22d4bb9c
CB		 11761
11762# else /* !RTL_USES_UTC */
11763 whenutc = when;
61bb5906 11764# ifdef VMSISH_TIME
22d4bb9c
CB		 11765 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
11766 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
61bb5906 11767# endif
22d4bb9c
CB		 11768 dst = -1;
11769#ifndef RTL_USES_UTC
32af7c23 11770 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
22d4bb9c
CB		 11771 when = whenutc - offset; /* pseudolocal time*/
11772 }
61bb5906
CB		 11773# endif
11774 /* CRTL localtime() wants local time as input, so does no tz correction */
11775 rsltmp = localtime(&when);
22d4bb9c 11776 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
61bb5906 11777 return rsltmp;
22d4bb9c 11778# endif
ff0cee69 11779
11780} /* end of my_localtime() */
11781/*}}}*/
11782
11783/* Reset definitions for later calls */
11784#define gmtime(t) my_gmtime(t)
11785#define localtime(t) my_localtime(t)
11786#define time(t) my_time(t)
11787
11788
941b3de1
CB		 11789/* my_utime - update modification/access time of a file
11790 *
11791 * VMS 7.3 and later implementation
11792 * Only the UTC translation is home-grown. The rest is handled by the
11793 * CRTL utime(), which will take into account the relevant feature
11794 * logicals and ODS-5 volume characteristics for true access times.
11795 *
11796 * pre VMS 7.3 implementation:
11797 * The calling sequence is identical to POSIX utime(), but under
11798 * VMS with ODS-2, only the modification time is changed; ODS-2 does
11799 * not maintain access times. Restrictions differ from the POSIX
ff0cee69 11800 * definition in that the time can be changed as long as the
11801 * caller has permission to execute the necessary IO$_MODIFY $QIO;
11802 * no separate checks are made to insure that the caller is the
11803 * owner of the file or has special privs enabled.
11804 * Code here is based on Joe Meadows' FILE utility.
941b3de1 11805 *
ff0cee69 11806 */
11807
11808/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11809 * to VMS epoch (01-JAN-1858 00:00:00.00)
11810 * in 100 ns intervals.
11811 */
11812static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11813
94a11853
CB		 11814/*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11815int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
ff0cee69 11816{
941b3de1
CB		 11817#if __CRTL_VER >= 70300000
11818 struct utimbuf utc_utimes, *utc_utimesp;
11819
11820 if (utimes != NULL) {
11821 utc_utimes.actime = utimes->actime;
11822 utc_utimes.modtime = utimes->modtime;
11823# ifdef VMSISH_TIME
11824 /* If input was local; convert to UTC for sys svc */
11825 if (VMSISH_TIME) {
11826 utc_utimes.actime = _toutc(utimes->actime);
11827 utc_utimes.modtime = _toutc(utimes->modtime);
11828 }
11829# endif
11830 utc_utimesp = &utc_utimes;
11831 }
11832 else {
11833 utc_utimesp = NULL;
11834 }
11835
11836 return utime(file, utc_utimesp);
11837
11838#else /* __CRTL_VER < 70300000 */
11839
ff0cee69 11840 register int i;
f7ddb74a 11841 int sts;
ff0cee69 11842 long int bintime[2], len = 2, lowbit, unixtime,
11843 secscale = 10000000; /* seconds --> 100 ns intervals */
11844 unsigned long int chan, iosb[2], retsts;
11845 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11846 struct FAB myfab = cc$rms_fab;
11847 struct NAM mynam = cc$rms_nam;
11848#if defined (__DECC) && defined (__VAX)
11849 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11850 * at least through VMS V6.1, which causes a type-conversion warning.
11851 */
11852# pragma message save
11853# pragma message disable cvtdiftypes
11854#endif
11855 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11856 struct fibdef myfib;
11857#if defined (__DECC) && defined (__VAX)
11858 /* This should be right after the declaration of myatr, but due
11859 * to a bug in VAX DEC C, this takes effect a statement early.
11860 */
11861# pragma message restore
11862#endif
f7ddb74a 11863 /* cast ok for read only parameter */
ff0cee69 11864 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11865 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11866 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
704c2eb3 11867
ff0cee69 11868 if (file == NULL || *file == '\0') {
941b3de1 11869 SETERRNO(ENOENT, LIB$_INVARG);
ff0cee69 11870 return -1;
11871 }
704c2eb3
JM		 11872
11873 /* Convert to VMS format ensuring that it will fit in 255 characters */
360732b5 11874 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
941b3de1
CB		 11875 SETERRNO(ENOENT, LIB$_INVARG);
11876 return -1;
11877 }
ff0cee69 11878 if (utimes != NULL) {
11879 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
11880 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11881 * Since time_t is unsigned long int, and lib$emul takes a signed long int
11882 * as input, we force the sign bit to be clear by shifting unixtime right
11883 * one bit, then multiplying by an extra factor of 2 in lib$emul().
11884 */
11885 lowbit = (utimes->modtime & 1) ? secscale : 0;
11886 unixtime = (long int) utimes->modtime;
61bb5906
CB		 11887# ifdef VMSISH_TIME
11888 /* If input was UTC; convert to local for sys svc */
11889 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
ff0cee69 11890# endif
1a6334fb 11891 unixtime >>= 1; secscale <<= 1;
ff0cee69 11892 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11893 if (!(retsts & 1)) {
941b3de1 11894 SETERRNO(EVMSERR, retsts);
ff0cee69 11895 return -1;
11896 }
11897 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11898 if (!(retsts & 1)) {
941b3de1 11899 SETERRNO(EVMSERR, retsts);
ff0cee69 11900 return -1;
11901 }
11902 }
11903 else {
11904 /* Just get the current time in VMS format directly */
11905 retsts = sys$gettim(bintime);
11906 if (!(retsts & 1)) {
941b3de1 11907 SETERRNO(EVMSERR, retsts);
ff0cee69 11908 return -1;
11909 }
11910 }
11911
11912 myfab.fab$l_fna = vmsspec;
11913 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11914 myfab.fab$l_nam = &mynam;
11915 mynam.nam$l_esa = esa;
11916 mynam.nam$b_ess = (unsigned char) sizeof esa;
11917 mynam.nam$l_rsa = rsa;
11918 mynam.nam$b_rss = (unsigned char) sizeof rsa;
f7ddb74a
JM		 11919 if (decc_efs_case_preserve)
11920 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
ff0cee69 11921
11922 /* Look for the file to be affected, letting RMS parse the file
11923 * specification for us as well. I have set errno using only
11924 * values documented in the utime() man page for VMS POSIX.
11925 */
11926 retsts = sys$parse(&myfab,0,0);
11927 if (!(retsts & 1)) {
11928 set_vaxc_errno(retsts);
11929 if (retsts == RMS$_PRV) set_errno(EACCES);
11930 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11931 else set_errno(EVMSERR);
11932 return -1;
11933 }
11934 retsts = sys$search(&myfab,0,0);
11935 if (!(retsts & 1)) {
752635ea 11936 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 11937 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 11938 set_vaxc_errno(retsts);
11939 if (retsts == RMS$_PRV) set_errno(EACCES);
11940 else if (retsts == RMS$_FNF) set_errno(ENOENT);
11941 else set_errno(EVMSERR);
11942 return -1;
11943 }
11944
11945 devdsc.dsc$w_length = mynam.nam$b_dev;
f7ddb74a 11946 /* cast ok for read only parameter */
ff0cee69 11947 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11948
11949 retsts = sys$assign(&devdsc,&chan,0,0);
11950 if (!(retsts & 1)) {
752635ea 11951 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 11952 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 11953 set_vaxc_errno(retsts);
11954 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
11955 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
11956 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
11957 else set_errno(EVMSERR);
11958 return -1;
11959 }
11960
11961 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11962 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11963
11964 memset((void *) &myfib, 0, sizeof myfib);
22d4bb9c 11965#if defined(__DECC) || defined(__DECCXX)
ff0cee69 11966 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11967 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11968 /* This prevents the revision time of the file being reset to the current
11969 * time as a result of our IO$_MODIFY $QIO. */
11970 myfib.fib$l_acctl = FIB$M_NORECORD;
11971#else
11972 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11973 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11974 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11975#endif
11976 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
752635ea 11977 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 11978 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 11979 _ckvmssts(sys$dassgn(chan));
11980 if (retsts & 1) retsts = iosb[0];
11981 if (!(retsts & 1)) {
11982 set_vaxc_errno(retsts);
11983 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11984 else set_errno(EVMSERR);
11985 return -1;
11986 }
11987
11988 return 0;
941b3de1
CB		 11989
11990#endif /* #if __CRTL_VER >= 70300000 */
11991
ff0cee69 11992} /* end of my_utime() */
11993/*}}}*/
11994
748a9306 11995/*
2497a41f 11996 * flex_stat, flex_lstat, flex_fstat
748a9306
LW		 11997 * basic stat, but gets it right when asked to stat
11998 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11999 */
12000
2497a41f 12001#ifndef _USE_STD_STAT
748a9306
LW		 12002/* encode_dev packs a VMS device name string into an integer to allow
12003 * simple comparisons. This can be used, for example, to check whether two
12004 * files are located on the same device, by comparing their encoded device
12005 * names. Even a string comparison would not do, because stat() reuses the
12006 * device name buffer for each call; so without encode_dev, it would be
12007 * necessary to save the buffer and use strcmp (this would mean a number of
12008 * changes to the standard Perl code, to say nothing of what a Perl script
12009 * would have to do.
12010 *
12011 * The device lock id, if it exists, should be unique (unless perhaps compared
12012 * with lock ids transferred from other nodes). We have a lock id if the disk is
12013 * mounted cluster-wide, which is when we tend to get long (host-qualified)
12014 * device names. Thus we use the lock id in preference, and only if that isn't
12015 * available, do we try to pack the device name into an integer (flagged by
12016 * the sign bit (LOCKID_MASK) being set).
12017 *
e518068a 12018 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
748a9306
LW		 12019 * name and its encoded form, but it seems very unlikely that we will find
12020 * two files on different disks that share the same encoded device names,
12021 * and even more remote that they will share the same file id (if the test
12022 * is to check for the same file).
12023 *
12024 * A better method might be to use sys$device_scan on the first call, and to
12025 * search for the device, returning an index into the cached array.
cb9e088c 12026 * The number returned would be more intelligible.
748a9306
LW		 12027 * This is probably not worth it, and anyway would take quite a bit longer
12028 * on the first call.
12029 */
12030#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
fd8cd3a3 12031static mydev_t encode_dev (pTHX_ const char *dev)
748a9306
LW		 12032{
12033 int i;
12034 unsigned long int f;
aa689395 12035 mydev_t enc;
748a9306
LW		 12036 char c;
12037 const char *q;
12038
12039 if (!dev || !dev[0]) return 0;
12040
12041#if LOCKID_MASK
12042 {
12043 struct dsc$descriptor_s dev_desc;
cb9e088c 12044 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
748a9306
LW		 12045
12046 /* For cluster-mounted disks, the disk lock identifier is unique, so we
12047 can try that first. */
12048 dev_desc.dsc$w_length = strlen (dev);
12049 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
12050 dev_desc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 12051 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
cb9e088c 12052 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
360732b5 12053 if (!$VMS_STATUS_SUCCESS(status)) {
cb9e088c
CB		 12054 switch (status) {
12055 case SS$_NOSUCHDEV:
12056 SETERRNO(ENODEV, status);
12057 return 0;
12058 default:
12059 _ckvmssts(status);
12060 }
12061 }
748a9306
LW		 12062 if (lockid) return (lockid & ~LOCKID_MASK);
12063 }
a0d0e21e 12064#endif
748a9306
LW		 12065
12066 /* Otherwise we try to encode the device name */
12067 enc = 0;
12068 f = 1;
12069 i = 0;
12070 for (q = dev + strlen(dev); q--; q >= dev) {
988c775c
JM		 12071 if (*q == ':')
12072 break;
748a9306
LW		 12073 if (isdigit (*q))
12074 c= (*q) - '0';
12075 else if (isalpha (toupper (*q)))
12076 c= toupper (*q) - 'A' + (char)10;
12077 else
12078 continue; /* Skip '$'s */
12079 i++;
12080 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
12081 if (i>1) f *= 36;
12082 enc += f * (unsigned long int) c;
12083 }
12084 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
12085
12086} /* end of encode_dev() */
cfcfe586
JM		 12087#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12088 device_no = encode_dev(aTHX_ devname)
12089#else
12090#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12091 device_no = new_dev_no
2497a41f 12092#endif
748a9306 12093
748a9306
LW		 12094static int
12095is_null_device(name)
12096 const char *name;
12097{
2497a41f 12098 if (decc_bug_devnull != 0) {
682e4b71 12099 if (strncmp("/dev/null", name, 9) == 0)
2497a41f
JM		 12100 return 1;
12101 }
748a9306
LW		 12102 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12103 The underscore prefix, controller letter, and unit number are
12104 independently optional; for our purposes, the colon punctuation
12105 is not. The colon can be trailed by optional directory and/or
12106 filename, but two consecutive colons indicates a nodename rather
12107 than a device. [pr] */
12108 if (*name == '_') ++name;
12109 if (tolower(*name++) != 'n') return 0;
12110 if (tolower(*name++) != 'l') return 0;
12111 if (tolower(*name) == 'a') ++name;
12112 if (*name == '0') ++name;
12113 return (*name++ == ':') && (*name != ':');
12114}
12115
c07a80fd 12116
a1887106
JM		 12117static I32
12118Perl_cando_by_name_int
12119 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
748a9306 12120{
e538e23f
CB		 12121 char usrname[L_cuserid];
12122 struct dsc$descriptor_s usrdsc =
748a9306 12123 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
e538e23f 12124 char *vmsname = NULL, *fileified = NULL;
597c27e2 12125 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
2d9f3838 12126 unsigned short int retlen, trnlnm_iter_count;
748a9306
LW		 12127 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12128 union prvdef curprv;
597c27e2
CB		 12129 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12130 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12131 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
ada67d10
CB		 12132 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12133 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12134 {0,0,0,0}};
12135 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
748a9306 12136 {0,0,0,0}};
ada67d10 12137 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
858aded6 12138 Stat_t st;
6151c65c 12139 static int profile_context = -1;
748a9306
LW		 12140
12141 if (!fname || !*fname) return FALSE;
a1887106 12142
e538e23f
CB		 12143 /* Make sure we expand logical names, since sys$check_access doesn't */
12144 fileified = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12145 if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
e538e23f 12146 if (!strpbrk(fname,"/]>:")) {
a1887106
JM		 12147 strcpy(fileified,fname);
12148 trnlnm_iter_count = 0;
e538e23f 12149 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
2d9f3838
CB		 12150 trnlnm_iter_count++;
12151 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
a1887106
JM		 12152 }
12153 fname = fileified;
e538e23f
CB		 12154 }
12155
12156 vmsname = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12157 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
e538e23f
CB		 12158 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12159 /* Don't know if already in VMS format, so make sure */
360732b5 12160 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
a1887106 12161 PerlMem_free(fileified);
e538e23f 12162 PerlMem_free(vmsname);
a1887106
JM		 12163 return FALSE;
12164 }
a1887106
JM		 12165 }
12166 else {
e538e23f 12167 strcpy(vmsname,fname);
a5f75d66
AD		 12168 }
12169
858aded6
CB		 12170 /* sys$check_access needs a file spec, not a directory spec.
12171 * Don't use flex_stat here, as that depends on thread context
12172 * having been initialized, and we may get here during startup.
12173 */
e538e23f
CB		 12174
12175 retlen = namdsc.dsc$w_length = strlen(vmsname);
12176 if (vmsname[retlen-1] == ']'
12177 || vmsname[retlen-1] == '>'
858aded6
CB		 12178 || vmsname[retlen-1] == ':'
12179 || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
e538e23f
CB		 12180
12181 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
12182 PerlMem_free(fileified);
12183 PerlMem_free(vmsname);
12184 return FALSE;
12185 }
12186 fname = fileified;
12187 }
858aded6
CB		 12188 else {
12189 fname = vmsname;
12190 }
e538e23f
CB		 12191
12192 retlen = namdsc.dsc$w_length = strlen(fname);
12193 namdsc.dsc$a_pointer = (char *)fname;
12194
748a9306 12195 switch (bit) {
f282b18d 12196 case S_IXUSR: case S_IXGRP: case S_IXOTH:
360732b5 12197 access = ARM$M_EXECUTE;
597c27e2
CB		 12198 flags = CHP$M_READ;
12199 break;
f282b18d 12200 case S_IRUSR: case S_IRGRP: case S_IROTH:
360732b5 12201 access = ARM$M_READ;
597c27e2
CB		 12202 flags = CHP$M_READ | CHP$M_USEREADALL;
12203 break;
f282b18d 12204 case S_IWUSR: case S_IWGRP: case S_IWOTH:
360732b5 12205 access = ARM$M_WRITE;
597c27e2
CB		 12206 flags = CHP$M_READ | CHP$M_WRITE;
12207 break;
f282b18d 12208 case S_IDUSR: case S_IDGRP: case S_IDOTH:
360732b5 12209 access = ARM$M_DELETE;
597c27e2
CB		 12210 flags = CHP$M_READ | CHP$M_WRITE;
12211 break;
748a9306 12212 default:
a1887106
JM		 12213 if (fileified != NULL)
12214 PerlMem_free(fileified);
e538e23f
CB		 12215 if (vmsname != NULL)
12216 PerlMem_free(vmsname);
748a9306
LW		 12217 return FALSE;
12218 }
12219
ada67d10
CB		 12220 /* Before we call $check_access, create a user profile with the current
12221 * process privs since otherwise it just uses the default privs from the
baf3cf9c
CB		 12222 * UAF and might give false positives or negatives. This only works on
12223 * VMS versions v6.0 and later since that's when sys$create_user_profile
12224 * became available.
ada67d10
CB		 12225 */
12226
12227 /* get current process privs and username */
ebd4d70b
JM		 12228 _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12229 _ckvmssts_noperl(iosb[0]);
ada67d10 12230
baf3cf9c
CB		 12231#if defined(__VMS_VER) && __VMS_VER >= 60000000
12232
ada67d10 12233 /* find out the space required for the profile */
ebd4d70b 12234 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6151c65c 12235 &usrprodsc.dsc$w_length,&profile_context));
ada67d10
CB		 12236
12237 /* allocate space for the profile and get it filled in */
c5375c28 12238 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
ebd4d70b
JM		 12239 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12240 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6151c65c 12241 &usrprodsc.dsc$w_length,&profile_context));
ada67d10
CB		 12242
12243 /* use the profile to check access to the file; free profile & analyze results */
6151c65c 12244 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
c5375c28 12245 PerlMem_free(usrprodsc.dsc$a_pointer);
ada67d10 12246 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
baf3cf9c
CB		 12247
12248#else
12249
12250 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12251
12252#endif
12253
bbce6d69 12254 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
61bb5906 12255 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
22d4bb9c 12256 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
bbce6d69 12257 set_vaxc_errno(retsts);
12258 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12259 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12260 else set_errno(ENOENT);
a1887106
JM		 12261 if (fileified != NULL)
12262 PerlMem_free(fileified);
e538e23f
CB		 12263 if (vmsname != NULL)
12264 PerlMem_free(vmsname);
a3e9d8c9 12265 return FALSE;
12266 }
ada67d10 12267 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
a1887106
JM		 12268 if (fileified != NULL)
12269 PerlMem_free(fileified);
e538e23f
CB		 12270 if (vmsname != NULL)
12271 PerlMem_free(vmsname);
3a385817
GS		 12272 return TRUE;
12273 }
ebd4d70b 12274 _ckvmssts_noperl(retsts);
748a9306 12275
a1887106
JM		 12276 if (fileified != NULL)
12277 PerlMem_free(fileified);
e538e23f
CB		 12278 if (vmsname != NULL)
12279 PerlMem_free(vmsname);
748a9306
LW		 12280 return FALSE; /* Should never get here */
12281
a1887106
JM		 12282}
12283
12284/* Do the permissions allow some operation? Assumes PL_statcache already set. */
12285/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12286 * subset of the applicable information.
12287 */
12288bool
12289Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12290{
12291 return cando_by_name_int
12292 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12293} /* end of cando() */
12294/*}}}*/
12295
12296
12297/*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12298I32
12299Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12300{
12301 return cando_by_name_int(bit, effective, fname, 0);
12302
748a9306
LW		 12303} /* end of cando_by_name() */
12304/*}}}*/
12305
12306
61bb5906 12307/*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
748a9306 12308int
fd8cd3a3 12309Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
748a9306 12310{
b7ae7a0d 12311 if (!fstat(fd,(stat_t *) statbufp)) {
75796008 12312 char *cptr;
988c775c
JM		 12313 char *vms_filename;
12314 vms_filename = PerlMem_malloc(VMS_MAXRSS);
12315 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
75796008 12316
988c775c
JM		 12317 /* Save name for cando by name in VMS format */
12318 cptr = getname(fd, vms_filename, 1);
75796008 12319
988c775c
JM		 12320 /* This should not happen, but just in case */
12321 if (cptr == NULL) {
12322 statbufp->st_devnam[0] = 0;
12323 }
12324 else {
12325 /* Make sure that the saved name fits in 255 characters */
12326 cptr = do_rmsexpand
12327 (vms_filename,
12328 statbufp->st_devnam,
12329 0,
12330 NULL,
360732b5
JM		 12331 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
12332 NULL,
12333 NULL);
75796008 12334 if (cptr == NULL)
988c775c 12335 statbufp->st_devnam[0] = 0;
75796008 12336 }
988c775c 12337 PerlMem_free(vms_filename);
682e4b71
JM		 12338
12339 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 12340 VMS_DEVICE_ENCODE
12341 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
2497a41f 12342
61bb5906
CB		 12343# ifdef RTL_USES_UTC
12344# ifdef VMSISH_TIME
12345 if (VMSISH_TIME) {
12346 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12347 statbufp->st_atime = _toloc(statbufp->st_atime);
12348 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12349 }
12350# endif
12351# else
ff0cee69 12352# ifdef VMSISH_TIME
12353 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12354# else
12355 if (1) {
12356# endif
61bb5906
CB		 12357 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12358 statbufp->st_atime = _toutc(statbufp->st_atime);
12359 statbufp->st_ctime = _toutc(statbufp->st_ctime);
ff0cee69 12360 }
61bb5906 12361#endif
b7ae7a0d 12362 return 0;
12363 }
12364 return -1;
748a9306
LW		 12365
12366} /* end of flex_fstat() */
12367/*}}}*/
12368
2497a41f
JM		 12369#if !defined(__VAX) && __CRTL_VER >= 80200000
12370#ifdef lstat
12371#undef lstat
12372#endif
12373#else
12374#ifdef lstat
12375#undef lstat
12376#endif
12377#define lstat(_x, _y) stat(_x, _y)
12378#endif
12379
7ded3206
CB		 12380#define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
12381
2497a41f
JM		 12382static int
12383Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
748a9306 12384{
988c775c
JM		 12385 char fileified[VMS_MAXRSS];
12386 char temp_fspec[VMS_MAXRSS];
12387 char *save_spec;
bbce6d69 12388 int retval = -1;
4ee39169 12389 dSAVEDERRNO;
748a9306 12390
e956e27a 12391 if (!fspec) return retval;
4ee39169 12392 SAVE_ERRNO;
cc077a9f 12393 strcpy(temp_fspec, fspec);
988c775c 12394
2497a41f
JM		 12395 if (decc_bug_devnull != 0) {
12396 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
12397 memset(statbufp,0,sizeof *statbufp);
cfcfe586 12398 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
2497a41f
JM		 12399 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12400 statbufp->st_uid = 0x00010001;
12401 statbufp->st_gid = 0x0001;
12402 time((time_t *)&statbufp->st_mtime);
12403 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12404 return 0;
12405 }
748a9306
LW		 12406 }
12407
bbce6d69 12408 /* Try for a directory name first. If fspec contains a filename without
61bb5906 12409 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
bbce6d69 12410 * and sea:[wine.dark]water. exist, we prefer the directory here.
12411 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12412 * not sea:[wine.dark]., if the latter exists. If the intended target is
12413 * the file with null type, specify this by calling flex_stat() with
12414 * a '.' at the end of fspec.
2497a41f
JM		 12415 *
12416 * If we are in Posix filespec mode, accept the filename as is.
bbce6d69 12417 */
f36b279d
CB		 12418
12419
12420#if __CRTL_VER >= 70300000 && !defined(__VAX)
12421 /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
12422 * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
12423 */
12424 if (!decc_efs_charset)
12425 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
12426#endif
12427
2497a41f
JM		 12428#if __CRTL_VER >= 80200000 && !defined(__VAX)
12429 if (decc_posix_compliant_pathnames == 0) {
12430#endif
360732b5 12431 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
2497a41f
JM		 12432 if (lstat_flag == 0)
12433 retval = stat(fileified,(stat_t *) statbufp);
12434 else
12435 retval = lstat(fileified,(stat_t *) statbufp);
988c775c 12436 save_spec = fileified;
748a9306 12437 }
2497a41f
JM		 12438 if (retval) {
12439 if (lstat_flag == 0)
12440 retval = stat(temp_fspec,(stat_t *) statbufp);
12441 else
12442 retval = lstat(temp_fspec,(stat_t *) statbufp);
988c775c 12443 save_spec = temp_fspec;
2497a41f 12444 }
f1db9cda
JM		 12445/*
12446 * In debugging, on 8.3 Alpha, I found a case where stat was returning a
12447 * file not found error for a directory named foo:[bar.t] or /foo/bar/t
12448 * and lstat was working correctly for the same file.
12449 * The only syntax that was working for stat was "foo:[bar]t.dir".
12450 *
12451 * Other directories with the same syntax worked fine.
12452 * So work around the problem when it shows up here.
12453 */
12454 if (retval) {
12455 int save_errno = errno;
12456 if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
12457 if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
12458 retval = stat(fileified, (stat_t *) statbufp);
12459 save_spec = fileified;
12460 }
12461 }
12462 /* Restore the errno value if third stat does not succeed */
12463 if (retval != 0)
12464 errno = save_errno;
12465 }
2497a41f
JM		 12466#if __CRTL_VER >= 80200000 && !defined(__VAX)
12467 } else {
12468 if (lstat_flag == 0)
12469 retval = stat(temp_fspec,(stat_t *) statbufp);
12470 else
12471 retval = lstat(temp_fspec,(stat_t *) statbufp);
988c775c 12472 save_spec = temp_fspec;
2497a41f
JM		 12473 }
12474#endif
f36b279d
CB		 12475
12476#if __CRTL_VER >= 70300000 && !defined(__VAX)
12477 /* As you were... */
12478 if (!decc_efs_charset)
12479 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12480#endif
12481
ff0cee69 12482 if (!retval) {
988c775c 12483 char * cptr;
d584a1c6
JM		 12484 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12485
12486 /* If this is an lstat, do not follow the link */
12487 if (lstat_flag)
12488 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12489
988c775c 12490 cptr = do_rmsexpand
d584a1c6 12491 (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
988c775c
JM		 12492 if (cptr == NULL)
12493 statbufp->st_devnam[0] = 0;
12494
682e4b71 12495 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 12496 VMS_DEVICE_ENCODE
12497 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
61bb5906
CB		 12498# ifdef RTL_USES_UTC
12499# ifdef VMSISH_TIME
12500 if (VMSISH_TIME) {
12501 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12502 statbufp->st_atime = _toloc(statbufp->st_atime);
12503 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12504 }
12505# endif
12506# else
ff0cee69 12507# ifdef VMSISH_TIME
12508 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12509# else
12510 if (1) {
12511# endif
61bb5906
CB		 12512 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12513 statbufp->st_atime = _toutc(statbufp->st_atime);
12514 statbufp->st_ctime = _toutc(statbufp->st_ctime);
ff0cee69 12515 }
61bb5906 12516# endif
ff0cee69 12517 }
9543c6b6 12518 /* If we were successful, leave errno where we found it */
4ee39169 12519 if (retval == 0) RESTORE_ERRNO;
748a9306
LW		 12520 return retval;
12521
2497a41f
JM		 12522} /* end of flex_stat_int() */
12523
12524
12525/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12526int
12527Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12528{
7ded3206 12529 return flex_stat_int(fspec, statbufp, 0);
2497a41f
JM		 12530}
12531/*}}}*/
12532
12533/*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12534int
12535Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12536{
7ded3206 12537 return flex_stat_int(fspec, statbufp, 1);
2497a41f 12538}
748a9306
LW		 12539/*}}}*/
12540
b7ae7a0d 12541
c07a80fd 12542/*{{{char *my_getlogin()*/
12543/* VMS cuserid == Unix getlogin, except calling sequence */
12544char *
2fbb330f 12545my_getlogin(void)
c07a80fd 12546{
12547 static char user[L_cuserid];
12548 return cuserid(user);
12549}
12550/*}}}*/
12551
12552
a5f75d66
AD		 12553/* rmscopy - copy a file using VMS RMS routines
12554 *
12555 * Copies contents and attributes of spec_in to spec_out, except owner
12556 * and protection information. Name and type of spec_in are used as
a3e9d8c9 12557 * defaults for spec_out. The third parameter specifies whether rmscopy()
12558 * should try to propagate timestamps from the input file to the output file.
12559 * If it is less than 0, no timestamps are preserved. If it is 0, then
12560 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12561 * propagated to the output file at creation iff the output file specification
12562 * did not contain an explicit name or type, and the revision date is always
12563 * updated at the end of the copy operation. If it is greater than 0, then
12564 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12565 * other than the revision date should be propagated, and bit 1 indicates
12566 * that the revision date should be propagated.
12567 *
12568 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
a5f75d66 12569 *
bd3fa61c 12570 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
a5f75d66 12571 * Incorporates, with permission, some code from EZCOPY by Tim Adye
01b8edb6 12572 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12573 * as part of the Perl standard distribution under the terms of the
12574 * GNU General Public License or the Perl Artistic License. Copies
12575 * of each may be found in the Perl standard distribution.
a480973c 12576 */ /* FIXME */
a3e9d8c9 12577/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
a480973c
JM		 12578int
12579Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12580{
d584a1c6
JM		 12581 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12582 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
a480973c 12583 unsigned long int i, sts, sts2;
a1887106 12584 int dna_len;
a480973c
JM		 12585 struct FAB fab_in, fab_out;
12586 struct RAB rab_in, rab_out;
a1887106
JM		 12587 rms_setup_nam(nam);
12588 rms_setup_nam(nam_out);
a480973c
JM		 12589 struct XABDAT xabdat;
12590 struct XABFHC xabfhc;
12591 struct XABRDT xabrdt;
12592 struct XABSUM xabsum;
12593
c5375c28 12594 vmsin = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12595 if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 12596 vmsout = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12597 if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
df278665
JM		 12598 if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12599 !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
c5375c28
JM		 12600 PerlMem_free(vmsin);
12601 PerlMem_free(vmsout);
a480973c
JM		 12602 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12603 return 0;
12604 }
12605
b1a8dcd7 12606 esa = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12607 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12608 esal = NULL;
12609#if !defined(__VAX) && defined(NAML$C_MAXRSS)
12610 esal = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12611 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 12612#endif
a480973c 12613 fab_in = cc$rms_fab;
a1887106 12614 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
a480973c
JM		 12615 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12616 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12617 fab_in.fab$l_fop = FAB$M_SQO;
a1887106 12618 rms_bind_fab_nam(fab_in, nam);
a480973c
JM		 12619 fab_in.fab$l_xab = (void *) &xabdat;
12620
b1a8dcd7 12621 rsa = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12622 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12623 rsal = NULL;
12624#if !defined(__VAX) && defined(NAML$C_MAXRSS)
12625 rsal = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12626 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12627#endif
12628 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12629 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
a1887106
JM		 12630 rms_nam_esl(nam) = 0;
12631 rms_nam_rsl(nam) = 0;
12632 rms_nam_esll(nam) = 0;
12633 rms_nam_rsll(nam) = 0;
a480973c
JM		 12634#ifdef NAM$M_NO_SHORT_UPCASE
12635 if (decc_efs_case_preserve)
a1887106 12636 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
a480973c
JM		 12637#endif
12638
12639 xabdat = cc$rms_xabdat; /* To get creation date */
12640 xabdat.xab$l_nxt = (void *) &xabfhc;
12641
12642 xabfhc = cc$rms_xabfhc; /* To get record length */
12643 xabfhc.xab$l_nxt = (void *) &xabsum;
12644
12645 xabsum = cc$rms_xabsum; /* To get key and area information */
12646
12647 if (!((sts = sys$open(&fab_in)) & 1)) {
c5375c28
JM		 12648 PerlMem_free(vmsin);
12649 PerlMem_free(vmsout);
12650 PerlMem_free(esa);
d584a1c6
JM		 12651 if (esal != NULL)
12652 PerlMem_free(esal);
c5375c28 12653 PerlMem_free(rsa);
d584a1c6
JM		 12654 if (rsal != NULL)
12655 PerlMem_free(rsal);
a480973c
JM		 12656 set_vaxc_errno(sts);
12657 switch (sts) {
12658 case RMS$_FNF: case RMS$_DNF:
12659 set_errno(ENOENT); break;
12660 case RMS$_DIR:
12661 set_errno(ENOTDIR); break;
12662 case RMS$_DEV:
12663 set_errno(ENODEV); break;
12664 case RMS$_SYN:
12665 set_errno(EINVAL); break;
12666 case RMS$_PRV:
12667 set_errno(EACCES); break;
12668 default:
12669 set_errno(EVMSERR);
12670 }
12671 return 0;
12672 }
12673
12674 nam_out = nam;
12675 fab_out = fab_in;
12676 fab_out.fab$w_ifi = 0;
12677 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12678 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12679 fab_out.fab$l_fop = FAB$M_SQO;
a1887106
JM		 12680 rms_bind_fab_nam(fab_out, nam_out);
12681 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12682 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12683 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
d584a1c6 12684 esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 12685 if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 12686 rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 12687 if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12688 esal_out = NULL;
12689 rsal_out = NULL;
12690#if !defined(__VAX) && defined(NAML$C_MAXRSS)
12691 esal_out = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12692 if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 12693 rsal_out = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12694 if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12695#endif
12696 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12697 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
a480973c
JM		 12698
12699 if (preserve_dates == 0) { /* Act like DCL COPY */
a1887106 12700 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
a480973c 12701 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
a1887106 12702 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 12703 PerlMem_free(vmsin);
12704 PerlMem_free(vmsout);
12705 PerlMem_free(esa);
d584a1c6
JM		 12706 if (esal != NULL)
12707 PerlMem_free(esal);
c5375c28 12708 PerlMem_free(rsa);
d584a1c6
JM		 12709 if (rsal != NULL)
12710 PerlMem_free(rsal);
c5375c28 12711 PerlMem_free(esa_out);
d584a1c6
JM		 12712 if (esal_out != NULL)
12713 PerlMem_free(esal_out);
12714 PerlMem_free(rsa_out);
12715 if (rsal_out != NULL)
12716 PerlMem_free(rsal_out);
a480973c
JM		 12717 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12718 set_vaxc_errno(sts);
12719 return 0;
12720 }
12721 fab_out.fab$l_xab = (void *) &xabdat;
a1887106
JM		 12722 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12723 preserve_dates = 1;
a480973c
JM		 12724 }
12725 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12726 preserve_dates =0; /* bitmask from this point forward */
12727
12728 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
a1887106 12729 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 12730 PerlMem_free(vmsin);
12731 PerlMem_free(vmsout);
12732 PerlMem_free(esa);
d584a1c6
JM		 12733 if (esal != NULL)
12734 PerlMem_free(esal);
c5375c28 12735 PerlMem_free(rsa);
d584a1c6
JM		 12736 if (rsal != NULL)
12737 PerlMem_free(rsal);
c5375c28 12738 PerlMem_free(esa_out);
d584a1c6
JM		 12739 if (esal_out != NULL)
12740 PerlMem_free(esal_out);
12741 PerlMem_free(rsa_out);
12742 if (rsal_out != NULL)
12743 PerlMem_free(rsal_out);
a480973c
JM		 12744 set_vaxc_errno(sts);
12745 switch (sts) {
12746 case RMS$_DNF:
12747 set_errno(ENOENT); break;
12748 case RMS$_DIR:
12749 set_errno(ENOTDIR); break;
12750 case RMS$_DEV:
12751 set_errno(ENODEV); break;
12752 case RMS$_SYN:
12753 set_errno(EINVAL); break;
12754 case RMS$_PRV:
12755 set_errno(EACCES); break;
12756 default:
12757 set_errno(EVMSERR);
12758 }
12759 return 0;
12760 }
12761 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12762 if (preserve_dates & 2) {
12763 /* sys$close() will process xabrdt, not xabdat */
12764 xabrdt = cc$rms_xabrdt;
12765#ifndef __GNUC__
12766 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12767#else
12768 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12769 * is unsigned long[2], while DECC & VAXC use a struct */
12770 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12771#endif
12772 fab_out.fab$l_xab = (void *) &xabrdt;
12773 }
12774
c5375c28 12775 ubf = PerlMem_malloc(32256);
ebd4d70b 12776 if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c
JM		 12777 rab_in = cc$rms_rab;
12778 rab_in.rab$l_fab = &fab_in;
12779 rab_in.rab$l_rop = RAB$M_BIO;
12780 rab_in.rab$l_ubf = ubf;
12781 rab_in.rab$w_usz = 32256;
12782 if (!((sts = sys$connect(&rab_in)) & 1)) {
12783 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12784 PerlMem_free(vmsin);
12785 PerlMem_free(vmsout);
c5375c28 12786 PerlMem_free(ubf);
d584a1c6
JM		 12787 PerlMem_free(esa);
12788 if (esal != NULL)
12789 PerlMem_free(esal);
c5375c28 12790 PerlMem_free(rsa);
d584a1c6
JM		 12791 if (rsal != NULL)
12792 PerlMem_free(rsal);
c5375c28 12793 PerlMem_free(esa_out);
d584a1c6
JM		 12794 if (esal_out != NULL)
12795 PerlMem_free(esal_out);
12796 PerlMem_free(rsa_out);
12797 if (rsal_out != NULL)
12798 PerlMem_free(rsal_out);
a480973c
JM		 12799 set_errno(EVMSERR); set_vaxc_errno(sts);
12800 return 0;
12801 }
12802
12803 rab_out = cc$rms_rab;
12804 rab_out.rab$l_fab = &fab_out;
12805 rab_out.rab$l_rbf = ubf;
12806 if (!((sts = sys$connect(&rab_out)) & 1)) {
12807 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12808 PerlMem_free(vmsin);
12809 PerlMem_free(vmsout);
c5375c28 12810 PerlMem_free(ubf);
d584a1c6
JM		 12811 PerlMem_free(esa);
12812 if (esal != NULL)
12813 PerlMem_free(esal);
c5375c28 12814 PerlMem_free(rsa);
d584a1c6
JM		 12815 if (rsal != NULL)
12816 PerlMem_free(rsal);
c5375c28 12817 PerlMem_free(esa_out);
d584a1c6
JM		 12818 if (esal_out != NULL)
12819 PerlMem_free(esal_out);
12820 PerlMem_free(rsa_out);
12821 if (rsal_out != NULL)
12822 PerlMem_free(rsal_out);
a480973c
JM		 12823 set_errno(EVMSERR); set_vaxc_errno(sts);
12824 return 0;
12825 }
12826
12827 while ((sts = sys$read(&rab_in))) { /* always true */
12828 if (sts == RMS$_EOF) break;
12829 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12830 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12831 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12832 PerlMem_free(vmsin);
12833 PerlMem_free(vmsout);
c5375c28 12834 PerlMem_free(ubf);
d584a1c6
JM		 12835 PerlMem_free(esa);
12836 if (esal != NULL)
12837 PerlMem_free(esal);
c5375c28 12838 PerlMem_free(rsa);
d584a1c6
JM		 12839 if (rsal != NULL)
12840 PerlMem_free(rsal);
c5375c28 12841 PerlMem_free(esa_out);
d584a1c6
JM		 12842 if (esal_out != NULL)
12843 PerlMem_free(esal_out);
12844 PerlMem_free(rsa_out);
12845 if (rsal_out != NULL)
12846 PerlMem_free(rsal_out);
a480973c
JM		 12847 set_errno(EVMSERR); set_vaxc_errno(sts);
12848 return 0;
12849 }
12850 }
12851
12852
12853 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12854 sys$close(&fab_in); sys$close(&fab_out);
12855 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
a480973c 12856
c5375c28
JM		 12857 PerlMem_free(vmsin);
12858 PerlMem_free(vmsout);
c5375c28 12859 PerlMem_free(ubf);
d584a1c6
JM		 12860 PerlMem_free(esa);
12861 if (esal != NULL)
12862 PerlMem_free(esal);
c5375c28 12863 PerlMem_free(rsa);
d584a1c6
JM		 12864 if (rsal != NULL)
12865 PerlMem_free(rsal);
c5375c28 12866 PerlMem_free(esa_out);
d584a1c6
JM		 12867 if (esal_out != NULL)
12868 PerlMem_free(esal_out);
12869 PerlMem_free(rsa_out);
12870 if (rsal_out != NULL)
12871 PerlMem_free(rsal_out);
12872
12873 if (!(sts & 1)) {
12874 set_errno(EVMSERR); set_vaxc_errno(sts);
12875 return 0;
12876 }
12877
a480973c
JM		 12878 return 1;
12879
12880} /* end of rmscopy() */
a5f75d66
AD		 12881/*}}}*/
12882
12883
748a9306
LW		 12884/*** The following glue provides 'hooks' to make some of the routines
12885 * from this file available from Perl. These routines are sufficiently
12886 * basic, and are required sufficiently early in the build process,
12887 * that's it's nice to have them available to miniperl as well as the
12888 * full Perl, so they're set up here instead of in an extension. The
12889 * Perl code which handles importation of these names into a given
12890 * package lives in [.VMS]Filespec.pm in @INC.
12891 */
12892
12893void
5c84aa53 12894rmsexpand_fromperl(pTHX_ CV *cv)
01b8edb6 12895{
12896 dXSARGS;
bbce6d69 12897 char *fspec, *defspec = NULL, *rslt;
2d8e6c8d 12898 STRLEN n_a;
360732b5 12899 int fs_utf8, dfs_utf8;
01b8edb6 12900
360732b5
JM		 12901 fs_utf8 = 0;
12902 dfs_utf8 = 0;
bbce6d69 12903 if (!items || items > 2)
5c84aa53 12904 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
2d8e6c8d 12905 fspec = SvPV(ST(0),n_a);
360732b5 12906 fs_utf8 = SvUTF8(ST(0));
bbce6d69 12907 if (!fspec || !*fspec) XSRETURN_UNDEF;
360732b5
JM		 12908 if (items == 2) {
12909 defspec = SvPV(ST(1),n_a);
12910 dfs_utf8 = SvUTF8(ST(1));
12911 }
12912 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
bbce6d69 12913 ST(0) = sv_newmortal();
360732b5
JM		 12914 if (rslt != NULL) {
12915 sv_usepvn(ST(0),rslt,strlen(rslt));
12916 if (fs_utf8) {
12917 SvUTF8_on(ST(0));
12918 }
12919 }
740ce14c 12920 XSRETURN(1);
01b8edb6 12921}
12922
12923void
5c84aa53 12924vmsify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12925{
12926 dXSARGS;
12927 char *vmsified;
2d8e6c8d 12928 STRLEN n_a;
360732b5 12929 int utf8_fl;
748a9306 12930
5c84aa53 12931 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
360732b5
JM		 12932 utf8_fl = SvUTF8(ST(0));
12933 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12934 ST(0) = sv_newmortal();
360732b5
JM		 12935 if (vmsified != NULL) {
12936 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12937 if (utf8_fl) {
12938 SvUTF8_on(ST(0));
12939 }
12940 }
748a9306
LW		 12941 XSRETURN(1);
12942}
12943
12944void
5c84aa53 12945unixify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12946{
12947 dXSARGS;
12948 char *unixified;
2d8e6c8d 12949 STRLEN n_a;
360732b5 12950 int utf8_fl;
748a9306 12951
5c84aa53 12952 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
360732b5
JM		 12953 utf8_fl = SvUTF8(ST(0));
12954 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12955 ST(0) = sv_newmortal();
360732b5
JM		 12956 if (unixified != NULL) {
12957 sv_usepvn(ST(0),unixified,strlen(unixified));
12958 if (utf8_fl) {
12959 SvUTF8_on(ST(0));
12960 }
12961 }
748a9306
LW		 12962 XSRETURN(1);
12963}
12964
12965void
5c84aa53 12966fileify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12967{
12968 dXSARGS;
12969 char *fileified;
2d8e6c8d 12970 STRLEN n_a;
360732b5 12971 int utf8_fl;
748a9306 12972
5c84aa53 12973 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
360732b5
JM		 12974 utf8_fl = SvUTF8(ST(0));
12975 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12976 ST(0) = sv_newmortal();
360732b5
JM		 12977 if (fileified != NULL) {
12978 sv_usepvn(ST(0),fileified,strlen(fileified));
12979 if (utf8_fl) {
12980 SvUTF8_on(ST(0));
12981 }
12982 }
748a9306
LW		 12983 XSRETURN(1);
12984}
12985
12986void
5c84aa53 12987pathify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12988{
12989 dXSARGS;
12990 char *pathified;
2d8e6c8d 12991 STRLEN n_a;
360732b5 12992 int utf8_fl;
748a9306 12993
5c84aa53 12994 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
360732b5
JM		 12995 utf8_fl = SvUTF8(ST(0));
12996 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12997 ST(0) = sv_newmortal();
360732b5
JM		 12998 if (pathified != NULL) {
12999 sv_usepvn(ST(0),pathified,strlen(pathified));
13000 if (utf8_fl) {
13001 SvUTF8_on(ST(0));
13002 }
13003 }
748a9306
LW		 13004 XSRETURN(1);
13005}
13006
13007void
5c84aa53 13008vmspath_fromperl(pTHX_ CV *cv)
748a9306
LW		 13009{
13010 dXSARGS;
13011 char *vmspath;
2d8e6c8d 13012 STRLEN n_a;
360732b5 13013 int utf8_fl;
748a9306 13014
5c84aa53 13015 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
360732b5
JM		 13016 utf8_fl = SvUTF8(ST(0));
13017 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 13018 ST(0) = sv_newmortal();
360732b5
JM		 13019 if (vmspath != NULL) {
13020 sv_usepvn(ST(0),vmspath,strlen(vmspath));
13021 if (utf8_fl) {
13022 SvUTF8_on(ST(0));
13023 }
13024 }
748a9306
LW		 13025 XSRETURN(1);
13026}
13027
13028void
5c84aa53 13029unixpath_fromperl(pTHX_ CV *cv)
748a9306
LW		 13030{
13031 dXSARGS;
13032 char *unixpath;
2d8e6c8d 13033 STRLEN n_a;
360732b5 13034 int utf8_fl;
748a9306 13035
5c84aa53 13036 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
360732b5
JM		 13037 utf8_fl = SvUTF8(ST(0));
13038 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 13039 ST(0) = sv_newmortal();
360732b5
JM		 13040 if (unixpath != NULL) {
13041 sv_usepvn(ST(0),unixpath,strlen(unixpath));
13042 if (utf8_fl) {
13043 SvUTF8_on(ST(0));
13044 }
13045 }
748a9306
LW		 13046 XSRETURN(1);
13047}
13048
13049void
5c84aa53 13050candelete_fromperl(pTHX_ CV *cv)
748a9306
LW		 13051{
13052 dXSARGS;
988c775c 13053 char *fspec, *fsp;
a5f75d66
AD		 13054 SV *mysv;
13055 IO *io;
2d8e6c8d 13056 STRLEN n_a;
748a9306 13057
5c84aa53 13058 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
a5f75d66
AD		 13059
13060 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
988c775c
JM		 13061 Newx(fspec, VMS_MAXRSS, char);
13062 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
a5f75d66 13063 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 13064 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
a5f75d66 13065 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 13066 ST(0) = &PL_sv_no;
988c775c 13067 Safefree(fspec);
a5f75d66
AD		 13068 XSRETURN(1);
13069 }
13070 fsp = fspec;
13071 }
13072 else {
2d8e6c8d 13073 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
a5f75d66 13074 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 13075 ST(0) = &PL_sv_no;
988c775c 13076 Safefree(fspec);
a5f75d66
AD		 13077 XSRETURN(1);
13078 }
13079 }
13080
54310121 13081 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
988c775c 13082 Safefree(fspec);
a5f75d66
AD		 13083 XSRETURN(1);
13084}
13085
13086void
5c84aa53 13087rmscopy_fromperl(pTHX_ CV *cv)
a5f75d66
AD		 13088{
13089 dXSARGS;
a480973c 13090 char *inspec, *outspec, *inp, *outp;
a3e9d8c9 13091 int date_flag;
a5f75d66
AD		 13092 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13093 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13094 unsigned long int sts;
13095 SV *mysv;
13096 IO *io;
2d8e6c8d 13097 STRLEN n_a;
a5f75d66 13098
a3e9d8c9 13099 if (items < 2 || items > 3)
5c84aa53 13100 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
a5f75d66
AD		 13101
13102 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
a480973c 13103 Newx(inspec, VMS_MAXRSS, char);
a5f75d66 13104 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 13105 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
a5f75d66 13106 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 13107 ST(0) = &PL_sv_no;
a480973c 13108 Safefree(inspec);
a5f75d66
AD		 13109 XSRETURN(1);
13110 }
13111 inp = inspec;
13112 }
13113 else {
2d8e6c8d 13114 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
a5f75d66 13115 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 13116 ST(0) = &PL_sv_no;
a480973c 13117 Safefree(inspec);
a5f75d66
AD		 13118 XSRETURN(1);
13119 }
13120 }
13121 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
a480973c 13122 Newx(outspec, VMS_MAXRSS, char);
a5f75d66 13123 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 13124 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
a5f75d66 13125 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 13126 ST(0) = &PL_sv_no;
a480973c
JM		 13127 Safefree(inspec);
13128 Safefree(outspec);
a5f75d66
AD		 13129 XSRETURN(1);
13130 }
13131 outp = outspec;
13132 }
13133 else {
2d8e6c8d 13134 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
a5f75d66 13135 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 13136 ST(0) = &PL_sv_no;
a480973c
JM		 13137 Safefree(inspec);
13138 Safefree(outspec);
a5f75d66
AD		 13139 XSRETURN(1);
13140 }
13141 }
a3e9d8c9 13142 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
a5f75d66 13143
54310121 13144 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
a480973c
JM		 13145 Safefree(inspec);
13146 Safefree(outspec);
748a9306
LW		 13147 XSRETURN(1);
13148}
13149
a480973c
JM		 13150/* The mod2fname is limited to shorter filenames by design, so it should
13151 * not be modified to support longer EFS pathnames
13152 */
4b19af01 13153void
fd8cd3a3 13154mod2fname(pTHX_ CV *cv)
4b19af01
CB		 13155{
13156 dXSARGS;
13157 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13158 workbuff[NAM$C_MAXRSS*1 + 1];
13159 int total_namelen = 3, counter, num_entries;
13160 /* ODS-5 ups this, but we want to be consistent, so... */
13161 int max_name_len = 39;
13162 AV *in_array = (AV *)SvRV(ST(0));
13163
13164 num_entries = av_len(in_array);
13165
13166 /* All the names start with PL_. */
13167 strcpy(ultimate_name, "PL_");
13168
13169 /* Clean up our working buffer */
13170 Zero(work_name, sizeof(work_name), char);
13171
13172 /* Run through the entries and build up a working name */
13173 for(counter = 0; counter <= num_entries; counter++) {
13174 /* If it's not the first name then tack on a __ */
13175 if (counter) {
13176 strcat(work_name, "__");
13177 }
bfd025d9 13178 strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
4b19af01
CB		 13179 }
13180
13181 /* Check to see if we actually have to bother...*/
13182 if (strlen(work_name) + 3 <= max_name_len) {
13183 strcat(ultimate_name, work_name);
13184 } else {
13185 /* It's too darned big, so we need to go strip. We use the same */
13186 /* algorithm as xsubpp does. First, strip out doubled __ */
13187 char *source, *dest, last;
13188 dest = workbuff;
13189 last = 0;
13190 for (source = work_name; *source; source++) {
13191 if (last == *source && last == '_') {
13192 continue;
13193 }
13194 *dest++ = *source;
13195 last = *source;
13196 }
13197 /* Go put it back */
13198 strcpy(work_name, workbuff);
13199 /* Is it still too big? */
13200 if (strlen(work_name) + 3 > max_name_len) {
13201 /* Strip duplicate letters */
13202 last = 0;
13203 dest = workbuff;
13204 for (source = work_name; *source; source++) {
13205 if (last == toupper(*source)) {
13206 continue;
13207 }
13208 *dest++ = *source;
13209 last = toupper(*source);
13210 }
13211 strcpy(work_name, workbuff);
13212 }
13213
13214 /* Is it *still* too big? */
13215 if (strlen(work_name) + 3 > max_name_len) {
13216 /* Too bad, we truncate */
13217 work_name[max_name_len - 2] = 0;
13218 }
13219 strcat(ultimate_name, work_name);
13220 }
13221
13222 /* Okay, return it */
13223 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13224 XSRETURN(1);
13225}
13226
748a9306 13227void
96e176bf
CL		 13228hushexit_fromperl(pTHX_ CV *cv)
13229{
13230 dXSARGS;
13231
13232 if (items > 0) {
13233 VMSISH_HUSHED = SvTRUE(ST(0));
13234 }
13235 ST(0) = boolSV(VMSISH_HUSHED);
13236 XSRETURN(1);
13237}
13238
dca5a913
JM		 13239
13240PerlIO *
13241Perl_vms_start_glob
13242 (pTHX_ SV *tmpglob,
13243 IO *io)
13244{
13245 PerlIO *fp;
13246 struct vs_str_st *rslt;
13247 char *vmsspec;
13248 char *rstr;
13249 char *begin, *cp;
13250 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13251 PerlIO *tmpfp;
13252 STRLEN i;
13253 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13254 struct dsc$descriptor_vs rsdsc;
13255 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13256 unsigned long hasver = 0, isunix = 0;
13257 unsigned long int lff_flags = 0;
13258 int rms_sts;
13259
83b907a4
CB		 13260 if (!SvOK(tmpglob)) {
13261 SETERRNO(ENOENT,RMS$_FNF);
13262 return NULL;
13263 }
13264
dca5a913
JM		 13265#ifdef VMS_LONGNAME_SUPPORT
13266 lff_flags = LIB$M_FIL_LONG_NAMES;
13267#endif
13268 /* The Newx macro will not allow me to assign a smaller array
13269 * to the rslt pointer, so we will assign it to the begin char pointer
13270 * and then copy the value into the rslt pointer.
13271 */
13272 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13273 rslt = (struct vs_str_st *)begin;
13274 rslt->length = 0;
13275 rstr = &rslt->str[0];
13276 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13277 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13278 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13279 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13280
13281 Newx(vmsspec, VMS_MAXRSS, char);
13282
13283 /* We could find out if there's an explicit dev/dir or version
13284 by peeking into lib$find_file's internal context at
13285 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13286 but that's unsupported, so I don't want to do it now and
13287 have it bite someone in the future. */
13288 /* Fix-me: vms_split_path() is the only way to do this, the
13289 existing method will fail with many legal EFS or UNIX specifications
13290 */
13291
13292 cp = SvPV(tmpglob,i);
13293
13294 for (; i; i--) {
13295 if (cp[i] == ';') hasver = 1;
13296 if (cp[i] == '.') {
13297 if (sts) hasver = 1;
13298 else sts = 1;
13299 }
13300 if (cp[i] == '/') {
13301 hasdir = isunix = 1;
13302 break;
13303 }
13304 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13305 hasdir = 1;
13306 break;
13307 }
13308 }
13309 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
990cad08 13310 int found = 0;
dca5a913
JM		 13311 Stat_t st;
13312 int stat_sts;
13313 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13314 if (!stat_sts && S_ISDIR(st.st_mode)) {
360732b5 13315 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
dca5a913 13316 ok = (wilddsc.dsc$a_pointer != NULL);
ff675744
CB		 13317 /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
13318 hasdir = 1;
dca5a913
JM		 13319 }
13320 else {
360732b5 13321 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
dca5a913
JM		 13322 ok = (wilddsc.dsc$a_pointer != NULL);
13323 }
13324 if (ok)
13325 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13326
13327 /* If not extended character set, replace ? with % */
13328 /* With extended character set, ? is a wildcard single character */
13329 if (!decc_efs_case_preserve) {
13330 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
13331 if (*cp == '?') *cp = '%';
13332 }
13333 sts = SS$_NORMAL;
13334 while (ok && $VMS_STATUS_SUCCESS(sts)) {
13335 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13336 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13337
13338 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13339 &dfltdsc,NULL,&rms_sts,&lff_flags);
13340 if (!$VMS_STATUS_SUCCESS(sts))
13341 break;
13342
990cad08
CB		 13343 found++;
13344
dca5a913
JM		 13345 /* with varying string, 1st word of buffer contains result length */
13346 rstr[rslt->length] = '\0';
13347
13348 /* Find where all the components are */
13349 v_sts = vms_split_path
360732b5 13350 (rstr,
dca5a913
JM		 13351 &v_spec,
13352 &v_len,
13353 &r_spec,
13354 &r_len,
13355 &d_spec,
13356 &d_len,
13357 &n_spec,
13358 &n_len,
13359 &e_spec,
13360 &e_len,
13361 &vs_spec,
13362 &vs_len);
13363
13364 /* If no version on input, truncate the version on output */
13365 if (!hasver && (vs_len > 0)) {
13366 *vs_spec = '\0';
13367 vs_len = 0;
13368
13369 /* No version & a null extension on UNIX handling */
13370 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
13371 e_len = 0;
13372 *e_spec = '\0';
13373 }
13374 }
13375
13376 if (!decc_efs_case_preserve) {
13377 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13378 }
13379
13380 if (hasdir) {
13381 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13382 begin = rstr;
13383 }
13384 else {
13385 /* Start with the name */
13386 begin = n_spec;
13387 }
13388 strcat(begin,"\n");
13389 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13390 }
13391 if (cxt) (void)lib$find_file_end(&cxt);
990cad08
CB		 13392
13393 if (!found) {
13394 /* Be POSIXish: return the input pattern when no matches */
2da7a6b5
CB		 13395 strcpy(rstr,SvPVX(tmpglob));
13396 strcat(rstr,"\n");
13397 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
990cad08
CB		 13398 }
13399
dca5a913
JM		 13400 if (ok && sts != RMS$_NMF &&
13401 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13402 if (!ok) {
13403 if (!(sts & 1)) {
13404 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13405 }
13406 PerlIO_close(tmpfp);
13407 fp = NULL;
13408 }
13409 else {
13410 PerlIO_rewind(tmpfp);
13411 IoTYPE(io) = IoTYPE_RDONLY;
13412 IoIFP(io) = fp = tmpfp;
13413 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
13414 }
13415 }
13416 Safefree(vmsspec);
13417 Safefree(rslt);
13418 return fp;
13419}
13420
cd1191f1 13421
2497a41f 13422static char *
5c4d031a 13423mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
d584a1c6 13424 int *utf8_fl);
2497a41f
JM		 13425
13426void
4d8d3a9c 13427unixrealpath_fromperl(pTHX_ CV *cv)
2497a41f 13428{
d584a1c6
JM		 13429 dXSARGS;
13430 char *fspec, *rslt_spec, *rslt;
13431 STRLEN n_a;
2497a41f 13432
d584a1c6 13433 if (!items || items != 1)
4d8d3a9c 13434 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
2497a41f 13435
d584a1c6
JM		 13436 fspec = SvPV(ST(0),n_a);
13437 if (!fspec || !*fspec) XSRETURN_UNDEF;
2497a41f 13438
d584a1c6
JM		 13439 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13440 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13441
13442 ST(0) = sv_newmortal();
13443 if (rslt != NULL)
13444 sv_usepvn(ST(0),rslt,strlen(rslt));
13445 else
13446 Safefree(rslt_spec);
13447 XSRETURN(1);
2497a41f 13448}
2ee6e19d 13449
b1a8dcd7
JM		 13450static char *
13451mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13452 int *utf8_fl);
13453
13454void
4d8d3a9c 13455vmsrealpath_fromperl(pTHX_ CV *cv)
b1a8dcd7
JM		 13456{
13457 dXSARGS;
13458 char *fspec, *rslt_spec, *rslt;
13459 STRLEN n_a;
13460
13461 if (!items || items != 1)
4d8d3a9c 13462 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
b1a8dcd7
JM		 13463
13464 fspec = SvPV(ST(0),n_a);
13465 if (!fspec || !*fspec) XSRETURN_UNDEF;
13466
13467 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13468 rslt = do_vms_realname(fspec, rslt_spec, NULL);
13469
13470 ST(0) = sv_newmortal();
13471 if (rslt != NULL)
13472 sv_usepvn(ST(0),rslt,strlen(rslt));
13473 else
13474 Safefree(rslt_spec);
13475 XSRETURN(1);
13476}
13477
13478#ifdef HAS_SYMLINK
2ee6e19d
CB		 13479/*
13480 * A thin wrapper around decc$symlink to make sure we follow the
13481 * standard and do not create a symlink with a zero-length name.
4148925f
JM		 13482 *
13483 * Also in ODS-2 mode, existing tests assume that the link target
13484 * will be converted to UNIX format.
2ee6e19d 13485 */
4148925f
JM		 13486/*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13487int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13488 if (!link_name || !*link_name) {
2ee6e19d
CB		 13489 SETERRNO(ENOENT, SS$_NOSUCHFILE);
13490 return -1;
13491 }
4148925f
JM		 13492
13493 if (decc_efs_charset) {
13494 return symlink(contents, link_name);
13495 } else {
13496 int sts;
13497 char * utarget;
13498
13499 /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13500 /* because in order to work, the symlink target must be in UNIX format */
13501
13502 /* As symbolic links can hold things other than files, we will only do */
13503 /* the conversion in in ODS-2 mode */
13504
13505 Newx(utarget, VMS_MAXRSS + 1, char);
0e5ce2c7 13506 if (int_tounixspec(contents, utarget, NULL) == NULL) {
4148925f
JM		 13507
13508 /* This should not fail, as an untranslatable filename */
13509 /* should be passed through */
13510 utarget = (char *)contents;
13511 }
13512 sts = symlink(utarget, link_name);
13513 Safefree(utarget);
13514 return sts;
13515 }
13516
2ee6e19d
CB		 13517}
13518/*}}}*/
13519
13520#endif /* HAS_SYMLINK */
2497a41f 13521
2497a41f
JM		 13522int do_vms_case_tolerant(void);
13523
13524void
4d8d3a9c 13525case_tolerant_process_fromperl(pTHX_ CV *cv)
2497a41f
JM		 13526{
13527 dXSARGS;
13528 ST(0) = boolSV(do_vms_case_tolerant());
13529 XSRETURN(1);
13530}
2497a41f 13531
9ec7171b
CB		 13532#ifdef USE_ITHREADS
13533
96e176bf
CL		 13534void
13535Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13536 struct interp_intern *dst)
13537{
7918f24d
NC		 13538 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13539
96e176bf
CL		 13540 memcpy(dst,src,sizeof(struct interp_intern));
13541}
13542
9ec7171b
CB		 13543#endif
13544
96e176bf
CL		 13545void
13546Perl_sys_intern_clear(pTHX)
13547{
13548}
13549
13550void
13551Perl_sys_intern_init(pTHX)
13552{
3ff49832
CL		 13553 unsigned int ix = RAND_MAX;
13554 double x;
96e176bf
CL		 13555
13556 VMSISH_HUSHED = 0;
13557
1a3aec58 13558 MY_POSIX_EXIT = vms_posix_exit;
7a7fd8e0 13559
96e176bf
CL		 13560 x = (float)ix;
13561 MY_INV_RAND_MAX = 1./x;
ff7adb52 13562}
96e176bf
CL		 13563
13564void
f7ddb74a 13565init_os_extras(void)
748a9306 13566{
a69a6dba 13567 dTHX;
748a9306 13568 char* file = __FILE__;
988c775c 13569 if (decc_disable_to_vms_logname_translation) {
93948341
CB		 13570 no_translate_barewords = TRUE;
13571 } else {
13572 no_translate_barewords = FALSE;
13573 }
748a9306 13574
740ce14c 13575 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
a5f75d66
AD		 13576 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13577 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13578 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13579 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13580 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13581 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13582 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4b19af01 13583 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
a5f75d66 13584 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
96e176bf 13585 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
4d8d3a9c
CB		 13586 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13587 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13588 newXSproto("VMS::Filespec::case_tolerant_process",
13589 case_tolerant_process_fromperl,file,"");
17f28c40 13590
afd8f436 13591 store_pipelocs(aTHX); /* will redo any earlier attempts */
22d4bb9c 13592
748a9306
LW		 13593 return;
13594}
13595
f7ddb74a
JM		 13596#if __CRTL_VER == 80200000
13597/* This missed getting in to the DECC SDK for 8.2 */
13598char *realpath(const char *file_name, char * resolved_name, ...);
13599#endif
13600
13601/*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13602/* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13603 * The perl fallback routine to provide realpath() is not as efficient
13604 * on OpenVMS.
13605 */
d584a1c6
JM		 13606
13607/* Hack, use old stat() as fastest way of getting ino_t and device */
13608int decc$stat(const char *name, void * statbuf);
13609
13610
13611/* Realpath is fragile. In 8.3 it does not work if the feature
13612 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13613 * links are implemented in RMS, not the CRTL. It also can fail if the
13614 * user does not have read/execute access to some of the directories.
13615 * So in order for Do What I Mean mode to work, if realpath() fails,
13616 * fall back to looking up the filename by the device name and FID.
13617 */
13618
13619int vms_fid_to_name(char * outname, int outlen, const char * name)
13620{
13621struct statbuf_t {
13622 char * st_dev;
b1a8dcd7 13623 unsigned short st_ino[3];
d584a1c6
JM		 13624 unsigned short padw;
13625 unsigned long padl[30]; /* plenty of room */
13626} statbuf;
13627int sts;
13628struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13629struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13630
13631 sts = decc$stat(name, &statbuf);
13632 if (sts == 0) {
13633
13634 dvidsc.dsc$a_pointer=statbuf.st_dev;
13635 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13636
13637 specdsc.dsc$a_pointer = outname;
13638 specdsc.dsc$w_length = outlen-1;
13639
13640 sts = lib$fid_to_name
13641 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13642 if ($VMS_STATUS_SUCCESS(sts)) {
13643 outname[specdsc.dsc$w_length] = 0;
13644 return 0;
13645 }
13646 }
13647 return sts;
13648}
13649
13650
13651
f7ddb74a 13652static char *
5c4d031a 13653mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
d584a1c6 13654 int *utf8_fl)
f7ddb74a 13655{
d584a1c6
JM		 13656 char * rslt = NULL;
13657
b1a8dcd7
JM		 13658#ifdef HAS_SYMLINK
13659 if (decc_posix_compliant_pathnames > 0 ) {
13660 /* realpath currently only works if posix compliant pathnames are
13661 * enabled. It may start working when they are not, but in that
13662 * case we still want the fallback behavior for backwards compatibility
13663 */
d584a1c6 13664 rslt = realpath(filespec, outbuf);
b1a8dcd7
JM		 13665 }
13666#endif
d584a1c6
JM		 13667
13668 if (rslt == NULL) {
13669 char * vms_spec;
13670 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13671 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13672 int file_len;
13673
13674 /* Fall back to fid_to_name */
13675
13676 Newx(vms_spec, VMS_MAXRSS + 1, char);
13677
4d8d3a9c
CB		 13678 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13679 if (sts == 0) {
d584a1c6
JM		 13680
13681
13682 /* Now need to trim the version off */
13683 sts = vms_split_path
13684 (vms_spec,
13685 &v_spec,
13686 &v_len,
13687 &r_spec,
13688 &r_len,
13689 &d_spec,
13690 &d_len,
13691 &n_spec,
13692 &n_len,
13693 &e_spec,
13694 &e_len,
13695 &vs_spec,
13696 &vs_len);
13697
13698
4d8d3a9c
CB		 13699 if (sts == 0) {
13700 int haslower = 0;
13701 const char *cp;
d584a1c6 13702
4d8d3a9c
CB		 13703 /* Trim off the version */
13704 int file_len = v_len + r_len + d_len + n_len + e_len;
13705 vms_spec[file_len] = 0;
d584a1c6 13706
4d8d3a9c 13707 /* The result is expected to be in UNIX format */
0e5ce2c7 13708 rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
4d8d3a9c
CB		 13709
13710 /* Downcase if input had any lower case letters and
13711 * case preservation is not in effect.
13712 */
13713 if (!decc_efs_case_preserve) {
13714 for (cp = filespec; *cp; cp++)
13715 if (islower(*cp)) { haslower = 1; break; }
13716
13717 if (haslower) __mystrtolower(rslt);
13718 }
13719 }
643f470b
CB		 13720 } else {
13721
13722 /* Now for some hacks to deal with backwards and forward */
13723 /* compatibilty */
13724 if (!decc_efs_charset) {
13725
13726 /* 1. ODS-2 mode wants to do a syntax only translation */
13727 rslt = do_rmsexpand(filespec, outbuf,
13728 0, NULL, 0, NULL, utf8_fl);
13729
13730 } else {
13731 if (decc_filename_unix_report) {
13732 char * dir_name;
13733 char * vms_dir_name;
13734 char * file_name;
13735
13736 /* 2. ODS-5 / UNIX report mode should return a failure */
13737 /* if the parent directory also does not exist */
13738 /* Otherwise, get the real path for the parent */
13739 /* and add the child to it.
13740
13741 /* basename / dirname only available for VMS 7.0+ */
13742 /* So we may need to implement them as common routines */
13743
13744 Newx(dir_name, VMS_MAXRSS + 1, char);
13745 Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13746 dir_name[0] = '\0';
13747 file_name = NULL;
13748
13749 /* First try a VMS parse */
13750 sts = vms_split_path
13751 (filespec,
13752 &v_spec,
13753 &v_len,
13754 &r_spec,
13755 &r_len,
13756 &d_spec,
13757 &d_len,
13758 &n_spec,
13759 &n_len,
13760 &e_spec,
13761 &e_len,
13762 &vs_spec,
13763 &vs_len);
13764
13765 if (sts == 0) {
13766 /* This is VMS */
13767
13768 int dir_len = v_len + r_len + d_len + n_len;
13769 if (dir_len > 0) {
13770 strncpy(dir_name, filespec, dir_len);
13771 dir_name[dir_len] = '\0';
13772 file_name = (char *)&filespec[dir_len + 1];
13773 }
13774 } else {
13775 /* This must be UNIX */
13776 char * tchar;
13777
13778 tchar = strrchr(filespec, '/');
13779
4148925f
JM		 13780 if (tchar != NULL) {
13781 int dir_len = tchar - filespec;
13782 strncpy(dir_name, filespec, dir_len);
13783 dir_name[dir_len] = '\0';
13784 file_name = (char *) &filespec[dir_len + 1];
13785 }
13786 }
13787
13788 /* Dir name is defaulted */
13789 if (dir_name[0] == 0) {
13790 dir_name[0] = '.';
13791 dir_name[1] = '\0';
13792 }
13793
13794 /* Need realpath for the directory */
13795 sts = vms_fid_to_name(vms_dir_name,
13796 VMS_MAXRSS + 1,
13797 dir_name);
13798
13799 if (sts == 0) {
13800 /* Now need to pathify it.
13801 char *tdir = do_pathify_dirspec(vms_dir_name,
13802 outbuf, utf8_fl);
13803
13804 /* And now add the original filespec to it */
13805 if (file_name != NULL) {
13806 strcat(outbuf, file_name);
13807 }
13808 return outbuf;
13809 }
13810 Safefree(vms_dir_name);
13811 Safefree(dir_name);
13812 }
13813 }
643f470b 13814 }
d584a1c6
JM		 13815 Safefree(vms_spec);
13816 }
13817 return rslt;
f7ddb74a
JM		 13818}
13819
b1a8dcd7
JM		 13820static char *
13821mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13822 int *utf8_fl)
13823{
13824 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13825 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13826 int file_len;
13827
13828 /* Fall back to fid_to_name */
13829
13830 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
cd43acd7
CB		 13831 if (sts != 0) {
13832 return NULL;
13833 }
13834 else {
b1a8dcd7
JM		 13835
13836
13837 /* Now need to trim the version off */
13838 sts = vms_split_path
13839 (outbuf,
13840 &v_spec,
13841 &v_len,
13842 &r_spec,
13843 &r_len,
13844 &d_spec,
13845 &d_len,
13846 &n_spec,
13847 &n_len,
13848 &e_spec,
13849 &e_len,
13850 &vs_spec,
13851 &vs_len);
13852
13853
13854 if (sts == 0) {
4d8d3a9c
CB		 13855 int haslower = 0;
13856 const char *cp;
13857
13858 /* Trim off the version */
13859 int file_len = v_len + r_len + d_len + n_len + e_len;
13860 outbuf[file_len] = 0;
b1a8dcd7 13861
4d8d3a9c
CB		 13862 /* Downcase if input had any lower case letters and
13863 * case preservation is not in effect.
13864 */
13865 if (!decc_efs_case_preserve) {
13866 for (cp = filespec; *cp; cp++)
13867 if (islower(*cp)) { haslower = 1; break; }
13868
13869 if (haslower) __mystrtolower(outbuf);
13870 }
b1a8dcd7
JM		 13871 }
13872 }
13873 return outbuf;
13874}
13875
13876
f7ddb74a
JM		 13877/*}}}*/
13878/* External entry points */
360732b5
JM		 13879char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13880{ return do_vms_realpath(filespec, outbuf, utf8_fl); }
f7ddb74a 13881
b1a8dcd7
JM		 13882char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13883{ return do_vms_realname(filespec, outbuf, utf8_fl); }
f7ddb74a 13884
f7ddb74a
JM		 13885/* case_tolerant */
13886
13887/*{{{int do_vms_case_tolerant(void)*/
13888/* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13889 * controlled by a process setting.
13890 */
13891int do_vms_case_tolerant(void)
13892{
13893 return vms_process_case_tolerant;
13894}
13895/*}}}*/
13896/* External entry points */
b1a8dcd7 13897#if __CRTL_VER >= 70301000 && !defined(__VAX)
f7ddb74a
JM		 13898int Perl_vms_case_tolerant(void)
13899{ return do_vms_case_tolerant(); }
13900#else
13901int Perl_vms_case_tolerant(void)
13902{ return vms_process_case_tolerant; }
13903#endif
13904
13905
13906 /* Start of DECC RTL Feature handling */
13907
13908static int sys_trnlnm
13909 (const char * logname,
13910 char * value,
13911 int value_len)
13912{
13913 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13914 const unsigned long attr = LNM$M_CASE_BLIND;
13915 struct dsc$descriptor_s name_dsc;
13916 int status;
13917 unsigned short result;
13918 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13919 {0, 0, 0, 0}};
13920
13921 name_dsc.dsc$w_length = strlen(logname);
13922 name_dsc.dsc$a_pointer = (char *)logname;
13923 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13924 name_dsc.dsc$b_class = DSC$K_CLASS_S;
13925
13926 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13927
13928 if ($VMS_STATUS_SUCCESS(status)) {
13929
13930 /* Null terminate and return the string */
13931 /*--------------------------------------*/
13932 value[result] = 0;
13933 }
13934
13935 return status;
13936}
13937
13938static int sys_crelnm
13939 (const char * logname,
13940 const char * value)
13941{
13942 int ret_val;
13943 const char * proc_table = "LNM$PROCESS_TABLE";
13944 struct dsc$descriptor_s proc_table_dsc;
13945 struct dsc$descriptor_s logname_dsc;
13946 struct itmlst_3 item_list[2];
13947
13948 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13949 proc_table_dsc.dsc$w_length = strlen(proc_table);
13950 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13951 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13952
13953 logname_dsc.dsc$a_pointer = (char *) logname;
13954 logname_dsc.dsc$w_length = strlen(logname);
13955 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13956 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13957
13958 item_list[0].buflen = strlen(value);
13959 item_list[0].itmcode = LNM$_STRING;
13960 item_list[0].bufadr = (char *)value;
13961 item_list[0].retlen = NULL;
13962
13963 item_list[1].buflen = 0;
13964 item_list[1].itmcode = 0;
13965
13966 ret_val = sys$crelnm
13967 (NULL,
13968 (const struct dsc$descriptor_s *)&proc_table_dsc,
13969 (const struct dsc$descriptor_s *)&logname_dsc,
13970 NULL,
13971 (const struct item_list_3 *) item_list);
13972
13973 return ret_val;
13974}
13975
f7ddb74a
JM		 13976/* C RTL Feature settings */
13977
13978static int set_features
13979 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
13980 int (* cli_routine)(void), /* Not documented */
13981 void *image_info) /* Not documented */
13982{
13983 int status;
13984 int s;
f7ddb74a
JM		 13985 char* str;
13986 char val_str[10];
3c841f20 13987#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
f7ddb74a
JM		 13988 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13989 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13990 unsigned long case_perm;
13991 unsigned long case_image;
3c841f20 13992#endif
f7ddb74a 13993
9c1171d1
JM		 13994 /* Allow an exception to bring Perl into the VMS debugger */
13995 vms_debug_on_exception = 0;
13996 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13997 if ($VMS_STATUS_SUCCESS(status)) {
b53f3677 13998 val_str[0] = _toupper(val_str[0]);
9c1171d1
JM		 13999 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14000 vms_debug_on_exception = 1;
14001 else
14002 vms_debug_on_exception = 0;
14003 }
14004
b53f3677
JM		 14005 /* Debug unix/vms file translation routines */
14006 vms_debug_fileify = 0;
14007 status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14008 if ($VMS_STATUS_SUCCESS(status)) {
14009 val_str[0] = _toupper(val_str[0]);
14010 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14011 vms_debug_fileify = 1;
14012 else
14013 vms_debug_fileify = 0;
14014 }
14015
14016
14017 /* Historically PERL has been doing vmsify / stat differently than */
14018 /* the CRTL. In particular, under some conditions the CRTL will */
14019 /* remove some illegal characters like spaces from filenames */
14020 /* resulting in some differences. The stat()/lstat() wrapper has */
14021 /* been reporting such file names as invalid and fails to stat them */
14022 /* fixing this bug so that stat()/lstat() accept these like the */
14023 /* CRTL does will result in several tests failing. */
14024 /* This should really be fixed, but for now, set up a feature to */
14025 /* enable it so that the impact can be studied. */
14026 vms_bug_stat_filename = 0;
14027 status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14028 if ($VMS_STATUS_SUCCESS(status)) {
14029 val_str[0] = _toupper(val_str[0]);
14030 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14031 vms_bug_stat_filename = 1;
14032 else
14033 vms_bug_stat_filename = 0;
14034 }
14035
14036
38a44b82 14037 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
360732b5
JM		 14038 vms_vtf7_filenames = 0;
14039 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14040 if ($VMS_STATUS_SUCCESS(status)) {
b53f3677 14041 val_str[0] = _toupper(val_str[0]);
360732b5
JM		 14042 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14043 vms_vtf7_filenames = 1;
14044 else
14045 vms_vtf7_filenames = 0;
14046 }
14047
e0e5e8d6 14048 /* unlink all versions on unlink() or rename() */
d584a1c6 14049 vms_unlink_all_versions = 0;
e0e5e8d6
JM		 14050 status = sys_trnlnm
14051 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14052 if ($VMS_STATUS_SUCCESS(status)) {
b53f3677 14053 val_str[0] = _toupper(val_str[0]);
e0e5e8d6
JM		 14054 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14055 vms_unlink_all_versions = 1;
14056 else
14057 vms_unlink_all_versions = 0;
14058 }
14059
360732b5
JM		 14060 /* Dectect running under GNV Bash or other UNIX like shell */
14061#if __CRTL_VER >= 70300000 && !defined(__VAX)
14062 gnv_unix_shell = 0;
14063 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14064 if ($VMS_STATUS_SUCCESS(status)) {
360732b5
JM		 14065 gnv_unix_shell = 1;
14066 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14067 set_feature_default("DECC$EFS_CHARSET", 1);
14068 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14069 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14070 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14071 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
e0e5e8d6 14072 vms_unlink_all_versions = 1;
1a3aec58 14073 vms_posix_exit = 1;
360732b5
JM		 14074 }
14075#endif
9c1171d1 14076
2497a41f
JM		 14077 /* hacks to see if known bugs are still present for testing */
14078
2497a41f 14079 /* PCP mode requires creating /dev/null special device file */
2623a4a6 14080 decc_bug_devnull = 0;
2497a41f
JM		 14081 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14082 if ($VMS_STATUS_SUCCESS(status)) {
b53f3677 14083 val_str[0] = _toupper(val_str[0]);
2497a41f
JM		 14084 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14085 decc_bug_devnull = 1;
682e4b71
JM		 14086 else
14087 decc_bug_devnull = 0;
2497a41f
JM		 14088 }
14089
2497a41f
JM		 14090 /* UNIX directory names with no paths are broken in a lot of places */
14091 decc_dir_barename = 1;
14092 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14093 if ($VMS_STATUS_SUCCESS(status)) {
b53f3677 14094 val_str[0] = _toupper(val_str[0]);
2497a41f
JM		 14095 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14096 decc_dir_barename = 1;
14097 else
14098 decc_dir_barename = 0;
14099 }
14100
f7ddb74a
JM		 14101#if __CRTL_VER >= 70300000 && !defined(__VAX)
14102 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14103 if (s >= 0) {
14104 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14105 if (decc_disable_to_vms_logname_translation < 0)
14106 decc_disable_to_vms_logname_translation = 0;
14107 }
14108
14109 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14110 if (s >= 0) {
14111 decc_efs_case_preserve = decc$feature_get_value(s, 1);
14112 if (decc_efs_case_preserve < 0)
14113 decc_efs_case_preserve = 0;
14114 }
14115
14116 s = decc$feature_get_index("DECC$EFS_CHARSET");
b53f3677 14117 decc_efs_charset_index = s;
f7ddb74a
JM		 14118 if (s >= 0) {
14119 decc_efs_charset = decc$feature_get_value(s, 1);
14120 if (decc_efs_charset < 0)
14121 decc_efs_charset = 0;
14122 }
14123
14124 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14125 if (s >= 0) {
14126 decc_filename_unix_report = decc$feature_get_value(s, 1);
1a3aec58 14127 if (decc_filename_unix_report > 0) {
f7ddb74a 14128 decc_filename_unix_report = 1;
1a3aec58
JM		 14129 vms_posix_exit = 1;
14130 }
f7ddb74a
JM		 14131 else
14132 decc_filename_unix_report = 0;
14133 }
14134
14135 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14136 if (s >= 0) {
14137 decc_filename_unix_only = decc$feature_get_value(s, 1);
14138 if (decc_filename_unix_only > 0) {
14139 decc_filename_unix_only = 1;
14140 }
14141 else {
14142 decc_filename_unix_only = 0;
14143 }
14144 }
14145
14146 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14147 if (s >= 0) {
14148 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14149 if (decc_filename_unix_no_version < 0)
14150 decc_filename_unix_no_version = 0;
14151 }
14152
14153 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14154 if (s >= 0) {
14155 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14156 if (decc_readdir_dropdotnotype < 0)
14157 decc_readdir_dropdotnotype = 0;
14158 }
14159
f7ddb74a
JM		 14160#if __CRTL_VER >= 80200000
14161 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14162 if (s >= 0) {
14163 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14164 if (decc_posix_compliant_pathnames < 0)
14165 decc_posix_compliant_pathnames = 0;
14166 if (decc_posix_compliant_pathnames > 4)
14167 decc_posix_compliant_pathnames = 0;
14168 }
14169
14170#endif
14171#else
14172 status = sys_trnlnm
14173 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14174 if ($VMS_STATUS_SUCCESS(status)) {
14175 val_str[0] = _toupper(val_str[0]);
14176 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14177 decc_disable_to_vms_logname_translation = 1;
14178 }
14179 }
14180
14181#ifndef __VAX
14182 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14183 if ($VMS_STATUS_SUCCESS(status)) {
14184 val_str[0] = _toupper(val_str[0]);
14185 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14186 decc_efs_case_preserve = 1;
14187 }
14188 }
14189#endif
14190
14191 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14192 if ($VMS_STATUS_SUCCESS(status)) {
14193 val_str[0] = _toupper(val_str[0]);
14194 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14195 decc_filename_unix_report = 1;
14196 }
14197 }
14198 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14199 if ($VMS_STATUS_SUCCESS(status)) {
14200 val_str[0] = _toupper(val_str[0]);
14201 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14202 decc_filename_unix_only = 1;
14203 decc_filename_unix_report = 1;
14204 }
14205 }
14206 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14207 if ($VMS_STATUS_SUCCESS(status)) {
14208 val_str[0] = _toupper(val_str[0]);
14209 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14210 decc_filename_unix_no_version = 1;
14211 }
14212 }
14213 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14214 if ($VMS_STATUS_SUCCESS(status)) {
14215 val_str[0] = _toupper(val_str[0]);
14216 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14217 decc_readdir_dropdotnotype = 1;
14218 }
14219 }
14220#endif
14221
28ff9735 14222#if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
f7ddb74a
JM		 14223
14224 /* Report true case tolerance */
14225 /*----------------------------*/
14226 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14227 if (!$VMS_STATUS_SUCCESS(status))
14228 case_perm = PPROP$K_CASE_BLIND;
14229 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14230 if (!$VMS_STATUS_SUCCESS(status))
14231 case_image = PPROP$K_CASE_BLIND;
14232 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14233 (case_image == PPROP$K_CASE_SENSITIVE))
14234 vms_process_case_tolerant = 0;
14235
14236#endif
14237
1a3aec58
JM		 14238 /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
14239 /* for strict backward compatibilty */
14240 status = sys_trnlnm
14241 ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14242 if ($VMS_STATUS_SUCCESS(status)) {
b53f3677 14243 val_str[0] = _toupper(val_str[0]);
1a3aec58
JM		 14244 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14245 vms_posix_exit = 1;
14246 else
14247 vms_posix_exit = 0;
14248 }
14249
f7ddb74a
JM		 14250
14251 /* CRTL can be initialized past this point, but not before. */
14252/* DECC$CRTL_INIT(); */
14253
14254 return SS$_NORMAL;
14255}
14256
14257#ifdef __DECC
f7ddb74a
JM		 14258#pragma nostandard
14259#pragma extern_model save
14260#pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
f7ddb74a 14261 const __align (LONGWORD) int spare[8] = {0};
dfffea70
CB		 14262
14263/* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14264#if __DECC_VER >= 60560002
14265#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14266#else
14267#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
f7ddb74a 14268#endif
dfffea70
CB		 14269#endif /* __DECC */
14270
f7ddb74a
JM		 14271const long vms_cc_features = (const long)set_features;
14272
14273/*
14274** Force a reference to LIB$INITIALIZE to ensure it
14275** exists in the image.
14276*/
14277int lib$initialize(void);
14278#ifdef __DECC
14279#pragma extern_model strict_refdef
14280#endif
14281 int lib_init_ref = (int) lib$initialize;
14282
14283#ifdef __DECC
14284#pragma extern_model restore
14285#pragma standard
14286#endif
14287
748a9306 14288/* End of vms.c */
Unnamed repository; edit this file 'description' to name the repository.