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
Re: 5.10.0 test hangs on non internet access
[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
14#include <acedef.h>
15#include <acldef.h>
16#include <armdef.h>
748a9306 17#include <atrdef.h>
a0d0e21e 18#include <chpdef.h>
8fde5078 19#include <clidef.h>
a3e9d8c9 20#include <climsgdef.h>
cd1191f1 21#include <dcdef.h>
a0d0e21e 22#include <descrip.h>
22d4bb9c 23#include <devdef.h>
a0d0e21e 24#include <dvidef.h>
748a9306 25#include <fibdef.h>
a0d0e21e
LW		 26#include <float.h>
27#include <fscndef.h>
28#include <iodef.h>
29#include <jpidef.h>
61bb5906 30#include <kgbdef.h>
f675dbe5 31#include <libclidef.h>
a0d0e21e
LW		 32#include <libdef.h>
33#include <lib$routines.h>
34#include <lnmdef.h>
aeb5cf3c 35#include <msgdef.h>
4fdf8f88 36#include <ossdef.h>
f7ddb74a
JM		 37#if __CRTL_VER >= 70301000 && !defined(__VAX)
38#include <ppropdef.h>
39#endif
748a9306 40#include <prvdef.h>
a0d0e21e
LW		 41#include <psldef.h>
42#include <rms.h>
43#include <shrdef.h>
44#include <ssdef.h>
45#include <starlet.h>
f86702cc 46#include <strdef.h>
47#include <str$routines.h>
a0d0e21e 48#include <syidef.h>
748a9306
LW		 49#include <uaidef.h>
50#include <uicdef.h>
2fbb330f
JM		 51#include <stsdef.h>
52#include <rmsdef.h>
cd1191f1 53#include <smgdef.h>
cfcfe586
JM		 54#if __CRTL_VER >= 70000000 /* FIXME to earliest version */
55#include <efndef.h>
56#define NO_EFN EFN$C_ENF
57#else
58#define NO_EFN 0;
59#endif
a0d0e21e 60
f7ddb74a
JM		 61#if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
62int decc$feature_get_index(const char *name);
63char* decc$feature_get_name(int index);
64int decc$feature_get_value(int index, int mode);
65int decc$feature_set_value(int index, int mode, int value);
66#else
67#include <unixlib.h>
68#endif
69
cfcfe586
JM		 70#pragma member_alignment save
71#pragma nomember_alignment longword
72struct item_list_3 {
73 unsigned short len;
74 unsigned short code;
75 void * bufadr;
76 unsigned short * retadr;
77};
78#pragma member_alignment restore
79
80/* More specific prototype than in starlet_c.h makes programming errors
81 more visible.
82 */
83#ifdef sys$getdviw
84#undef sys$getdviw
cfcfe586
JM		 85int sys$getdviw
86 (unsigned long efn,
87 unsigned short chan,
88 const struct dsc$descriptor_s * devnam,
89 const struct item_list_3 * itmlst,
90 void * iosb,
91 void * (astadr)(unsigned long),
92 void * astprm,
93 void * nullarg);
7566800d 94#endif
cfcfe586 95
4fdf8f88
JM		 96#ifdef sys$get_security
97#undef sys$get_security
98int sys$get_security
99 (const struct dsc$descriptor_s * clsnam,
100 const struct dsc$descriptor_s * objnam,
101 const unsigned int *objhan,
102 unsigned int flags,
103 const struct item_list_3 * itmlst,
104 unsigned int * contxt,
105 const unsigned int * acmode);
106#endif
107
108#ifdef sys$set_security
109#undef sys$set_security
110int sys$set_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
8cb5d3d5
JM		 120#ifdef lib$find_image_symbol
121#undef lib$find_image_symbol
122int lib$find_image_symbol
123 (const struct dsc$descriptor_s * imgname,
124 const struct dsc$descriptor_s * symname,
125 void * symval,
126 const struct dsc$descriptor_s * defspec,
127 unsigned long flag);
4fdf8f88 128#endif
8cb5d3d5 129
4fdf8f88
JM		 130#ifdef lib$rename_file
131#undef lib$rename_file
132int lib$rename_file
133 (const struct dsc$descriptor_s * old_file_dsc,
134 const struct dsc$descriptor_s * new_file_dsc,
135 const struct dsc$descriptor_s * default_file_dsc,
136 const struct dsc$descriptor_s * related_file_dsc,
137 const unsigned long * flags,
138 void * (success)(const struct dsc$descriptor_s * old_dsc,
139 const struct dsc$descriptor_s * new_dsc,
140 const void *),
141 void * (error)(const struct dsc$descriptor_s * old_dsc,
142 const struct dsc$descriptor_s * new_dsc,
143 const int * rms_sts,
144 const int * rms_stv,
145 const int * error_src,
146 const void * usr_arg),
147 int (confirm)(const struct dsc$descriptor_s * old_dsc,
148 const struct dsc$descriptor_s * new_dsc,
149 const void * old_fab,
150 const void * usr_arg),
151 void * user_arg,
152 struct dsc$descriptor_s * old_result_name_dsc,
153 struct dsc$descriptor_s * new_result_name_dsc,
154 unsigned long * file_scan_context);
8cb5d3d5
JM		 155#endif
156
7a7fd8e0 157#if __CRTL_VER >= 70300000 && !defined(__VAX)
f7ddb74a
JM		 158
159static int set_feature_default(const char *name, int value)
160{
161 int status;
162 int index;
163
164 index = decc$feature_get_index(name);
165
166 status = decc$feature_set_value(index, 1, value);
167 if (index == -1 || (status == -1)) {
168 return -1;
169 }
170
171 status = decc$feature_get_value(index, 1);
172 if (status != value) {
173 return -1;
174 }
175
176return 0;
177}
178#endif
f7ddb74a 179
740ce14c 180/* Older versions of ssdef.h don't have these */
181#ifndef SS$_INVFILFOROP
182# define SS$_INVFILFOROP 3930
183#endif
184#ifndef SS$_NOSUCHOBJECT
b7ae7a0d 185# define SS$_NOSUCHOBJECT 2696
186#endif
187
a15cef0c
CB		 188/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
189#define PERLIO_NOT_STDIO 0
190
2497a41f 191/* Don't replace system definitions of vfork, getenv, lstat, and stat,
aa689395 192 * code below needs to get to the underlying CRTL routines. */
193#define DONT_MASK_RTL_CALLS
a0d0e21e
LW		 194#include "EXTERN.h"
195#include "perl.h"
748a9306 196#include "XSUB.h"
3eeba6fb
CB		 197/* Anticipating future expansion in lexical warnings . . . */
198#ifndef WARN_INTERNAL
199# define WARN_INTERNAL WARN_MISC
200#endif
a0d0e21e 201
988c775c
JM		 202#ifdef VMS_LONGNAME_SUPPORT
203#include <libfildef.h>
204#endif
205
22d4bb9c
CB		 206#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
207# define RTL_USES_UTC 1
208#endif
209
5f1992ed
CB		 210/* Routine to create a decterm for use with the Perl debugger */
211/* No headers, this information was found in the Programming Concepts Manual */
212
8cb5d3d5 213static int (*decw_term_port)
5f1992ed
CB		 214 (const struct dsc$descriptor_s * display,
215 const struct dsc$descriptor_s * setup_file,
216 const struct dsc$descriptor_s * customization,
217 struct dsc$descriptor_s * result_device_name,
218 unsigned short * result_device_name_length,
219 void * controller,
220 void * char_buffer,
8cb5d3d5 221 void * char_change_buffer) = 0;
22d4bb9c 222
c07a80fd 223/* gcc's header files don't #define direct access macros
224 * corresponding to VAXC's variant structs */
225#ifdef __GNUC__
482b294c 226# define uic$v_format uic$r_uic_form.uic$v_format
227# define uic$v_group uic$r_uic_form.uic$v_group
228# define uic$v_member uic$r_uic_form.uic$v_member
c07a80fd 229# define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
230# define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
231# define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
232# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
233#endif
234
c645ec3f
GS		 235#if defined(NEED_AN_H_ERRNO)
236dEXT int h_errno;
237#endif
c07a80fd 238
f7ddb74a
JM		 239#ifdef __DECC
240#pragma message disable pragma
241#pragma member_alignment save
242#pragma nomember_alignment longword
243#pragma message save
244#pragma message disable misalgndmem
245#endif
a0d0e21e
LW		 246struct itmlst_3 {
247 unsigned short int buflen;
248 unsigned short int itmcode;
249 void *bufadr;
748a9306 250 unsigned short int *retlen;
a0d0e21e 251};
657054d4
JM		 252
253struct filescan_itmlst_2 {
254 unsigned short length;
255 unsigned short itmcode;
256 char * component;
257};
258
dca5a913
JM		 259struct vs_str_st {
260 unsigned short length;
261 char str[65536];
262};
263
f7ddb74a
JM		 264#ifdef __DECC
265#pragma message restore
266#pragma member_alignment restore
267#endif
a0d0e21e 268
360732b5
JM		 269#define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
270#define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
271#define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
272#define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
273#define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
274#define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
275#define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
276#define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
f7ddb74a 277#define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
4b19af01
CB		 278#define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
279#define getredirection(a,b) mp_getredirection(aTHX_ a,b)
280
360732b5
JM		 281static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
282static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
283static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
284static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
f7ddb74a 285
0e06870b
CB		 286/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
287#define PERL_LNM_MAX_ALLOWED_INDEX 127
288
2d9f3838
CB		 289/* OpenVMS User's Guide says at least 9 iterative translations will be performed,
290 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
291 * the Perl facility.
292 */
293#define PERL_LNM_MAX_ITER 10
294
2497a41f
JM		 295 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
296#if __CRTL_VER >= 70302000 && !defined(__VAX)
297#define MAX_DCL_SYMBOL (8192)
298#define MAX_DCL_LINE_LENGTH (4096 - 4)
299#else
300#define MAX_DCL_SYMBOL (1024)
301#define MAX_DCL_LINE_LENGTH (1024 - 4)
302#endif
ff7adb52 303
01b8edb6 304static char *__mystrtolower(char *str)
305{
306 if (str) for (; *str; ++str) *str= tolower(*str);
307 return str;
308}
309
f675dbe5
CB		 310static struct dsc$descriptor_s fildevdsc =
311 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
312static struct dsc$descriptor_s crtlenvdsc =
313 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
314static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
315static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
316static struct dsc$descriptor_s **env_tables = defenv;
317static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
318
93948341
CB		 319/* True if we shouldn't treat barewords as logicals during directory */
320/* munching */
321static int no_translate_barewords;
322
22d4bb9c
CB		 323#ifndef RTL_USES_UTC
324static int tz_updated = 1;
325#endif
326
f7ddb74a
JM		 327/* DECC Features that may need to affect how Perl interprets
328 * displays filename information
329 */
330static int decc_disable_to_vms_logname_translation = 1;
331static int decc_disable_posix_root = 1;
332int decc_efs_case_preserve = 0;
333static int decc_efs_charset = 0;
334static int decc_filename_unix_no_version = 0;
335static int decc_filename_unix_only = 0;
336int decc_filename_unix_report = 0;
337int decc_posix_compliant_pathnames = 0;
338int decc_readdir_dropdotnotype = 0;
339static int vms_process_case_tolerant = 1;
360732b5
JM		 340int vms_vtf7_filenames = 0;
341int gnv_unix_shell = 0;
e0e5e8d6 342static int vms_unlink_all_versions = 0;
f7ddb74a 343
2497a41f
JM		 344/* bug workarounds if needed */
345int decc_bug_readdir_efs1 = 0;
682e4b71 346int decc_bug_devnull = 1;
2497a41f
JM		 347int decc_bug_fgetname = 0;
348int decc_dir_barename = 0;
349
9c1171d1
JM		 350static int vms_debug_on_exception = 0;
351
f7ddb74a
JM		 352/* Is this a UNIX file specification?
353 * No longer a simple check with EFS file specs
354 * For now, not a full check, but need to
355 * handle POSIX ^UP^ specifications
356 * Fixing to handle ^/ cases would require
357 * changes to many other conversion routines.
358 */
359
657054d4 360static int is_unix_filespec(const char *path)
f7ddb74a
JM		 361{
362int ret_val;
363const char * pch1;
364
365 ret_val = 0;
366 if (strncmp(path,"\"^UP^",5) != 0) {
367 pch1 = strchr(path, '/');
368 if (pch1 != NULL)
369 ret_val = 1;
370 else {
371
372 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
373 if (decc_filename_unix_report || decc_filename_unix_only) {
374 if (strcmp(path,".") == 0)
375 ret_val = 1;
376 }
377 }
378 }
379 return ret_val;
380}
381
360732b5
JM		 382/* This routine converts a UCS-2 character to be VTF-7 encoded.
383 */
384
385static void ucs2_to_vtf7
386 (char *outspec,
387 unsigned long ucs2_char,
388 int * output_cnt)
389{
390unsigned char * ucs_ptr;
391int hex;
392
393 ucs_ptr = (unsigned char *)&ucs2_char;
394
395 outspec[0] = '^';
396 outspec[1] = 'U';
397 hex = (ucs_ptr[1] >> 4) & 0xf;
398 if (hex < 0xA)
399 outspec[2] = hex + '0';
400 else
401 outspec[2] = (hex - 9) + 'A';
402 hex = ucs_ptr[1] & 0xF;
403 if (hex < 0xA)
404 outspec[3] = hex + '0';
405 else {
406 outspec[3] = (hex - 9) + 'A';
407 }
408 hex = (ucs_ptr[0] >> 4) & 0xf;
409 if (hex < 0xA)
410 outspec[4] = hex + '0';
411 else
412 outspec[4] = (hex - 9) + 'A';
413 hex = ucs_ptr[1] & 0xF;
414 if (hex < 0xA)
415 outspec[5] = hex + '0';
416 else {
417 outspec[5] = (hex - 9) + 'A';
418 }
419 *output_cnt = 6;
420}
421
422
423/* This handles the conversion of a UNIX extended character set to a ^
424 * escaped VMS character.
425 * in a UNIX file specification.
426 *
427 * The output count variable contains the number of characters added
428 * to the output string.
429 *
430 * The return value is the number of characters read from the input string
431 */
432static int copy_expand_unix_filename_escape
433 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
434{
435int count;
436int scnt;
437int utf8_flag;
438
439 utf8_flag = 0;
440 if (utf8_fl)
441 utf8_flag = *utf8_fl;
442
443 count = 0;
444 *output_cnt = 0;
445 if (*inspec >= 0x80) {
446 if (utf8_fl && vms_vtf7_filenames) {
447 unsigned long ucs_char;
448
449 ucs_char = 0;
450
451 if ((*inspec & 0xE0) == 0xC0) {
452 /* 2 byte Unicode */
453 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
454 if (ucs_char >= 0x80) {
455 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
456 return 2;
457 }
458 } else if ((*inspec & 0xF0) == 0xE0) {
459 /* 3 byte Unicode */
460 ucs_char = ((inspec[0] & 0xF) << 12) +
461 ((inspec[1] & 0x3f) << 6) +
462 (inspec[2] & 0x3f);
463 if (ucs_char >= 0x800) {
464 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
465 return 3;
466 }
467
468#if 0 /* I do not see longer sequences supported by OpenVMS */
469 /* Maybe some one can fix this later */
470 } else if ((*inspec & 0xF8) == 0xF0) {
471 /* 4 byte Unicode */
472 /* UCS-4 to UCS-2 */
473 } else if ((*inspec & 0xFC) == 0xF8) {
474 /* 5 byte Unicode */
475 /* UCS-4 to UCS-2 */
476 } else if ((*inspec & 0xFE) == 0xFC) {
477 /* 6 byte Unicode */
478 /* UCS-4 to UCS-2 */
479#endif
480 }
481 }
482
38a44b82 483 /* High bit set, but not a Unicode character! */
360732b5
JM		 484
485 /* Non printing DECMCS or ISO Latin-1 character? */
486 if (*inspec <= 0x9F) {
487 int hex;
488 outspec[0] = '^';
489 outspec++;
490 hex = (*inspec >> 4) & 0xF;
491 if (hex < 0xA)
492 outspec[1] = hex + '0';
493 else {
494 outspec[1] = (hex - 9) + 'A';
495 }
496 hex = *inspec & 0xF;
497 if (hex < 0xA)
498 outspec[2] = hex + '0';
499 else {
500 outspec[2] = (hex - 9) + 'A';
501 }
502 *output_cnt = 3;
503 return 1;
504 } else if (*inspec == 0xA0) {
505 outspec[0] = '^';
506 outspec[1] = 'A';
507 outspec[2] = '0';
508 *output_cnt = 3;
509 return 1;
510 } else if (*inspec == 0xFF) {
511 outspec[0] = '^';
512 outspec[1] = 'F';
513 outspec[2] = 'F';
514 *output_cnt = 3;
515 return 1;
516 }
517 *outspec = *inspec;
518 *output_cnt = 1;
519 return 1;
520 }
521
522 /* Is this a macro that needs to be passed through?
523 * Macros start with $( and an alpha character, followed
524 * by a string of alpha numeric characters ending with a )
525 * If this does not match, then encode it as ODS-5.
526 */
527 if ((inspec[0] == '$') && (inspec[1] == '(')) {
528 int tcnt;
529
530 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
531 tcnt = 3;
532 outspec[0] = inspec[0];
533 outspec[1] = inspec[1];
534 outspec[2] = inspec[2];
535
536 while(isalnum(inspec[tcnt]) ||
537 (inspec[2] == '.') || (inspec[2] == '_')) {
538 outspec[tcnt] = inspec[tcnt];
539 tcnt++;
540 }
541 if (inspec[tcnt] == ')') {
542 outspec[tcnt] = inspec[tcnt];
543 tcnt++;
544 *output_cnt = tcnt;
545 return tcnt;
546 }
547 }
548 }
549
550 switch (*inspec) {
551 case 0x7f:
552 outspec[0] = '^';
553 outspec[1] = '7';
554 outspec[2] = 'F';
555 *output_cnt = 3;
556 return 1;
557 break;
558 case '?':
559 if (decc_efs_charset == 0)
560 outspec[0] = '%';
561 else
562 outspec[0] = '?';
563 *output_cnt = 1;
564 return 1;
565 break;
566 case '.':
567 case '~':
568 case '!':
569 case '#':
570 case '&':
571 case '\'':
572 case '`':
573 case '(':
574 case ')':
575 case '+':
576 case '@':
577 case '{':
578 case '}':
579 case ',':
580 case ';':
581 case '[':
582 case ']':
583 case '%':
584 case '^':
adc11f0b
CB		 585 /* Don't escape again if following character is
586 * already something we escape.
587 */
588 if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
589 *outspec = *inspec;
590 *output_cnt = 1;
591 return 1;
592 break;
593 }
594 /* But otherwise fall through and escape it. */
360732b5
JM		 595 case '=':
596 /* Assume that this is to be escaped */
597 outspec[0] = '^';
598 outspec[1] = *inspec;
599 *output_cnt = 2;
600 return 1;
601 break;
602 case ' ': /* space */
603 /* Assume that this is to be escaped */
604 outspec[0] = '^';
605 outspec[1] = '_';
606 *output_cnt = 2;
607 return 1;
608 break;
609 default:
610 *outspec = *inspec;
611 *output_cnt = 1;
612 return 1;
613 break;
614 }
615}
616
617
657054d4
JM		 618/* This handles the expansion of a '^' prefix to the proper character
619 * in a UNIX file specification.
620 *
621 * The output count variable contains the number of characters added
622 * to the output string.
623 *
624 * The return value is the number of characters read from the input
625 * string
626 */
627static int copy_expand_vms_filename_escape
628 (char *outspec, const char *inspec, int *output_cnt)
629{
630int count;
631int scnt;
632
633 count = 0;
634 *output_cnt = 0;
635 if (*inspec == '^') {
636 inspec++;
637 switch (*inspec) {
adc11f0b
CB		 638 /* Spaces and non-trailing dots should just be passed through,
639 * but eat the escape character.
640 */
657054d4 641 case '.':
657054d4 642 *outspec = *inspec;
adc11f0b
CB		 643 count += 2;
644 (*output_cnt)++;
657054d4
JM		 645 break;
646 case '_': /* space */
647 *outspec = ' ';
adc11f0b 648 count += 2;
657054d4
JM		 649 (*output_cnt)++;
650 break;
adc11f0b
CB		 651 case '^':
652 /* Hmm. Better leave the escape escaped. */
653 outspec[0] = '^';
654 outspec[1] = '^';
655 count += 2;
656 (*output_cnt) += 2;
657 break;
360732b5 658 case 'U': /* Unicode - FIX-ME this is wrong. */
657054d4
JM		 659 inspec++;
660 count++;
661 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
662 if (scnt == 4) {
2f4077ca
JM		 663 unsigned int c1, c2;
664 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
665 outspec[0] == c1 & 0xff;
666 outspec[1] == c2 & 0xff;
657054d4
JM		 667 if (scnt > 1) {
668 (*output_cnt) += 2;
669 count += 4;
670 }
671 }
672 else {
673 /* Error - do best we can to continue */
674 *outspec = 'U';
675 outspec++;
676 (*output_cnt++);
677 *outspec = *inspec;
678 count++;
679 (*output_cnt++);
680 }
681 break;
682 default:
683 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
684 if (scnt == 2) {
685 /* Hex encoded */
2f4077ca
JM		 686 unsigned int c1;
687 scnt = sscanf(inspec, "%2x", &c1);
688 outspec[0] = c1 & 0xff;
657054d4
JM		 689 if (scnt > 0) {
690 (*output_cnt++);
691 count += 2;
692 }
693 }
694 else {
695 *outspec = *inspec;
696 count++;
697 (*output_cnt++);
698 }
699 }
700 }
701 else {
702 *outspec = *inspec;
703 count++;
704 (*output_cnt)++;
705 }
706 return count;
707}
708
7566800d
CB		 709#ifdef sys$filescan
710#undef sys$filescan
711int sys$filescan
657054d4
JM		 712 (const struct dsc$descriptor_s * srcstr,
713 struct filescan_itmlst_2 * valuelist,
714 unsigned long * fldflags,
715 struct dsc$descriptor_s *auxout,
716 unsigned short * retlen);
7566800d 717#endif
657054d4
JM		 718
719/* vms_split_path - Verify that the input file specification is a
720 * VMS format file specification, and provide pointers to the components of
721 * it. With EFS format filenames, this is virtually the only way to
722 * parse a VMS path specification into components.
723 *
724 * If the sum of the components do not add up to the length of the
725 * string, then the passed file specification is probably a UNIX style
726 * path.
727 */
728static int vms_split_path
360732b5 729 (const char * path,
dca5a913 730 char * * volume,
657054d4 731 int * vol_len,
dca5a913 732 char * * root,
657054d4 733 int * root_len,
dca5a913 734 char * * dir,
657054d4 735 int * dir_len,
dca5a913 736 char * * name,
657054d4 737 int * name_len,
dca5a913 738 char * * ext,
657054d4 739 int * ext_len,
dca5a913 740 char * * version,
657054d4
JM		 741 int * ver_len)
742{
743struct dsc$descriptor path_desc;
744int status;
745unsigned long flags;
746int ret_stat;
747struct filescan_itmlst_2 item_list[9];
748const int filespec = 0;
749const int nodespec = 1;
750const int devspec = 2;
751const int rootspec = 3;
752const int dirspec = 4;
753const int namespec = 5;
754const int typespec = 6;
755const int verspec = 7;
756
757 /* Assume the worst for an easy exit */
758 ret_stat = -1;
759 *volume = NULL;
760 *vol_len = 0;
761 *root = NULL;
762 *root_len = 0;
763 *dir = NULL;
764 *dir_len;
765 *name = NULL;
766 *name_len = 0;
767 *ext = NULL;
768 *ext_len = 0;
769 *version = NULL;
770 *ver_len = 0;
771
772 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
773 path_desc.dsc$w_length = strlen(path);
774 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
775 path_desc.dsc$b_class = DSC$K_CLASS_S;
776
777 /* Get the total length, if it is shorter than the string passed
778 * then this was probably not a VMS formatted file specification
779 */
780 item_list[filespec].itmcode = FSCN$_FILESPEC;
781 item_list[filespec].length = 0;
782 item_list[filespec].component = NULL;
783
784 /* If the node is present, then it gets considered as part of the
785 * volume name to hopefully make things simple.
786 */
787 item_list[nodespec].itmcode = FSCN$_NODE;
788 item_list[nodespec].length = 0;
789 item_list[nodespec].component = NULL;
790
791 item_list[devspec].itmcode = FSCN$_DEVICE;
792 item_list[devspec].length = 0;
793 item_list[devspec].component = NULL;
794
795 /* root is a special case, adding it to either the directory or
796 * the device components will probalby complicate things for the
797 * callers of this routine, so leave it separate.
798 */
799 item_list[rootspec].itmcode = FSCN$_ROOT;
800 item_list[rootspec].length = 0;
801 item_list[rootspec].component = NULL;
802
803 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
804 item_list[dirspec].length = 0;
805 item_list[dirspec].component = NULL;
806
807 item_list[namespec].itmcode = FSCN$_NAME;
808 item_list[namespec].length = 0;
809 item_list[namespec].component = NULL;
810
811 item_list[typespec].itmcode = FSCN$_TYPE;
812 item_list[typespec].length = 0;
813 item_list[typespec].component = NULL;
814
815 item_list[verspec].itmcode = FSCN$_VERSION;
816 item_list[verspec].length = 0;
817 item_list[verspec].component = NULL;
818
819 item_list[8].itmcode = 0;
820 item_list[8].length = 0;
821 item_list[8].component = NULL;
822
7566800d 823 status = sys$filescan
657054d4
JM		 824 ((const struct dsc$descriptor_s *)&path_desc, item_list,
825 &flags, NULL, NULL);
360732b5 826 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
657054d4
JM		 827
828 /* If we parsed it successfully these two lengths should be the same */
829 if (path_desc.dsc$w_length != item_list[filespec].length)
830 return ret_stat;
831
832 /* If we got here, then it is a VMS file specification */
833 ret_stat = 0;
834
835 /* set the volume name */
836 if (item_list[nodespec].length > 0) {
837 *volume = item_list[nodespec].component;
838 *vol_len = item_list[nodespec].length + item_list[devspec].length;
839 }
840 else {
841 *volume = item_list[devspec].component;
842 *vol_len = item_list[devspec].length;
843 }
844
845 *root = item_list[rootspec].component;
846 *root_len = item_list[rootspec].length;
847
848 *dir = item_list[dirspec].component;
849 *dir_len = item_list[dirspec].length;
850
851 /* Now fun with versions and EFS file specifications
852 * The parser can not tell the difference when a "." is a version
853 * delimiter or a part of the file specification.
854 */
855 if ((decc_efs_charset) &&
856 (item_list[verspec].length > 0) &&
857 (item_list[verspec].component[0] == '.')) {
858 *name = item_list[namespec].component;
859 *name_len = item_list[namespec].length + item_list[typespec].length;
860 *ext = item_list[verspec].component;
861 *ext_len = item_list[verspec].length;
862 *version = NULL;
863 *ver_len = 0;
864 }
865 else {
866 *name = item_list[namespec].component;
867 *name_len = item_list[namespec].length;
868 *ext = item_list[typespec].component;
869 *ext_len = item_list[typespec].length;
870 *version = item_list[verspec].component;
871 *ver_len = item_list[verspec].length;
872 }
873 return ret_stat;
874}
875
f7ddb74a 876
fa537f88
CB		 877/* my_maxidx
878 * Routine to retrieve the maximum equivalence index for an input
879 * logical name. Some calls to this routine have no knowledge if
880 * the variable is a logical or not. So on error we return a max
881 * index of zero.
882 */
f7ddb74a 883/*{{{int my_maxidx(const char *lnm) */
fa537f88 884static int
f7ddb74a 885my_maxidx(const char *lnm)
fa537f88
CB		 886{
887 int status;
888 int midx;
889 int attr = LNM$M_CASE_BLIND;
890 struct dsc$descriptor lnmdsc;
891 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
892 {0, 0, 0, 0}};
893
894 lnmdsc.dsc$w_length = strlen(lnm);
895 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
896 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 897 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
fa537f88
CB		 898
899 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
900 if ((status & 1) == 0)
901 midx = 0;
902
903 return (midx);
904}
905/*}}}*/
906
f675dbe5 907/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
c07a80fd 908int
fd8cd3a3 909Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
f675dbe5 910 struct dsc$descriptor_s **tabvec, unsigned long int flags)
748a9306 911{
f7ddb74a
JM		 912 const char *cp1;
913 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
f675dbe5 914 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
748a9306 915 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
fa537f88 916 int midx;
f675dbe5
CB		 917 unsigned char acmode;
918 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
919 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
920 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
921 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
748a9306 922 {0, 0, 0, 0}};
f675dbe5 923 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
fd8cd3a3
DS		 924#if defined(PERL_IMPLICIT_CONTEXT)
925 pTHX = NULL;
fd8cd3a3
DS		 926 if (PL_curinterp) {
927 aTHX = PERL_GET_INTERP;
cc077a9f 928 } else {
fd8cd3a3 929 aTHX = NULL;
cc077a9f
HM		 930 }
931#endif
748a9306 932
fa537f88 933 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
b7ae7a0d 934 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
935 }
f7ddb74a 936 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 937 *cp2 = _toupper(*cp1);
938 if (cp1 - lnm > LNM$C_NAMLENGTH) {
939 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
940 return 0;
941 }
942 }
943 lnmdsc.dsc$w_length = cp1 - lnm;
944 lnmdsc.dsc$a_pointer = uplnm;
fd7385b9 945 uplnm[lnmdsc.dsc$w_length] = '\0';
f675dbe5
CB		 946 secure = flags & PERL__TRNENV_SECURE;
947 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
948 if (!tabvec || !*tabvec) tabvec = env_tables;
949
950 for (curtab = 0; tabvec[curtab]; curtab++) {
951 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
952 if (!ivenv && !secure) {
953 char *eq, *end;
954 int i;
955 if (!environ) {
956 ivenv = 1;
5c84aa53 957 Perl_warn(aTHX_ "Can't read CRTL environ\n");
f675dbe5
CB		 958 continue;
959 }
960 retsts = SS$_NOLOGNAM;
961 for (i = 0; environ[i]; i++) {
962 if ((eq = strchr(environ[i],'=')) &&
299d126a 963 lnmdsc.dsc$w_length == (eq - environ[i]) &&
f675dbe5
CB		 964 !strncmp(environ[i],uplnm,eq - environ[i])) {
965 eq++;
966 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
967 if (!eqvlen) continue;
968 retsts = SS$_NORMAL;
969 break;
970 }
971 }
972 if (retsts != SS$_NOLOGNAM) break;
973 }
974 }
975 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
976 !str$case_blind_compare(&tmpdsc,&clisym)) {
977 if (!ivsym && !secure) {
978 unsigned short int deflen = LNM$C_NAMLENGTH;
979 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
980 /* dynamic dsc to accomodate possible long value */
981 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
982 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
983 if (retsts & 1) {
2497a41f 984 if (eqvlen > MAX_DCL_SYMBOL) {
f675dbe5 985 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
2497a41f 986 eqvlen = MAX_DCL_SYMBOL;
cc077a9f
HM		 987 /* Special hack--we might be called before the interpreter's */
988 /* fully initialized, in which case either thr or PL_curcop */
989 /* might be bogus. We have to check, since ckWARN needs them */
990 /* both to be valid if running threaded */
cc077a9f 991 if (ckWARN(WARN_MISC)) {
f98bc0c6 992 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
cc077a9f 993 }
f675dbe5
CB		 994 }
995 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
996 }
997 _ckvmssts(lib$sfree1_dd(&eqvdsc));
998 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
999 if (retsts == LIB$_NOSUCHSYM) continue;
1000 break;
1001 }
1002 }
1003 else if (!ivlnm) {
843027b0 1004 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
f7ddb74a
JM		 1005 midx = my_maxidx(lnm);
1006 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1007 lnmlst[1].bufadr = cp2;
fa537f88
CB		 1008 eqvlen = 0;
1009 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1010 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1011 if (retsts == SS$_NOLOGNAM) break;
1012 /* PPFs have a prefix */
1013 if (
fd7385b9 1014#if INTSIZE == 4
fa537f88 1015 *((int *)uplnm) == *((int *)"SYS$") &&
fd7385b9 1016#endif
fa537f88
CB		 1017 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1018 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1019 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1020 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1021 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
18a3d61e 1022 memmove(eqv,eqv+4,eqvlen-4);
fa537f88
CB		 1023 eqvlen -= 4;
1024 }
f7ddb74a
JM		 1025 cp2 += eqvlen;
1026 *cp2 = '\0';
fa537f88
CB		 1027 }
1028 if ((retsts == SS$_IVLOGNAM) ||
1029 (retsts == SS$_NOLOGNAM)) { continue; }
fd7385b9 1030 }
fa537f88 1031 else {
fa537f88
CB		 1032 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1033 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1034 if (retsts == SS$_NOLOGNAM) continue;
1035 eqv[eqvlen] = '\0';
1036 }
1037 eqvlen = strlen(eqv);
f675dbe5
CB		 1038 break;
1039 }
c07a80fd 1040 }
f675dbe5
CB		 1041 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1042 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1043 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1044 retsts == SS$_NOLOGNAM) {
1045 set_errno(EINVAL); set_vaxc_errno(retsts);
748a9306 1046 }
f675dbe5
CB		 1047 else _ckvmssts(retsts);
1048 return 0;
1049} /* end of vmstrnenv */
1050/*}}}*/
c07a80fd 1051
f675dbe5
CB		 1052/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1053/* Define as a function so we can access statics. */
4b19af01 1054int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
f675dbe5
CB		 1055{
1056 return vmstrnenv(lnm,eqv,idx,fildev,
1057#ifdef SECURE_INTERNAL_GETENV
1058 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1059#else
1060 0
1061#endif
1062 );
1063}
1064/*}}}*/
a0d0e21e
LW		 1065
1066/* my_getenv
61bb5906
CB		 1067 * Note: Uses Perl temp to store result so char * can be returned to
1068 * caller; this pointer will be invalidated at next Perl statement
1069 * transition.
a6c40364 1070 * We define this as a function rather than a macro in terms of my_getenv_len()
f675dbe5
CB		 1071 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1072 * allocate SVs).
a0d0e21e 1073 */
f675dbe5 1074/*{{{ char *my_getenv(const char *lnm, bool sys)*/
a0d0e21e 1075char *
5c84aa53 1076Perl_my_getenv(pTHX_ const char *lnm, bool sys)
a0d0e21e 1077{
f7ddb74a 1078 const char *cp1;
fa537f88 1079 static char *__my_getenv_eqv = NULL;
f7ddb74a 1080 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
c07a80fd 1081 unsigned long int idx = 0;
bc10a425 1082 int trnsuccess, success, secure, saverr, savvmserr;
843027b0 1083 int midx, flags;
61bb5906 1084 SV *tmpsv;
a0d0e21e 1085
f7ddb74a 1086 midx = my_maxidx(lnm) + 1;
fa537f88 1087
6b88bc9c 1088 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
61bb5906
CB		 1089 /* Set up a temporary buffer for the return value; Perl will
1090 * clean it up at the next statement transition */
fa537f88 1091 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
61bb5906
CB		 1092 if (!tmpsv) return NULL;
1093 eqv = SvPVX(tmpsv);
1094 }
fa537f88
CB		 1095 else {
1096 /* Assume no interpreter ==> single thread */
1097 if (__my_getenv_eqv != NULL) {
1098 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1099 }
1100 else {
a02a5408 1101 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1102 }
1103 eqv = __my_getenv_eqv;
1104 }
1105
f7ddb74a 1106 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1107 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
2497a41f 1108 int len;
61bb5906 1109 getcwd(eqv,LNM$C_NAMLENGTH);
2497a41f
JM		 1110
1111 len = strlen(eqv);
1112
1113 /* Get rid of "000000/ in rooted filespecs */
1114 if (len > 7) {
1115 char * zeros;
1116 zeros = strstr(eqv, "/000000/");
1117 if (zeros != NULL) {
1118 int mlen;
1119 mlen = len - (zeros - eqv) - 7;
1120 memmove(zeros, &zeros[7], mlen);
1121 len = len - 7;
1122 eqv[len] = '\0';
1123 }
1124 }
61bb5906 1125 return eqv;
748a9306 1126 }
a0d0e21e 1127 else {
2512681b 1128 /* Impose security constraints only if tainting */
bc10a425
CB		 1129 if (sys) {
1130 /* Impose security constraints only if tainting */
1131 secure = PL_curinterp ? PL_tainting : will_taint;
1132 saverr = errno; savvmserr = vaxc$errno;
1133 }
843027b0
CB		 1134 else {
1135 secure = 0;
1136 }
1137
1138 flags =
f675dbe5 1139#ifdef SECURE_INTERNAL_GETENV
843027b0 1140 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1141#else
843027b0 1142 0
f675dbe5 1143#endif
843027b0
CB		 1144 ;
1145
1146 /* For the getenv interface we combine all the equivalence names
1147 * of a search list logical into one value to acquire a maximum
1148 * value length of 255*128 (assuming %ENV is using logicals).
1149 */
1150 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1151
1152 /* If the name contains a semicolon-delimited index, parse it
1153 * off and make sure we only retrieve the equivalence name for
1154 * that index. */
1155 if ((cp2 = strchr(lnm,';')) != NULL) {
1156 strcpy(uplnm,lnm);
1157 uplnm[cp2-lnm] = '\0';
1158 idx = strtoul(cp2+1,NULL,0);
1159 lnm = uplnm;
1160 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1161 }
1162
1163 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1164
bc10a425
CB		 1165 /* Discard NOLOGNAM on internal calls since we're often looking
1166 * for an optional name, and this "error" often shows up as the
1167 * (bogus) exit status for a die() call later on. */
1168 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1169 return success ? eqv : Nullch;
a0d0e21e 1170 }
a0d0e21e
LW		 1171
1172} /* end of my_getenv() */
1173/*}}}*/
1174
f675dbe5 1175
a6c40364
GS		 1176/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1177char *
fd8cd3a3 1178Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
f675dbe5 1179{
f7ddb74a
JM		 1180 const char *cp1;
1181 char *buf, *cp2;
a6c40364 1182 unsigned long idx = 0;
843027b0 1183 int midx, flags;
fa537f88 1184 static char *__my_getenv_len_eqv = NULL;
bc10a425 1185 int secure, saverr, savvmserr;
cc077a9f
HM		 1186 SV *tmpsv;
1187
f7ddb74a 1188 midx = my_maxidx(lnm) + 1;
fa537f88 1189
cc077a9f
HM		 1190 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1191 /* Set up a temporary buffer for the return value; Perl will
1192 * clean it up at the next statement transition */
fa537f88 1193 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
cc077a9f
HM		 1194 if (!tmpsv) return NULL;
1195 buf = SvPVX(tmpsv);
1196 }
fa537f88
CB		 1197 else {
1198 /* Assume no interpreter ==> single thread */
1199 if (__my_getenv_len_eqv != NULL) {
1200 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1201 }
1202 else {
a02a5408 1203 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1204 }
1205 buf = __my_getenv_len_eqv;
1206 }
1207
f7ddb74a 1208 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1209 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
f7ddb74a
JM		 1210 char * zeros;
1211
f675dbe5 1212 getcwd(buf,LNM$C_NAMLENGTH);
a6c40364 1213 *len = strlen(buf);
f7ddb74a
JM		 1214
1215 /* Get rid of "000000/ in rooted filespecs */
1216 if (*len > 7) {
1217 zeros = strstr(buf, "/000000/");
1218 if (zeros != NULL) {
1219 int mlen;
1220 mlen = *len - (zeros - buf) - 7;
1221 memmove(zeros, &zeros[7], mlen);
1222 *len = *len - 7;
1223 buf[*len] = '\0';
1224 }
1225 }
a6c40364 1226 return buf;
f675dbe5
CB		 1227 }
1228 else {
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 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1247
1248 if ((cp2 = strchr(lnm,';')) != NULL) {
1249 strcpy(buf,lnm);
1250 buf[cp2-lnm] = '\0';
1251 idx = strtoul(cp2+1,NULL,0);
1252 lnm = buf;
1253 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1254 }
1255
1256 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1257
f7ddb74a
JM		 1258 /* Get rid of "000000/ in rooted filespecs */
1259 if (*len > 7) {
1260 char * zeros;
1261 zeros = strstr(buf, "/000000/");
1262 if (zeros != NULL) {
1263 int mlen;
1264 mlen = *len - (zeros - buf) - 7;
1265 memmove(zeros, &zeros[7], mlen);
1266 *len = *len - 7;
1267 buf[*len] = '\0';
1268 }
1269 }
1270
bc10a425
CB		 1271 /* Discard NOLOGNAM on internal calls since we're often looking
1272 * for an optional name, and this "error" often shows up as the
1273 * (bogus) exit status for a die() call later on. */
1274 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1275 return *len ? buf : Nullch;
f675dbe5
CB		 1276 }
1277
a6c40364 1278} /* end of my_getenv_len() */
f675dbe5
CB		 1279/*}}}*/
1280
fd8cd3a3 1281static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
8fde5078
CB		 1282
1283static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1e422769 1284
740ce14c 1285/*{{{ void prime_env_iter() */
1286void
1287prime_env_iter(void)
1288/* Fill the %ENV associative array with all logical names we can
1289 * find, in preparation for iterating over it.
1290 */
1291{
17f28c40 1292 static int primed = 0;
3eeba6fb 1293 HV *seenhv = NULL, *envhv;
22be8b3c 1294 SV *sv = NULL;
f675dbe5 1295 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
8fde5078
CB		 1296 unsigned short int chan;
1297#ifndef CLI$M_TRUSTED
1298# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1299#endif
f675dbe5
CB		 1300 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1301 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1302 long int i;
1303 bool have_sym = FALSE, have_lnm = FALSE;
1304 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1305 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1306 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1307 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1308 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
fd8cd3a3
DS		 1309#if defined(PERL_IMPLICIT_CONTEXT)
1310 pTHX;
1311#endif
3db8f154 1312#if defined(USE_ITHREADS)
b2b3adea
HM		 1313 static perl_mutex primenv_mutex;
1314 MUTEX_INIT(&primenv_mutex);
61bb5906 1315#endif
740ce14c 1316
fd8cd3a3
DS		 1317#if defined(PERL_IMPLICIT_CONTEXT)
1318 /* We jump through these hoops because we can be called at */
1319 /* platform-specific initialization time, which is before anything is */
1320 /* set up--we can't even do a plain dTHX since that relies on the */
1321 /* interpreter structure to be initialized */
fd8cd3a3
DS		 1322 if (PL_curinterp) {
1323 aTHX = PERL_GET_INTERP;
1324 } else {
1325 aTHX = NULL;
1326 }
1327#endif
fd8cd3a3 1328
3eeba6fb 1329 if (primed || !PL_envgv) return;
61bb5906
CB		 1330 MUTEX_LOCK(&primenv_mutex);
1331 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
3eeba6fb 1332 envhv = GvHVn(PL_envgv);
740ce14c 1333 /* Perform a dummy fetch as an lval to insure that the hash table is
8fde5078 1334 * set up. Otherwise, the hv_store() will turn into a nullop. */
740ce14c 1335 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
740ce14c 1336
f675dbe5
CB		 1337 for (i = 0; env_tables[i]; i++) {
1338 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1339 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
f02a1854 1340 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
8fde5078 1341 }
f675dbe5
CB		 1342 if (have_sym || have_lnm) {
1343 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1344 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1345 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1346 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
61bb5906 1347 }
f675dbe5
CB		 1348
1349 for (i--; i >= 0; i--) {
1350 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1351 char *start;
1352 int j;
1353 for (j = 0; environ[j]; j++) {
1354 if (!(start = strchr(environ[j],'='))) {
3eeba6fb 1355 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1356 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
f675dbe5
CB		 1357 }
1358 else {
1359 start++;
22be8b3c
CB		 1360 sv = newSVpv(start,0);
1361 SvTAINTED_on(sv);
1362 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
f675dbe5
CB		 1363 }
1364 }
1365 continue;
740ce14c 1366 }
f675dbe5
CB		 1367 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1368 !str$case_blind_compare(&tmpdsc,&clisym)) {
1369 strcpy(cmd,"Show Symbol/Global *");
1370 cmddsc.dsc$w_length = 20;
1371 if (env_tables[i]->dsc$w_length == 12 &&
1372 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1373 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1374 flags = defflags | CLI$M_NOLOGNAM;
1375 }
1376 else {
1377 strcpy(cmd,"Show Logical *");
1378 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1379 strcat(cmd," /Table=");
1380 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1381 cmddsc.dsc$w_length = strlen(cmd);
1382 }
1383 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1384 flags = defflags | CLI$M_NOCLISYM;
1385 }
1386
1387 /* Create a new subprocess to execute each command, to exclude the
1388 * remote possibility that someone could subvert a mbx or file used
1389 * to write multiple commands to a single subprocess.
1390 */
1391 do {
1392 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1393 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1394 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1395 defflags &= ~CLI$M_TRUSTED;
1396 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1397 _ckvmssts(retsts);
a02a5408 1398 if (!buf) Newx(buf,mbxbufsiz + 1,char);
f675dbe5
CB		 1399 if (seenhv) SvREFCNT_dec(seenhv);
1400 seenhv = newHV();
1401 while (1) {
1402 char *cp1, *cp2, *key;
1403 unsigned long int sts, iosb[2], retlen, keylen;
1404 register U32 hash;
1405
1406 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1407 if (sts & 1) sts = iosb[0] & 0xffff;
1408 if (sts == SS$_ENDOFFILE) {
1409 int wakect = 0;
1410 while (substs == 0) { sys$hiber(); wakect++;}
1411 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1412 _ckvmssts(substs);
1413 break;
1414 }
1415 _ckvmssts(sts);
1416 retlen = iosb[0] >> 16;
1417 if (!retlen) continue; /* blank line */
1418 buf[retlen] = '\0';
1419 if (iosb[1] != subpid) {
1420 if (iosb[1]) {
5c84aa53 1421 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
f675dbe5
CB		 1422 }
1423 continue;
1424 }
3eeba6fb 1425 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
f98bc0c6 1426 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
f675dbe5
CB		 1427
1428 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1429 if (*cp1 == '(' || /* Logical name table name */
1430 *cp1 == '=' /* Next eqv of searchlist */) continue;
1431 if (*cp1 == '"') cp1++;
1432 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1433 key = cp1; keylen = cp2 - cp1;
1434 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1435 while (*cp2 && *cp2 != '=') cp2++;
1f47e8e2
CB		 1436 while (*cp2 && *cp2 == '=') cp2++;
1437 while (*cp2 && *cp2 == ' ') cp2++;
1438 if (*cp2 == '"') { /* String translation; may embed "" */
1439 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1440 cp2++; cp1--; /* Skip "" surrounding translation */
1441 }
1442 else { /* Numeric translation */
1443 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1444 cp1--; /* stop on last non-space char */
1445 }
1446 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
f98bc0c6 1447 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
edc7bc49
CB		 1448 continue;
1449 }
5afd6d42 1450 PERL_HASH(hash,key,keylen);
ff79d39d
CB		 1451
1452 if (cp1 == cp2 && *cp2 == '.') {
1453 /* A single dot usually means an unprintable character, such as a null
1454 * to indicate a zero-length value. Get the actual value to make sure.
1455 */
1456 char lnm[LNM$C_NAMLENGTH+1];
2497a41f 1457 char eqv[MAX_DCL_SYMBOL+1];
0faef845 1458 int trnlen;
ff79d39d 1459 strncpy(lnm, key, keylen);
0faef845 1460 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
ff79d39d
CB		 1461 sv = newSVpvn(eqv, strlen(eqv));
1462 }
1463 else {
1464 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1465 }
1466
22be8b3c
CB		 1467 SvTAINTED_on(sv);
1468 hv_store(envhv,key,keylen,sv,hash);
f675dbe5 1469 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
edc7bc49 1470 }
f675dbe5
CB		 1471 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1472 /* get the PPFs for this process, not the subprocess */
f7ddb74a 1473 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
f675dbe5
CB		 1474 char eqv[LNM$C_NAMLENGTH+1];
1475 int trnlen, i;
1476 for (i = 0; ppfs[i]; i++) {
1477 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
22be8b3c
CB		 1478 sv = newSVpv(eqv,trnlen);
1479 SvTAINTED_on(sv);
1480 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
f675dbe5 1481 }
740ce14c 1482 }
1483 }
f675dbe5
CB		 1484 primed = 1;
1485 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1486 if (buf) Safefree(buf);
1487 if (seenhv) SvREFCNT_dec(seenhv);
1488 MUTEX_UNLOCK(&primenv_mutex);
1489 return;
1490
740ce14c 1491} /* end of prime_env_iter */
1492/*}}}*/
740ce14c 1493
f675dbe5 1494
2c590a56 1495/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1496/* Define or delete an element in the same "environment" as
1497 * vmstrnenv(). If an element is to be deleted, it's removed from
1498 * the first place it's found. If it's to be set, it's set in the
1499 * place designated by the first element of the table vector.
3eeba6fb 1500 * Like setenv() returns 0 for success, non-zero on error.
a0d0e21e 1501 */
f675dbe5 1502int
2c590a56 1503Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
a0d0e21e 1504{
f7ddb74a
JM		 1505 const char *cp1;
1506 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
f675dbe5 1507 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
fa537f88 1508 int nseg = 0, j;
a0d0e21e 1509 unsigned long int retsts, usermode = PSL$C_USER;
fa537f88 1510 struct itmlst_3 *ile, *ilist;
a0d0e21e 1511 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
f675dbe5
CB		 1512 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1513 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1514 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1515 $DESCRIPTOR(local,"_LOCAL");
1516
ed253963
CB		 1517 if (!lnm) {
1518 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1519 return SS$_IVLOGNAM;
1520 }
1521
f7ddb74a 1522 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 1523 *cp2 = _toupper(*cp1);
1524 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1525 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1526 return SS$_IVLOGNAM;
1527 }
1528 }
a0d0e21e 1529 lnmdsc.dsc$w_length = cp1 - lnm;
f675dbe5
CB		 1530 if (!tabvec || !*tabvec) tabvec = env_tables;
1531
3eeba6fb 1532 if (!eqv) { /* we're deleting n element */
f675dbe5
CB		 1533 for (curtab = 0; tabvec[curtab]; curtab++) {
1534 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1535 int i;
299d126a 1536 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
f675dbe5 1537 if ((cp1 = strchr(environ[i],'=')) &&
299d126a 1538 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
f675dbe5 1539 !strncmp(environ[i],lnm,cp1 - environ[i])) {
3eeba6fb 1540#ifdef HAS_SETENV
0e06870b 1541 return setenv(lnm,"",1) ? vaxc$errno : 0;
f675dbe5
CB		 1542 }
1543 }
1544 ivenv = 1; retsts = SS$_NOLOGNAM;
1545#else
3eeba6fb 1546 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1547 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
3eeba6fb
CB		 1548 ivenv = 1; retsts = SS$_NOSUCHPGM;
1549 break;
1550 }
1551 }
f675dbe5
CB		 1552#endif
1553 }
1554 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1555 !str$case_blind_compare(&tmpdsc,&clisym)) {
1556 unsigned int symtype;
1557 if (tabvec[curtab]->dsc$w_length == 12 &&
1558 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1559 !str$case_blind_compare(&tmpdsc,&local))
1560 symtype = LIB$K_CLI_LOCAL_SYM;
1561 else symtype = LIB$K_CLI_GLOBAL_SYM;
1562 retsts = lib$delete_symbol(&lnmdsc,&symtype);
3eeba6fb
CB		 1563 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1564 if (retsts == LIB$_NOSUCHSYM) continue;
f675dbe5
CB		 1565 break;
1566 }
1567 else if (!ivlnm) {
1568 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1569 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1570 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1571 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1572 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1573 }
a0d0e21e
LW		 1574 }
1575 }
f675dbe5
CB		 1576 else { /* we're defining a value */
1577 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1578#ifdef HAS_SETENV
3eeba6fb 1579 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
f675dbe5 1580#else
3eeba6fb 1581 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1582 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
f675dbe5
CB		 1583 retsts = SS$_NOSUCHPGM;
1584#endif
1585 }
1586 else {
f7ddb74a 1587 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
f675dbe5
CB		 1588 eqvdsc.dsc$w_length = strlen(eqv);
1589 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1590 !str$case_blind_compare(&tmpdsc,&clisym)) {
1591 unsigned int symtype;
1592 if (tabvec[0]->dsc$w_length == 12 &&
1593 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1594 !str$case_blind_compare(&tmpdsc,&local))
1595 symtype = LIB$K_CLI_LOCAL_SYM;
1596 else symtype = LIB$K_CLI_GLOBAL_SYM;
1597 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1598 }
3eeba6fb
CB		 1599 else {
1600 if (!*eqv) eqvdsc.dsc$w_length = 1;
a1dfe751 1601 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
fa537f88
CB		 1602
1603 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1604 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1605 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1606 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1607 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1608 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1609 }
1610
a02a5408 1611 Newx(ilist,nseg+1,struct itmlst_3);
fa537f88
CB		 1612 ile = ilist;
1613 if (!ile) {
1614 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1615 return SS$_INSFMEM;
a1dfe751 1616 }
fa537f88
CB		 1617 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1618
1619 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1620 ile->itmcode = LNM$_STRING;
1621 ile->bufadr = c;
1622 if ((j+1) == nseg) {
1623 ile->buflen = strlen(c);
1624 /* in case we are truncating one that's too long */
1625 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1626 }
1627 else {
1628 ile->buflen = LNM$C_NAMLENGTH;
1629 }
1630 }
1631
1632 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1633 Safefree (ilist);
1634 }
1635 else {
1636 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
a1dfe751 1637 }
3eeba6fb 1638 }
f675dbe5
CB		 1639 }
1640 }
1641 if (!(retsts & 1)) {
1642 switch (retsts) {
1643 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1644 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1645 set_errno(EVMSERR); break;
1646 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1647 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1648 set_errno(EINVAL); break;
1649 case SS$_NOPRIV:
7d2497bf 1650 set_errno(EACCES); break;
f675dbe5
CB		 1651 default:
1652 _ckvmssts(retsts);
1653 set_errno(EVMSERR);
1654 }
1655 set_vaxc_errno(retsts);
1656 return (int) retsts || 44; /* retsts should never be 0, but just in case */
a0d0e21e 1657 }
3eeba6fb
CB		 1658 else {
1659 /* We reset error values on success because Perl does an hv_fetch()
1660 * before each hv_store(), and if the thing we're setting didn't
1661 * previously exist, we've got a leftover error message. (Of course,
1662 * this fails in the face of
1663 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1664 * in that the error reported in $! isn't spurious,
1665 * but it's right more often than not.)
1666 */
f675dbe5
CB		 1667 set_errno(0); set_vaxc_errno(retsts);
1668 return 0;
1669 }
1670
1671} /* end of vmssetenv() */
1672/*}}}*/
a0d0e21e 1673
2c590a56 1674/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1675/* This has to be a function since there's a prototype for it in proto.h */
1676void
2c590a56 1677Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
f675dbe5 1678{
bc10a425
CB		 1679 if (lnm && *lnm) {
1680 int len = strlen(lnm);
1681 if (len == 7) {
1682 char uplnm[8];
22d4bb9c
CB		 1683 int i;
1684 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
bc10a425 1685 if (!strcmp(uplnm,"DEFAULT")) {
7ded3206 1686 if (eqv && *eqv) my_chdir(eqv);
bc10a425
CB		 1687 return;
1688 }
1689 }
1690#ifndef RTL_USES_UTC
1691 if (len == 6 || len == 2) {
1692 char uplnm[7];
1693 int i;
1694 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1695 uplnm[len] = '\0';
1696 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1697 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
22d4bb9c
CB		 1698 }
1699#endif
1700 }
f675dbe5
CB		 1701 (void) vmssetenv(lnm,eqv,NULL);
1702}
a0d0e21e
LW		 1703/*}}}*/
1704
27c67b75 1705/*{{{static void vmssetuserlnm(char *name, char *eqv); */
0e06870b
CB		 1706/* vmssetuserlnm
1707 * sets a user-mode logical in the process logical name table
1708 * used for redirection of sys$error
1709 */
1710void
2fbb330f 1711Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
0e06870b
CB		 1712{
1713 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1714 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
2d5e9e5d 1715 unsigned long int iss, attr = LNM$M_CONFINE;
0e06870b
CB		 1716 unsigned char acmode = PSL$C_USER;
1717 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1718 {0, 0, 0, 0}};
2fbb330f 1719 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
0e06870b
CB		 1720 d_name.dsc$w_length = strlen(name);
1721
1722 lnmlst[0].buflen = strlen(eqv);
2fbb330f 1723 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
0e06870b
CB		 1724
1725 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1726 if (!(iss&1)) lib$signal(iss);
1727}
1728/*}}}*/
c07a80fd 1729
f675dbe5 1730
c07a80fd 1731/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1732/* my_crypt - VMS password hashing
1733 * my_crypt() provides an interface compatible with the Unix crypt()
1734 * C library function, and uses sys$hash_password() to perform VMS
1735 * password hashing. The quadword hashed password value is returned
1736 * as a NUL-terminated 8 character string. my_crypt() does not change
1737 * the case of its string arguments; in order to match the behavior
1738 * of LOGINOUT et al., alphabetic characters in both arguments must
1739 * be upcased by the caller.
2497a41f
JM		 1740 *
1741 * - fix me to call ACM services when available
c07a80fd 1742 */
1743char *
fd8cd3a3 1744Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd 1745{
1746# ifndef UAI$C_PREFERRED_ALGORITHM
1747# define UAI$C_PREFERRED_ALGORITHM 127
1748# endif
1749 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1750 unsigned short int salt = 0;
1751 unsigned long int sts;
1752 struct const_dsc {
1753 unsigned short int dsc$w_length;
1754 unsigned char dsc$b_type;
1755 unsigned char dsc$b_class;
1756 const char * dsc$a_pointer;
1757 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1758 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1759 struct itmlst_3 uailst[3] = {
1760 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1761 { sizeof salt, UAI$_SALT, &salt, 0},
1762 { 0, 0, NULL, NULL}};
1763 static char hash[9];
1764
1765 usrdsc.dsc$w_length = strlen(usrname);
1766 usrdsc.dsc$a_pointer = usrname;
1767 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1768 switch (sts) {
f282b18d 1769 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
c07a80fd 1770 set_errno(EACCES);
1771 break;
1772 case RMS$_RNF:
1773 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1774 break;
1775 default:
1776 set_errno(EVMSERR);
1777 }
1778 set_vaxc_errno(sts);
1779 if (sts != RMS$_RNF) return NULL;
1780 }
1781
1782 txtdsc.dsc$w_length = strlen(textpasswd);
1783 txtdsc.dsc$a_pointer = textpasswd;
1784 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1785 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1786 }
1787
1788 return (char *) hash;
1789
1790} /* end of my_crypt() */
1791/*}}}*/
1792
1793
360732b5
JM		 1794static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1795static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1796static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
a0d0e21e 1797
2497a41f
JM		 1798/* fixup barenames that are directories for internal use.
1799 * There have been problems with the consistent handling of UNIX
1800 * style directory names when routines are presented with a name that
1801 * has no directory delimitors at all. So this routine will eventually
1802 * fix the issue.
1803 */
1804static char * fixup_bare_dirnames(const char * name)
1805{
1806 if (decc_disable_to_vms_logname_translation) {
1807/* fix me */
1808 }
1809 return NULL;
1810}
1811
e0e5e8d6
JM		 1812/* 8.3, remove() is now broken on symbolic links */
1813static int rms_erase(const char * vmsname);
1814
1815
2497a41f
JM		 1816/* mp_do_kill_file
1817 * A little hack to get around a bug in some implemenation of remove()
1818 * that do not know how to delete a directory
1819 *
1820 * Delete any file to which user has control access, regardless of whether
1821 * delete access is explicitly allowed.
1822 * Limitations: User must have write access to parent directory.
1823 * Does not block signals or ASTs; if interrupted in midstream
1824 * may leave file with an altered ACL.
1825 * HANDLE WITH CARE!
1826 */
1827/*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1828static int
1829mp_do_kill_file(pTHX_ const char *name, int dirflag)
1830{
e0e5e8d6
JM		 1831 char *vmsname;
1832 char *rslt;
2497a41f
JM		 1833 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1834 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1835 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1836 struct myacedef {
1837 unsigned char myace$b_length;
1838 unsigned char myace$b_type;
1839 unsigned short int myace$w_flags;
1840 unsigned long int myace$l_access;
1841 unsigned long int myace$l_ident;
1842 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1843 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1844 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1845 struct itmlst_3
1846 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1847 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1848 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1849 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1850 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1851 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1852
1853 /* Expand the input spec using RMS, since the CRTL remove() and
1854 * system services won't do this by themselves, so we may miss
1855 * a file "hiding" behind a logical name or search list. */
c5375c28
JM		 1856 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1857 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1858
e0e5e8d6
JM		 1859 rslt = do_rmsexpand(name,
1860 vmsname,
1861 0,
1862 NULL,
1863 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1864 NULL,
1865 NULL);
1866 if (rslt == NULL) {
c5375c28 1867 PerlMem_free(vmsname);
2497a41f
JM		 1868 return -1;
1869 }
c5375c28 1870
e0e5e8d6
JM		 1871 /* Erase the file */
1872 rmsts = rms_erase(vmsname);
2497a41f 1873
e0e5e8d6
JM		 1874 /* Did it succeed */
1875 if ($VMS_STATUS_SUCCESS(rmsts)) {
1876 PerlMem_free(vmsname);
1877 return 0;
2497a41f
JM		 1878 }
1879
1880 /* If not, can changing protections help? */
e0e5e8d6
JM		 1881 if (rmsts != RMS$_PRV) {
1882 set_vaxc_errno(rmsts);
1883 PerlMem_free(vmsname);
2497a41f
JM		 1884 return -1;
1885 }
1886
1887 /* No, so we get our own UIC to use as a rights identifier,
1888 * and the insert an ACE at the head of the ACL which allows us
1889 * to delete the file.
1890 */
1891 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
e0e5e8d6
JM		 1892 fildsc.dsc$w_length = strlen(vmsname);
1893 fildsc.dsc$a_pointer = vmsname;
2497a41f
JM		 1894 cxt = 0;
1895 newace.myace$l_ident = oldace.myace$l_ident;
e0e5e8d6 1896 rmsts = -1;
2497a41f
JM		 1897 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1898 switch (aclsts) {
1899 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1900 set_errno(ENOENT); break;
1901 case RMS$_DIR:
1902 set_errno(ENOTDIR); break;
1903 case RMS$_DEV:
1904 set_errno(ENODEV); break;
1905 case RMS$_SYN: case SS$_INVFILFOROP:
1906 set_errno(EINVAL); break;
1907 case RMS$_PRV:
1908 set_errno(EACCES); break;
1909 default:
1910 _ckvmssts(aclsts);
1911 }
1912 set_vaxc_errno(aclsts);
e0e5e8d6 1913 PerlMem_free(vmsname);
2497a41f
JM		 1914 return -1;
1915 }
1916 /* Grab any existing ACEs with this identifier in case we fail */
1917 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1918 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1919 || fndsts == SS$_NOMOREACE ) {
1920 /* Add the new ACE . . . */
1921 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1922 goto yourroom;
1923
e0e5e8d6
JM		 1924 rmsts = rms_erase(vmsname);
1925 if ($VMS_STATUS_SUCCESS(rmsts)) {
1926 rmsts = 0;
2497a41f
JM		 1927 }
1928 else {
e0e5e8d6 1929 rmsts = -1;
2497a41f
JM		 1930 /* We blew it - dir with files in it, no write priv for
1931 * parent directory, etc. Put things back the way they were. */
1932 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1933 goto yourroom;
1934 if (fndsts & 1) {
1935 addlst[0].bufadr = &oldace;
1936 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1937 goto yourroom;
1938 }
1939 }
1940 }
1941
1942 yourroom:
1943 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1944 /* We just deleted it, so of course it's not there. Some versions of
1945 * VMS seem to return success on the unlock operation anyhow (after all
1946 * the unlock is successful), but others don't.
1947 */
1948 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1949 if (aclsts & 1) aclsts = fndsts;
1950 if (!(aclsts & 1)) {
1951 set_errno(EVMSERR);
1952 set_vaxc_errno(aclsts);
2497a41f
JM		 1953 }
1954
e0e5e8d6 1955 PerlMem_free(vmsname);
2497a41f
JM		 1956 return rmsts;
1957
1958} /* end of kill_file() */
1959/*}}}*/
1960
1961
a0d0e21e
LW		 1962/*{{{int do_rmdir(char *name)*/
1963int
b8ffc8df 1964Perl_do_rmdir(pTHX_ const char *name)
a0d0e21e 1965{
e0e5e8d6 1966 char * dirfile;
a0d0e21e 1967 int retval;
61bb5906 1968 Stat_t st;
a0d0e21e 1969
e0e5e8d6
JM		 1970 dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1971 if (dirfile == NULL)
1972 _ckvmssts(SS$_INSFMEM);
1973
1974 /* Force to a directory specification */
1975 if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1976 PerlMem_free(dirfile);
1977 return -1;
1978 }
dffb32cf 1979 if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
e0e5e8d6
JM		 1980 errno = ENOTDIR;
1981 retval = -1;
1982 }
1983 else
1984 retval = mp_do_kill_file(aTHX_ dirfile, 1);
1985
1986 PerlMem_free(dirfile);
a0d0e21e
LW		 1987 return retval;
1988
1989} /* end of do_rmdir */
1990/*}}}*/
1991
1992/* kill_file
1993 * Delete any file to which user has control access, regardless of whether
1994 * delete access is explicitly allowed.
1995 * Limitations: User must have write access to parent directory.
1996 * Does not block signals or ASTs; if interrupted in midstream
1997 * may leave file with an altered ACL.
1998 * HANDLE WITH CARE!
1999 */
2000/*{{{int kill_file(char *name)*/
2001int
b8ffc8df 2002Perl_kill_file(pTHX_ const char *name)
a0d0e21e 2003{
2f4077ca
JM		 2004 char rspec[NAM$C_MAXRSS+1];
2005 char *tspec;
e0e5e8d6
JM		 2006 Stat_t st;
2007 int rmsts;
a0d0e21e 2008
e0e5e8d6
JM		 2009 /* Remove() is allowed to delete directories, according to the X/Open
2010 * specifications.
4fdf8f88 2011 * This may need special handling to work with the ACL hacks.
a0d0e21e 2012 */
4fdf8f88 2013 if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
dffb32cf 2014 rmsts = Perl_do_rmdir(aTHX_ name);
e0e5e8d6 2015 return rmsts;
a0d0e21e
LW		 2016 }
2017
e0e5e8d6 2018 rmsts = mp_do_kill_file(aTHX_ name, 0);
a0d0e21e
LW		 2019
2020 return rmsts;
2021
2022} /* end of kill_file() */
2023/*}}}*/
2024
8cc95fdb 2025
84902520 2026/*{{{int my_mkdir(char *,Mode_t)*/
8cc95fdb 2027int
b8ffc8df 2028Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
8cc95fdb 2029{
2030 STRLEN dirlen = strlen(dir);
2031
a2a90019
CB		 2032 /* zero length string sometimes gives ACCVIO */
2033 if (dirlen == 0) return -1;
2034
8cc95fdb 2035 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2036 * null file name/type. However, it's commonplace under Unix,
2037 * so we'll allow it for a gain in portability.
2038 */
2039 if (dir[dirlen-1] == '/') {
2040 char *newdir = savepvn(dir,dirlen-1);
2041 int ret = mkdir(newdir,mode);
2042 Safefree(newdir);
2043 return ret;
2044 }
2045 else return mkdir(dir,mode);
2046} /* end of my_mkdir */
2047/*}}}*/
2048
ee8c7f54
CB		 2049/*{{{int my_chdir(char *)*/
2050int
b8ffc8df 2051Perl_my_chdir(pTHX_ const char *dir)
ee8c7f54
CB		 2052{
2053 STRLEN dirlen = strlen(dir);
ee8c7f54
CB		 2054
2055 /* zero length string sometimes gives ACCVIO */
2056 if (dirlen == 0) return -1;
f7ddb74a
JM		 2057 const char *dir1;
2058
2059 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2060 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2061 * so that existing scripts do not need to be changed.
2062 */
2063 dir1 = dir;
2064 while ((dirlen > 0) && (*dir1 == ' ')) {
2065 dir1++;
2066 dirlen--;
2067 }
ee8c7f54
CB		 2068
2069 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2070 * that implies
2071 * null file name/type. However, it's commonplace under Unix,
2072 * so we'll allow it for a gain in portability.
f7ddb74a
JM		 2073 *
2074 * - Preview- '/' will be valid soon on VMS
ee8c7f54 2075 */
f7ddb74a 2076 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
dca5a913 2077 char *newdir = savepvn(dir1,dirlen-1);
ee8c7f54
CB		 2078 int ret = chdir(newdir);
2079 Safefree(newdir);
2080 return ret;
2081 }
dca5a913 2082 else return chdir(dir1);
ee8c7f54
CB		 2083} /* end of my_chdir */
2084/*}}}*/
8cc95fdb 2085
674d6c38 2086
f1db9cda
JM		 2087/*{{{int my_chmod(char *, mode_t)*/
2088int
2089Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2090{
2091 STRLEN speclen = strlen(file_spec);
2092
2093 /* zero length string sometimes gives ACCVIO */
2094 if (speclen == 0) return -1;
2095
2096 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2097 * that implies null file name/type. However, it's commonplace under Unix,
2098 * so we'll allow it for a gain in portability.
2099 *
2100 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2101 * in VMS file.dir notation.
2102 */
2103 if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2104 char *vms_src, *vms_dir, *rslt;
2105 int ret = -1;
2106 errno = EIO;
2107
2108 /* First convert this to a VMS format specification */
2109 vms_src = PerlMem_malloc(VMS_MAXRSS);
2110 if (vms_src == NULL)
2111 _ckvmssts(SS$_INSFMEM);
2112
2113 rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2114 if (rslt == NULL) {
2115 /* If we fail, then not a file specification */
2116 PerlMem_free(vms_src);
2117 errno = EIO;
2118 return -1;
2119 }
2120
2121 /* Now make it a directory spec so chmod is happy */
2122 vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2123 if (vms_dir == NULL)
2124 _ckvmssts(SS$_INSFMEM);
2125 rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2126 PerlMem_free(vms_src);
2127
2128 /* Now do it */
2129 if (rslt != NULL) {
2130 ret = chmod(vms_dir, mode);
2131 } else {
2132 errno = EIO;
2133 }
2134 PerlMem_free(vms_dir);
2135 return ret;
2136 }
2137 else return chmod(file_spec, mode);
2138} /* end of my_chmod */
2139/*}}}*/
2140
2141
674d6c38
CB		 2142/*{{{FILE *my_tmpfile()*/
2143FILE *
2144my_tmpfile(void)
2145{
2146 FILE *fp;
2147 char *cp;
674d6c38
CB		 2148
2149 if ((fp = tmpfile())) return fp;
2150
c5375c28
JM		 2151 cp = PerlMem_malloc(L_tmpnam+24);
2152 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2153
2497a41f
JM		 2154 if (decc_filename_unix_only == 0)
2155 strcpy(cp,"Sys$Scratch:");
2156 else
2157 strcpy(cp,"/tmp/");
674d6c38
CB		 2158 tmpnam(cp+strlen(cp));
2159 strcat(cp,".Perltmp");
2160 fp = fopen(cp,"w+","fop=dlt");
c5375c28 2161 PerlMem_free(cp);
674d6c38
CB		 2162 return fp;
2163}
2164/*}}}*/
2165
5c2d7af2
CB		 2166
2167#ifndef HOMEGROWN_POSIX_SIGNALS
2168/*
2169 * The C RTL's sigaction fails to check for invalid signal numbers so we
2170 * help it out a bit. The docs are correct, but the actual routine doesn't
2171 * do what the docs say it will.
2172 */
2173/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2174int
2175Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2176 struct sigaction* oact)
2177{
2178 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2179 SETERRNO(EINVAL, SS$_INVARG);
2180 return -1;
2181 }
2182 return sigaction(sig, act, oact);
2183}
2184/*}}}*/
2185#endif
2186
f2610a60
CL		 2187#ifdef KILL_BY_SIGPRC
2188#include <errnodef.h>
2189
05c058bc
CB		 2190/* We implement our own kill() using the undocumented system service
2191 sys$sigprc for one of two reasons:
2192
2193 1.) If the kill() in an older CRTL uses sys$forcex, causing the
f2610a60
CL		 2194 target process to do a sys$exit, which usually can't be handled
2195 gracefully...certainly not by Perl and the %SIG{} mechanism.
2196
05c058bc
CB		 2197 2.) If the kill() in the CRTL can't be called from a signal
2198 handler without disappearing into the ether, i.e., the signal
2199 it purportedly sends is never trapped. Still true as of VMS 7.3.
2200
2201 sys$sigprc has the same parameters as sys$forcex, but throws an exception
f2610a60
CL		 2202 in the target process rather than calling sys$exit.
2203
2204 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2205 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2206 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2207 with condition codes C$_SIG0+nsig*8, catching the exception on the
2208 target process and resignaling with appropriate arguments.
2209
2210 But we don't have that VMS 7.0+ exception handler, so if you
2211 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2212
2213 Also note that SIGTERM is listed in the docs as being "unimplemented",
2214 yet always seems to be signaled with a VMS condition code of 4 (and
2215 correctly handled for that code). So we hardwire it in.
2216
2217 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2218 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2219 than signalling with an unrecognized (and unhandled by CRTL) code.
2220*/
2221
fe1de8ce 2222#define _MY_SIG_MAX 28
f2610a60 2223
9c1171d1
JM		 2224static unsigned int
2225Perl_sig_to_vmscondition_int(int sig)
f2610a60 2226{
2e34cc90 2227 static unsigned int sig_code[_MY_SIG_MAX+1] =
f2610a60
CL		 2228 {
2229 0, /* 0 ZERO */
2230 SS$_HANGUP, /* 1 SIGHUP */
2231 SS$_CONTROLC, /* 2 SIGINT */
2232 SS$_CONTROLY, /* 3 SIGQUIT */
2233 SS$_RADRMOD, /* 4 SIGILL */
2234 SS$_BREAK, /* 5 SIGTRAP */
2235 SS$_OPCCUS, /* 6 SIGABRT */
2236 SS$_COMPAT, /* 7 SIGEMT */
2237#ifdef __VAX
2238 SS$_FLTOVF, /* 8 SIGFPE VAX */
2239#else
2240 SS$_HPARITH, /* 8 SIGFPE AXP */
2241#endif
2242 SS$_ABORT, /* 9 SIGKILL */
2243 SS$_ACCVIO, /* 10 SIGBUS */
2244 SS$_ACCVIO, /* 11 SIGSEGV */
2245 SS$_BADPARAM, /* 12 SIGSYS */
2246 SS$_NOMBX, /* 13 SIGPIPE */
2247 SS$_ASTFLT, /* 14 SIGALRM */
2248 4, /* 15 SIGTERM */
2249 0, /* 16 SIGUSR1 */
fe1de8ce
CB		 2250 0, /* 17 SIGUSR2 */
2251 0, /* 18 */
2252 0, /* 19 */
2253 0, /* 20 SIGCHLD */
2254 0, /* 21 SIGCONT */
2255 0, /* 22 SIGSTOP */
2256 0, /* 23 SIGTSTP */
2257 0, /* 24 SIGTTIN */
2258 0, /* 25 SIGTTOU */
2259 0, /* 26 */
2260 0, /* 27 */
2261 0 /* 28 SIGWINCH */
f2610a60
CL		 2262 };
2263
2264#if __VMS_VER >= 60200000
2265 static int initted = 0;
2266 if (!initted) {
2267 initted = 1;
2268 sig_code[16] = C$_SIGUSR1;
2269 sig_code[17] = C$_SIGUSR2;
fe1de8ce
CB		 2270#if __CRTL_VER >= 70000000
2271 sig_code[20] = C$_SIGCHLD;
2272#endif
2273#if __CRTL_VER >= 70300000
2274 sig_code[28] = C$_SIGWINCH;
2275#endif
f2610a60
CL		 2276 }
2277#endif
2278
2e34cc90
CL		 2279 if (sig < _SIG_MIN) return 0;
2280 if (sig > _MY_SIG_MAX) return 0;
2281 return sig_code[sig];
2282}
2283
9c1171d1
JM		 2284unsigned int
2285Perl_sig_to_vmscondition(int sig)
2286{
2287#ifdef SS$_DEBUG
2288 if (vms_debug_on_exception != 0)
2289 lib$signal(SS$_DEBUG);
2290#endif
2291 return Perl_sig_to_vmscondition_int(sig);
2292}
2293
2294
2e34cc90
CL		 2295int
2296Perl_my_kill(int pid, int sig)
2297{
218fdd94 2298 dTHX;
2e34cc90
CL		 2299 int iss;
2300 unsigned int code;
2301 int sys$sigprc(unsigned int *pidadr,
2302 struct dsc$descriptor_s *prcname,
2303 unsigned int code);
2304
7a7fd8e0
JM		 2305 /* sig 0 means validate the PID */
2306 /*------------------------------*/
2307 if (sig == 0) {
2308 const unsigned long int jpicode = JPI$_PID;
2309 pid_t ret_pid;
2310 int status;
2311 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2312 if ($VMS_STATUS_SUCCESS(status))
2313 return 0;
2314 switch (status) {
2315 case SS$_NOSUCHNODE:
2316 case SS$_UNREACHABLE:
2317 case SS$_NONEXPR:
2318 errno = ESRCH;
2319 break;
2320 case SS$_NOPRIV:
2321 errno = EPERM;
2322 break;
2323 default:
2324 errno = EVMSERR;
2325 }
2326 vaxc$errno=status;
2327 return -1;
2328 }
2329
9c1171d1 2330 code = Perl_sig_to_vmscondition_int(sig);
2e34cc90 2331
7a7fd8e0
JM		 2332 if (!code) {
2333 SETERRNO(EINVAL, SS$_BADPARAM);
2334 return -1;
2335 }
2336
2337 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2338 * signals are to be sent to multiple processes.
2339 * pid = 0 - all processes in group except ones that the system exempts
2340 * pid = -1 - all processes except ones that the system exempts
2341 * pid = -n - all processes in group (abs(n)) except ...
2342 * For now, just report as not supported.
2343 */
2344
2345 if (pid <= 0) {
2346 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
f2610a60
CL		 2347 return -1;
2348 }
2349
2e34cc90 2350 iss = sys$sigprc((unsigned int *)&pid,0,code);
f2610a60
CL		 2351 if (iss&1) return 0;
2352
2353 switch (iss) {
2354 case SS$_NOPRIV:
2355 set_errno(EPERM); break;
2356 case SS$_NONEXPR:
2357 case SS$_NOSUCHNODE:
2358 case SS$_UNREACHABLE:
2359 set_errno(ESRCH); break;
2360 case SS$_INSFMEM:
2361 set_errno(ENOMEM); break;
2362 default:
2363 _ckvmssts(iss);
2364 set_errno(EVMSERR);
2365 }
2366 set_vaxc_errno(iss);
2367
2368 return -1;
2369}
2370#endif
2371
2fbb330f
JM		 2372/* Routine to convert a VMS status code to a UNIX status code.
2373** More tricky than it appears because of conflicting conventions with
2374** existing code.
2375**
2376** VMS status codes are a bit mask, with the least significant bit set for
2377** success.
2378**
2379** Special UNIX status of EVMSERR indicates that no translation is currently
2380** available, and programs should check the VMS status code.
2381**
2382** Programs compiled with _POSIX_EXIT have a special encoding that requires
2383** decoding.
2384*/
2385
2386#ifndef C_FACILITY_NO
2387#define C_FACILITY_NO 0x350000
2388#endif
2389#ifndef DCL_IVVERB
2390#define DCL_IVVERB 0x38090
2391#endif
2392
7a7fd8e0 2393int Perl_vms_status_to_unix(int vms_status, int child_flag)
2fbb330f
JM		 2394{
2395int facility;
2396int fac_sp;
2397int msg_no;
2398int msg_status;
2399int unix_status;
2400
2401 /* Assume the best or the worst */
2402 if (vms_status & STS$M_SUCCESS)
2403 unix_status = 0;
2404 else
2405 unix_status = EVMSERR;
2406
2407 msg_status = vms_status & ~STS$M_CONTROL;
2408
2409 facility = vms_status & STS$M_FAC_NO;
2410 fac_sp = vms_status & STS$M_FAC_SP;
2411 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2412
0968cdad 2413 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2fbb330f
JM		 2414 switch(msg_no) {
2415 case SS$_NORMAL:
2416 unix_status = 0;
2417 break;
2418 case SS$_ACCVIO:
2419 unix_status = EFAULT;
2420 break;
7a7fd8e0
JM		 2421 case SS$_DEVOFFLINE:
2422 unix_status = EBUSY;
2423 break;
2424 case SS$_CLEARED:
2425 unix_status = ENOTCONN;
2426 break;
2427 case SS$_IVCHAN:
2fbb330f
JM		 2428 case SS$_IVLOGNAM:
2429 case SS$_BADPARAM:
2430 case SS$_IVLOGTAB:
2431 case SS$_NOLOGNAM:
2432 case SS$_NOLOGTAB:
2433 case SS$_INVFILFOROP:
2434 case SS$_INVARG:
2435 case SS$_NOSUCHID:
2436 case SS$_IVIDENT:
2437 unix_status = EINVAL;
2438 break;
7a7fd8e0
JM		 2439 case SS$_UNSUPPORTED:
2440 unix_status = ENOTSUP;
2441 break;
2fbb330f
JM		 2442 case SS$_FILACCERR:
2443 case SS$_NOGRPPRV:
2444 case SS$_NOSYSPRV:
2445 unix_status = EACCES;
2446 break;
2447 case SS$_DEVICEFULL:
2448 unix_status = ENOSPC;
2449 break;
2450 case SS$_NOSUCHDEV:
2451 unix_status = ENODEV;
2452 break;
2453 case SS$_NOSUCHFILE:
2454 case SS$_NOSUCHOBJECT:
2455 unix_status = ENOENT;
2456 break;
fb38d079
JM		 2457 case SS$_ABORT: /* Fatal case */
2458 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2459 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2fbb330f
JM		 2460 unix_status = EINTR;
2461 break;
2462 case SS$_BUFFEROVF:
2463 unix_status = E2BIG;
2464 break;
2465 case SS$_INSFMEM:
2466 unix_status = ENOMEM;
2467 break;
2468 case SS$_NOPRIV:
2469 unix_status = EPERM;
2470 break;
2471 case SS$_NOSUCHNODE:
2472 case SS$_UNREACHABLE:
2473 unix_status = ESRCH;
2474 break;
2475 case SS$_NONEXPR:
2476 unix_status = ECHILD;
2477 break;
2478 default:
2479 if ((facility == 0) && (msg_no < 8)) {
2480 /* These are not real VMS status codes so assume that they are
2481 ** already UNIX status codes
2482 */
2483 unix_status = msg_no;
2484 break;
2485 }
2486 }
2487 }
2488 else {
2489 /* Translate a POSIX exit code to a UNIX exit code */
2490 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
7a7fd8e0 2491 unix_status = (msg_no & 0x07F8) >> 3;
2fbb330f
JM		 2492 }
2493 else {
7a7fd8e0
JM		 2494
2495 /* Documented traditional behavior for handling VMS child exits */
2496 /*--------------------------------------------------------------*/
2497 if (child_flag != 0) {
2498
2499 /* Success / Informational return 0 */
2500 /*----------------------------------*/
2501 if (msg_no & STS$K_SUCCESS)
2502 return 0;
2503
2504 /* Warning returns 1 */
2505 /*-------------------*/
2506 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2507 return 1;
2508
2509 /* Everything else pass through the severity bits */
2510 /*------------------------------------------------*/
2511 return (msg_no & STS$M_SEVERITY);
2512 }
2513
2514 /* Normal VMS status to ERRNO mapping attempt */
2515 /*--------------------------------------------*/
2fbb330f
JM		 2516 switch(msg_status) {
2517 /* case RMS$_EOF: */ /* End of File */
2518 case RMS$_FNF: /* File Not Found */
2519 case RMS$_DNF: /* Dir Not Found */
2520 unix_status = ENOENT;
2521 break;
2522 case RMS$_RNF: /* Record Not Found */
2523 unix_status = ESRCH;
2524 break;
2525 case RMS$_DIR:
2526 unix_status = ENOTDIR;
2527 break;
2528 case RMS$_DEV:
2529 unix_status = ENODEV;
2530 break;
7a7fd8e0
JM		 2531 case RMS$_IFI:
2532 case RMS$_FAC:
2533 case RMS$_ISI:
2534 unix_status = EBADF;
2535 break;
2536 case RMS$_FEX:
2537 unix_status = EEXIST;
2538 break;
2fbb330f
JM		 2539 case RMS$_SYN:
2540 case RMS$_FNM:
2541 case LIB$_INVSTRDES:
2542 case LIB$_INVARG:
2543 case LIB$_NOSUCHSYM:
2544 case LIB$_INVSYMNAM:
2545 case DCL_IVVERB:
2546 unix_status = EINVAL;
2547 break;
2548 case CLI$_BUFOVF:
2549 case RMS$_RTB:
2550 case CLI$_TKNOVF:
2551 case CLI$_RSLOVF:
2552 unix_status = E2BIG;
2553 break;
2554 case RMS$_PRV: /* No privilege */
2555 case RMS$_ACC: /* ACP file access failed */
2556 case RMS$_WLK: /* Device write locked */
2557 unix_status = EACCES;
2558 break;
2559 /* case RMS$_NMF: */ /* No more files */
2560 }
2561 }
2562 }
2563
2564 return unix_status;
2565}
2566
7a7fd8e0
JM		 2567/* Try to guess at what VMS error status should go with a UNIX errno
2568 * value. This is hard to do as there could be many possible VMS
2569 * error statuses that caused the errno value to be set.
2570 */
2571
2572int Perl_unix_status_to_vms(int unix_status)
2573{
2574int test_unix_status;
2575
2576 /* Trivial cases first */
2577 /*---------------------*/
2578 if (unix_status == EVMSERR)
2579 return vaxc$errno;
2580
2581 /* Is vaxc$errno sane? */
2582 /*---------------------*/
2583 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2584 if (test_unix_status == unix_status)
2585 return vaxc$errno;
2586
2587 /* If way out of range, must be VMS code already */
2588 /*-----------------------------------------------*/
2589 if (unix_status > EVMSERR)
2590 return unix_status;
2591
2592 /* If out of range, punt */
2593 /*-----------------------*/
2594 if (unix_status > __ERRNO_MAX)
2595 return SS$_ABORT;
2596
2597
2598 /* Ok, now we have to do it the hard way. */
2599 /*----------------------------------------*/
2600 switch(unix_status) {
2601 case 0: return SS$_NORMAL;
2602 case EPERM: return SS$_NOPRIV;
2603 case ENOENT: return SS$_NOSUCHOBJECT;
2604 case ESRCH: return SS$_UNREACHABLE;
2605 case EINTR: return SS$_ABORT;
2606 /* case EIO: */
2607 /* case ENXIO: */
2608 case E2BIG: return SS$_BUFFEROVF;
2609 /* case ENOEXEC */
2610 case EBADF: return RMS$_IFI;
2611 case ECHILD: return SS$_NONEXPR;
2612 /* case EAGAIN */
2613 case ENOMEM: return SS$_INSFMEM;
2614 case EACCES: return SS$_FILACCERR;
2615 case EFAULT: return SS$_ACCVIO;
2616 /* case ENOTBLK */
0968cdad 2617 case EBUSY: return SS$_DEVOFFLINE;
7a7fd8e0
JM		 2618 case EEXIST: return RMS$_FEX;
2619 /* case EXDEV */
2620 case ENODEV: return SS$_NOSUCHDEV;
2621 case ENOTDIR: return RMS$_DIR;
2622 /* case EISDIR */
2623 case EINVAL: return SS$_INVARG;
2624 /* case ENFILE */
2625 /* case EMFILE */
2626 /* case ENOTTY */
2627 /* case ETXTBSY */
2628 /* case EFBIG */
2629 case ENOSPC: return SS$_DEVICEFULL;
2630 case ESPIPE: return LIB$_INVARG;
2631 /* case EROFS: */
2632 /* case EMLINK: */
2633 /* case EPIPE: */
2634 /* case EDOM */
2635 case ERANGE: return LIB$_INVARG;
2636 /* case EWOULDBLOCK */
2637 /* case EINPROGRESS */
2638 /* case EALREADY */
2639 /* case ENOTSOCK */
2640 /* case EDESTADDRREQ */
2641 /* case EMSGSIZE */
2642 /* case EPROTOTYPE */
2643 /* case ENOPROTOOPT */
2644 /* case EPROTONOSUPPORT */
2645 /* case ESOCKTNOSUPPORT */
2646 /* case EOPNOTSUPP */
2647 /* case EPFNOSUPPORT */
2648 /* case EAFNOSUPPORT */
2649 /* case EADDRINUSE */
2650 /* case EADDRNOTAVAIL */
2651 /* case ENETDOWN */
2652 /* case ENETUNREACH */
2653 /* case ENETRESET */
2654 /* case ECONNABORTED */
2655 /* case ECONNRESET */
2656 /* case ENOBUFS */
2657 /* case EISCONN */
2658 case ENOTCONN: return SS$_CLEARED;
2659 /* case ESHUTDOWN */
2660 /* case ETOOMANYREFS */
2661 /* case ETIMEDOUT */
2662 /* case ECONNREFUSED */
2663 /* case ELOOP */
2664 /* case ENAMETOOLONG */
2665 /* case EHOSTDOWN */
2666 /* case EHOSTUNREACH */
2667 /* case ENOTEMPTY */
2668 /* case EPROCLIM */
2669 /* case EUSERS */
2670 /* case EDQUOT */
2671 /* case ENOMSG */
2672 /* case EIDRM */
2673 /* case EALIGN */
2674 /* case ESTALE */
2675 /* case EREMOTE */
2676 /* case ENOLCK */
2677 /* case ENOSYS */
2678 /* case EFTYPE */
2679 /* case ECANCELED */
2680 /* case EFAIL */
2681 /* case EINPROG */
2682 case ENOTSUP:
2683 return SS$_UNSUPPORTED;
2684 /* case EDEADLK */
2685 /* case ENWAIT */
2686 /* case EILSEQ */
2687 /* case EBADCAT */
2688 /* case EBADMSG */
2689 /* case EABANDONED */
2690 default:
2691 return SS$_ABORT; /* punt */
2692 }
2693
2694 return SS$_ABORT; /* Should not get here */
2695}
2fbb330f
JM		 2696
2697
22d4bb9c
CB		 2698/* default piping mailbox size */
2699#define PERL_BUFSIZ 512
2700
674d6c38 2701
a0d0e21e 2702static void
fd8cd3a3 2703create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 2704{
22d4bb9c
CB		 2705 unsigned long int mbxbufsiz;
2706 static unsigned long int syssize = 0;
2707 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 2708 char csize[LNM$C_NAMLENGTH+1];
f7ddb74a
JM		 2709 int sts;
2710
22d4bb9c
CB		 2711 if (!syssize) {
2712 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 2713 /*
22d4bb9c
CB		 2714 * Get the SYSGEN parameter MAXBUF
2715 *
2716 * If the logical 'PERL_MBX_SIZE' is defined
2717 * use the value of the logical instead of PERL_BUFSIZ, but
2718 * keep the size between 128 and MAXBUF.
2719 *
a0d0e21e 2720 */
22d4bb9c
CB		 2721 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2722 }
2723
2724 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2725 mbxbufsiz = atoi(csize);
2726 } else {
2727 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 2728 }
22d4bb9c
CB		 2729 if (mbxbufsiz < 128) mbxbufsiz = 128;
2730 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2731
f7ddb74a 2732 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 2733
f7ddb74a 2734 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
a0d0e21e
LW		 2735 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2736
2737} /* end of create_mbx() */
2738
22d4bb9c 2739
a0d0e21e 2740/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 2741
2742typedef struct _iosb IOSB;
2743typedef struct _iosb* pIOSB;
2744typedef struct _pipe Pipe;
2745typedef struct _pipe* pPipe;
2746typedef struct pipe_details Info;
2747typedef struct pipe_details* pInfo;
2748typedef struct _srqp RQE;
2749typedef struct _srqp* pRQE;
2750typedef struct _tochildbuf CBuf;
2751typedef struct _tochildbuf* pCBuf;
2752
2753struct _iosb {
2754 unsigned short status;
2755 unsigned short count;
2756 unsigned long dvispec;
2757};
2758
2759#pragma member_alignment save
2760#pragma nomember_alignment quadword
2761struct _srqp { /* VMS self-relative queue entry */
2762 unsigned long qptr[2];
2763};
2764#pragma member_alignment restore
2765static RQE RQE_ZERO = {0,0};
2766
2767struct _tochildbuf {
2768 RQE q;
2769 int eof;
2770 unsigned short size;
2771 char *buf;
2772};
2773
2774struct _pipe {
2775 RQE free;
2776 RQE wait;
2777 int fd_out;
2778 unsigned short chan_in;
2779 unsigned short chan_out;
2780 char *buf;
2781 unsigned int bufsize;
2782 IOSB iosb;
2783 IOSB iosb2;
2784 int *pipe_done;
2785 int retry;
2786 int type;
2787 int shut_on_empty;
2788 int need_wake;
2789 pPipe *home;
2790 pInfo info;
2791 pCBuf curr;
2792 pCBuf curr2;
fd8cd3a3
DS		 2793#if defined(PERL_IMPLICIT_CONTEXT)
2794 void *thx; /* Either a thread or an interpreter */
2795 /* pointer, depending on how we're built */
2796#endif
22d4bb9c
CB		 2797};
2798
2799
a0d0e21e
LW		 2800struct pipe_details
2801{
22d4bb9c 2802 pInfo next;
ff7adb52
CL		 2803 PerlIO *fp; /* file pointer to pipe mailbox */
2804 int useFILE; /* using stdio, not perlio */
748a9306
LW		 2805 int pid; /* PID of subprocess */
2806 int mode; /* == 'r' if pipe open for reading */
2807 int done; /* subprocess has completed */
ff7adb52 2808 int waiting; /* waiting for completion/closure */
22d4bb9c
CB		 2809 int closing; /* my_pclose is closing this pipe */
2810 unsigned long completion; /* termination status of subprocess */
2811 pPipe in; /* pipe in to sub */
2812 pPipe out; /* pipe out of sub */
2813 pPipe err; /* pipe of sub's sys$error */
2814 int in_done; /* true when in pipe finished */
2815 int out_done;
2816 int err_done;
cd1191f1
CB		 2817 unsigned short xchan; /* channel to debug xterm */
2818 unsigned short xchan_valid; /* channel is assigned */
a0d0e21e
LW		 2819};
2820
748a9306
LW		 2821struct exit_control_block
2822{
2823 struct exit_control_block *flink;
2824 unsigned long int (*exit_routine)();
2825 unsigned long int arg_count;
2826 unsigned long int *status_address;
2827 unsigned long int exit_status;
2828};
2829
d85f548a
JH		 2830typedef struct _closed_pipes Xpipe;
2831typedef struct _closed_pipes* pXpipe;
2832
2833struct _closed_pipes {
2834 int pid; /* PID of subprocess */
2835 unsigned long completion; /* termination status of subprocess */
2836};
2837#define NKEEPCLOSED 50
2838static Xpipe closed_list[NKEEPCLOSED];
2839static int closed_index = 0;
2840static int closed_num = 0;
2841
22d4bb9c
CB		 2842#define RETRY_DELAY "0 ::0.20"
2843#define MAX_RETRY 50
a0d0e21e 2844
22d4bb9c
CB		 2845static int pipe_ef = 0; /* first call to safe_popen inits these*/
2846static unsigned long mypid;
2847static unsigned long delaytime[2];
2848
2849static pInfo open_pipes = NULL;
2850static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 2851
ff7adb52
CL		 2852#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2853
2854
3eeba6fb 2855
748a9306 2856static unsigned long int
fd8cd3a3 2857pipe_exit_routine(pTHX)
748a9306 2858{
22d4bb9c 2859 pInfo info;
1e422769 2860 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
ff7adb52
CL		 2861 int sts, did_stuff, need_eof, j;
2862
5ce486e0
CB		 2863 /*
2864 * Flush any pending i/o, but since we are in process run-down, be
2865 * careful about referencing PerlIO structures that may already have
2866 * been deallocated. We may not even have an interpreter anymore.
ff7adb52
CL		 2867 */
2868 info = open_pipes;
2869 while (info) {
2870 if (info->fp) {
5ce486e0
CB		 2871 if (!info->useFILE
2872#if defined(USE_ITHREADS)
2873 && my_perl
2874#endif
2875 && PL_perlio_fd_refcnt)
2876 PerlIO_flush(info->fp);
ff7adb52
CL		 2877 else
2878 fflush((FILE *)info->fp);
2879 }
2880 info = info->next;
2881 }
3eeba6fb
CB		 2882
2883 /*
ff7adb52 2884 next we try sending an EOF...ignore if doesn't work, make sure we
3eeba6fb
CB		 2885 don't hang
2886 */
2887 did_stuff = 0;
2888 info = open_pipes;
748a9306 2889
3eeba6fb 2890 while (info) {
b2b89246 2891 int need_eof;
d4c83939 2892 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 2893 if (info->in && !info->in->shut_on_empty) {
d4c83939 2894 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
22d4bb9c 2895 0, 0, 0, 0, 0, 0));
ff7adb52 2896 info->waiting = 1;
22d4bb9c 2897 did_stuff = 1;
748a9306 2898 }
d4c83939 2899 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2900 info = info->next;
2901 }
ff7adb52
CL		 2902
2903 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2904
2905 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2906 int nwait = 0;
2907
2908 info = open_pipes;
2909 while (info) {
d4c83939 2910 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 2911 if (info->waiting && info->done)
2912 info->waiting = 0;
2913 nwait += info->waiting;
d4c83939 2914 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 2915 info = info->next;
2916 }
2917 if (!nwait) break;
2918 sleep(1);
2919 }
3eeba6fb
CB		 2920
2921 did_stuff = 0;
2922 info = open_pipes;
2923 while (info) {
d4c83939 2924 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 2925 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2926 sts = sys$forcex(&info->pid,0,&abort);
d4c83939 2927 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3eeba6fb
CB		 2928 did_stuff = 1;
2929 }
d4c83939 2930 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2931 info = info->next;
2932 }
ff7adb52
CL		 2933
2934 /* again, wait for effect */
2935
2936 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2937 int nwait = 0;
2938
2939 info = open_pipes;
2940 while (info) {
d4c83939 2941 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 2942 if (info->waiting && info->done)
2943 info->waiting = 0;
2944 nwait += info->waiting;
d4c83939 2945 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 2946 info = info->next;
2947 }
2948 if (!nwait) break;
2949 sleep(1);
2950 }
3eeba6fb
CB		 2951
2952 info = open_pipes;
2953 while (info) {
d4c83939 2954 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 2955 if (!info->done) { /* We tried to be nice . . . */
2956 sts = sys$delprc(&info->pid,0);
d4c83939 2957 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2f1dcba4 2958 info->done = 1; /* sys$delprc is as done as we're going to get. */
3eeba6fb 2959 }
d4c83939 2960 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2961 info = info->next;
2962 }
2963
2964 while(open_pipes) {
1e422769 2965 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2966 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 2967 }
2968 return retsts;
2969}
2970
2971static struct exit_control_block pipe_exitblock =
2972 {(struct exit_control_block *) 0,
2973 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2974
22d4bb9c
CB		 2975static void pipe_mbxtofd_ast(pPipe p);
2976static void pipe_tochild1_ast(pPipe p);
2977static void pipe_tochild2_ast(pPipe p);
748a9306 2978
a0d0e21e 2979static void
22d4bb9c 2980popen_completion_ast(pInfo info)
a0d0e21e 2981{
22d4bb9c
CB		 2982 pInfo i = open_pipes;
2983 int iss;
f7ddb74a 2984 int sts;
d85f548a
JH		 2985 pXpipe x;
2986
2987 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2988 closed_list[closed_index].pid = info->pid;
2989 closed_list[closed_index].completion = info->completion;
2990 closed_index++;
2991 if (closed_index == NKEEPCLOSED)
2992 closed_index = 0;
2993 closed_num++;
22d4bb9c
CB		 2994
2995 while (i) {
2996 if (i == info) break;
2997 i = i->next;
2998 }
2999 if (!i) return; /* unlinked, probably freed too */
3000
22d4bb9c
CB		 3001 info->done = TRUE;
3002
3003/*
3004 Writing to subprocess ...
3005 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3006
3007 chan_out may be waiting for "done" flag, or hung waiting
3008 for i/o completion to child...cancel the i/o. This will
3009 put it into "snarf mode" (done but no EOF yet) that discards
3010 input.
3011
3012 Output from subprocess (stdout, stderr) needs to be flushed and
3013 shut down. We try sending an EOF, but if the mbx is full the pipe
3014 routine should still catch the "shut_on_empty" flag, telling it to
3015 use immediate-style reads so that "mbx empty" -> EOF.
3016
3017
3018*/
3019 if (info->in && !info->in_done) { /* only for mode=w */
3020 if (info->in->shut_on_empty && info->in->need_wake) {
3021 info->in->need_wake = FALSE;
fd8cd3a3 3022 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 3023 } else {
fd8cd3a3 3024 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 3025 }
3026 }
3027
3028 if (info->out && !info->out_done) { /* were we also piping output? */
3029 info->out->shut_on_empty = TRUE;
3030 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3031 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3032 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3033 }
3034
3035 if (info->err && !info->err_done) { /* we were piping stderr */
3036 info->err->shut_on_empty = TRUE;
3037 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3038 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3039 _ckvmssts_noperl(iss);
a0d0e21e 3040 }
fd8cd3a3 3041 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3042
a0d0e21e
LW		 3043}
3044
2fbb330f 3045static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
218fdd94 3046static void vms_execfree(struct dsc$descriptor_s *vmscmd);
aa779de1 3047
22d4bb9c
CB		 3048/*
3049 we actually differ from vmstrnenv since we use this to
3050 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3051 are pointing to the same thing
3052*/
3053
3054static unsigned short
fd8cd3a3 3055popen_translate(pTHX_ char *logical, char *result)
22d4bb9c
CB		 3056{
3057 int iss;
3058 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3059 $DESCRIPTOR(d_log,"");
3060 struct _il3 {
3061 unsigned short length;
3062 unsigned short code;
3063 char * buffer_addr;
3064 unsigned short *retlenaddr;
3065 } itmlst[2];
3066 unsigned short l, ifi;
3067
3068 d_log.dsc$a_pointer = logical;
3069 d_log.dsc$w_length = strlen(logical);
3070
3071 itmlst[0].code = LNM$_STRING;
3072 itmlst[0].length = 255;
3073 itmlst[0].buffer_addr = result;
3074 itmlst[0].retlenaddr = &l;
3075
3076 itmlst[1].code = 0;
3077 itmlst[1].length = 0;
3078 itmlst[1].buffer_addr = 0;
3079 itmlst[1].retlenaddr = 0;
3080
3081 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3082 if (iss == SS$_NOLOGNAM) {
3083 iss = SS$_NORMAL;
3084 l = 0;
3085 }
3086 if (!(iss&1)) lib$signal(iss);
3087 result[l] = '\0';
3088/*
3089 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3090 strip it off and return the ifi, if any
3091*/
3092 ifi = 0;
3093 if (result[0] == 0x1b && result[1] == 0x00) {
18a3d61e 3094 memmove(&ifi,result+2,2);
22d4bb9c
CB		 3095 strcpy(result,result+4);
3096 }
3097 return ifi; /* this is the RMS internal file id */
3098}
3099
22d4bb9c
CB		 3100static void pipe_infromchild_ast(pPipe p);
3101
3102/*
3103 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3104 inside an AST routine without worrying about reentrancy and which Perl
3105 memory allocator is being used.
3106
3107 We read data and queue up the buffers, then spit them out one at a
3108 time to the output mailbox when the output mailbox is ready for one.
3109
3110*/
3111#define INITIAL_TOCHILDQUEUE 2
3112
3113static pPipe
fd8cd3a3 3114pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3115{
22d4bb9c
CB		 3116 pPipe p;
3117 pCBuf b;
3118 char mbx1[64], mbx2[64];
3119 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3120 DSC$K_CLASS_S, mbx1},
3121 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3122 DSC$K_CLASS_S, mbx2};
3123 unsigned int dviitm = DVI$_DEVBUFSIZ;
3124 int j, n;
3125
d4c83939
CB		 3126 n = sizeof(Pipe);
3127 _ckvmssts(lib$get_vm(&n, &p));
22d4bb9c 3128
fd8cd3a3
DS		 3129 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3130 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 3131 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3132
3133 p->buf = 0;
3134 p->shut_on_empty = FALSE;
3135 p->need_wake = FALSE;
3136 p->type = 0;
3137 p->retry = 0;
3138 p->iosb.status = SS$_NORMAL;
3139 p->iosb2.status = SS$_NORMAL;
3140 p->free = RQE_ZERO;
3141 p->wait = RQE_ZERO;
3142 p->curr = 0;
3143 p->curr2 = 0;
3144 p->info = 0;
fd8cd3a3
DS		 3145#ifdef PERL_IMPLICIT_CONTEXT
3146 p->thx = aTHX;
3147#endif
22d4bb9c
CB		 3148
3149 n = sizeof(CBuf) + p->bufsize;
3150
3151 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3152 _ckvmssts(lib$get_vm(&n, &b));
3153 b->buf = (char *) b + sizeof(CBuf);
3154 _ckvmssts(lib$insqhi(b, &p->free));
3155 }
3156
3157 pipe_tochild2_ast(p);
3158 pipe_tochild1_ast(p);
3159 strcpy(wmbx, mbx1);
3160 strcpy(rmbx, mbx2);
3161 return p;
3162}
3163
3164/* reads the MBX Perl is writing, and queues */
3165
3166static void
3167pipe_tochild1_ast(pPipe p)
3168{
22d4bb9c
CB		 3169 pCBuf b = p->curr;
3170 int iss = p->iosb.status;
3171 int eof = (iss == SS$_ENDOFFILE);
f7ddb74a 3172 int sts;
fd8cd3a3
DS		 3173#ifdef PERL_IMPLICIT_CONTEXT
3174 pTHX = p->thx;
3175#endif
22d4bb9c
CB		 3176
3177 if (p->retry) {
3178 if (eof) {
3179 p->shut_on_empty = TRUE;
3180 b->eof = TRUE;
3181 _ckvmssts(sys$dassgn(p->chan_in));
3182 } else {
3183 _ckvmssts(iss);
3184 }
3185
3186 b->eof = eof;
3187 b->size = p->iosb.count;
f7ddb74a 3188 _ckvmssts(sts = lib$insqhi(b, &p->wait));
22d4bb9c
CB		 3189 if (p->need_wake) {
3190 p->need_wake = FALSE;
3191 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3192 }
3193 } else {
3194 p->retry = 1; /* initial call */
3195 }
3196
3197 if (eof) { /* flush the free queue, return when done */
3198 int n = sizeof(CBuf) + p->bufsize;
3199 while (1) {
3200 iss = lib$remqti(&p->free, &b);
3201 if (iss == LIB$_QUEWASEMP) return;
3202 _ckvmssts(iss);
3203 _ckvmssts(lib$free_vm(&n, &b));
3204 }
3205 }
3206
3207 iss = lib$remqti(&p->free, &b);
3208 if (iss == LIB$_QUEWASEMP) {
3209 int n = sizeof(CBuf) + p->bufsize;
3210 _ckvmssts(lib$get_vm(&n, &b));
3211 b->buf = (char *) b + sizeof(CBuf);
3212 } else {
3213 _ckvmssts(iss);
3214 }
3215
3216 p->curr = b;
3217 iss = sys$qio(0,p->chan_in,
3218 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3219 &p->iosb,
3220 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3221 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3222 _ckvmssts(iss);
3223}
3224
3225
3226/* writes queued buffers to output, waits for each to complete before
3227 doing the next */
3228
3229static void
3230pipe_tochild2_ast(pPipe p)
3231{
22d4bb9c
CB		 3232 pCBuf b = p->curr2;
3233 int iss = p->iosb2.status;
3234 int n = sizeof(CBuf) + p->bufsize;
3235 int done = (p->info && p->info->done) ||
3236 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 3237#if defined(PERL_IMPLICIT_CONTEXT)
3238 pTHX = p->thx;
3239#endif
22d4bb9c
CB		 3240
3241 do {
3242 if (p->type) { /* type=1 has old buffer, dispose */
3243 if (p->shut_on_empty) {
3244 _ckvmssts(lib$free_vm(&n, &b));
3245 } else {
3246 _ckvmssts(lib$insqhi(b, &p->free));
3247 }
3248 p->type = 0;
3249 }
3250
3251 iss = lib$remqti(&p->wait, &b);
3252 if (iss == LIB$_QUEWASEMP) {
3253 if (p->shut_on_empty) {
3254 if (done) {
3255 _ckvmssts(sys$dassgn(p->chan_out));
3256 *p->pipe_done = TRUE;
3257 _ckvmssts(sys$setef(pipe_ef));
3258 } else {
3259 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3260 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3261 }
3262 return;
3263 }
3264 p->need_wake = TRUE;
3265 return;
3266 }
3267 _ckvmssts(iss);
3268 p->type = 1;
3269 } while (done);
3270
3271
3272 p->curr2 = b;
3273 if (b->eof) {
3274 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3275 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3276 } else {
3277 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3278 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3279 }
3280
3281 return;
3282
3283}
3284
3285
3286static pPipe
fd8cd3a3 3287pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3288{
22d4bb9c
CB		 3289 pPipe p;
3290 char mbx1[64], mbx2[64];
3291 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3292 DSC$K_CLASS_S, mbx1},
3293 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3294 DSC$K_CLASS_S, mbx2};
3295 unsigned int dviitm = DVI$_DEVBUFSIZ;
3296
d4c83939
CB		 3297 int n = sizeof(Pipe);
3298 _ckvmssts(lib$get_vm(&n, &p));
fd8cd3a3
DS		 3299 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3300 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 3301
3302 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939
CB		 3303 n = p->bufsize * sizeof(char);
3304 _ckvmssts(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3305 p->shut_on_empty = FALSE;
3306 p->info = 0;
3307 p->type = 0;
3308 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 3309#if defined(PERL_IMPLICIT_CONTEXT)
3310 p->thx = aTHX;
3311#endif
22d4bb9c
CB		 3312 pipe_infromchild_ast(p);
3313
3314 strcpy(wmbx, mbx1);
3315 strcpy(rmbx, mbx2);
3316 return p;
3317}
3318
3319static void
3320pipe_infromchild_ast(pPipe p)
3321{
22d4bb9c
CB		 3322 int iss = p->iosb.status;
3323 int eof = (iss == SS$_ENDOFFILE);
3324 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3325 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 3326#if defined(PERL_IMPLICIT_CONTEXT)
3327 pTHX = p->thx;
3328#endif
22d4bb9c
CB		 3329
3330 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3331 _ckvmssts(sys$dassgn(p->chan_out));
3332 p->chan_out = 0;
3333 }
3334
3335 /* read completed:
3336 input shutdown if EOF from self (done or shut_on_empty)
3337 output shutdown if closing flag set (my_pclose)
3338 send data/eof from child or eof from self
3339 otherwise, re-read (snarf of data from child)
3340 */
3341
3342 if (p->type == 1) {
3343 p->type = 0;
3344 if (myeof && p->chan_in) { /* input shutdown */
3345 _ckvmssts(sys$dassgn(p->chan_in));
3346 p->chan_in = 0;
3347 }
3348
3349 if (p->chan_out) {
3350 if (myeof || kideof) { /* pass EOF to parent */
3351 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3352 pipe_infromchild_ast, p,
3353 0, 0, 0, 0, 0, 0));
3354 return;
3355 } else if (eof) { /* eat EOF --- fall through to read*/
3356
3357 } else { /* transmit data */
3358 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3359 pipe_infromchild_ast,p,
3360 p->buf, p->iosb.count, 0, 0, 0, 0));
3361 return;
3362 }
3363 }
3364 }
3365
3366 /* everything shut? flag as done */
3367
3368 if (!p->chan_in && !p->chan_out) {
3369 *p->pipe_done = TRUE;
3370 _ckvmssts(sys$setef(pipe_ef));
3371 return;
3372 }
3373
3374 /* write completed (or read, if snarfing from child)
3375 if still have input active,
3376 queue read...immediate mode if shut_on_empty so we get EOF if empty
3377 otherwise,
3378 check if Perl reading, generate EOFs as needed
3379 */
3380
3381 if (p->type == 0) {
3382 p->type = 1;
3383 if (p->chan_in) {
3384 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3385 pipe_infromchild_ast,p,
3386 p->buf, p->bufsize, 0, 0, 0, 0);
3387 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3388 _ckvmssts(iss);
3389 } else { /* send EOFs for extra reads */
3390 p->iosb.status = SS$_ENDOFFILE;
3391 p->iosb.dvispec = 0;
3392 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3393 0, 0, 0,
3394 pipe_infromchild_ast, p, 0, 0, 0, 0));
3395 }
3396 }
3397}
3398
3399static pPipe
fd8cd3a3 3400pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 3401{
22d4bb9c
CB		 3402 pPipe p;
3403 char mbx[64];
3404 unsigned long dviitm = DVI$_DEVBUFSIZ;
3405 struct stat s;
3406 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3407 DSC$K_CLASS_S, mbx};
a480973c 3408 int n = sizeof(Pipe);
22d4bb9c
CB		 3409
3410 /* things like terminals and mbx's don't need this filter */
3411 if (fd && fstat(fd,&s) == 0) {
3412 unsigned long dviitm = DVI$_DEVCHAR, devchar;
cfcfe586
JM		 3413 char device[65];
3414 unsigned short dev_len;
3415 struct dsc$descriptor_s d_dev;
3416 char * cptr;
3417 struct item_list_3 items[3];
3418 int status;
3419 unsigned short dvi_iosb[4];
3420
3421 cptr = getname(fd, out, 1);
3422 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3423 d_dev.dsc$a_pointer = out;
3424 d_dev.dsc$w_length = strlen(out);
3425 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3426 d_dev.dsc$b_class = DSC$K_CLASS_S;
3427
3428 items[0].len = 4;
3429 items[0].code = DVI$_DEVCHAR;
3430 items[0].bufadr = &devchar;
3431 items[0].retadr = NULL;
3432 items[1].len = 64;
3433 items[1].code = DVI$_FULLDEVNAM;
3434 items[1].bufadr = device;
3435 items[1].retadr = &dev_len;
3436 items[2].len = 0;
3437 items[2].code = 0;
3438
3439 status = sys$getdviw
3440 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3441 _ckvmssts(status);
3442 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3443 device[dev_len] = 0;
3444
3445 if (!(devchar & DEV$M_DIR)) {
3446 strcpy(out, device);
3447 return 0;
3448 }
3449 }
22d4bb9c
CB		 3450 }
3451
d4c83939 3452 _ckvmssts(lib$get_vm(&n, &p));
22d4bb9c 3453 p->fd_out = dup(fd);
fd8cd3a3 3454 create_mbx(aTHX_ &p->chan_in, &d_mbx);
22d4bb9c 3455 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939
CB		 3456 n = (p->bufsize+1) * sizeof(char);
3457 _ckvmssts(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3458 p->shut_on_empty = FALSE;
3459 p->retry = 0;
3460 p->info = 0;
3461 strcpy(out, mbx);
3462
3463 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3464 pipe_mbxtofd_ast, p,
3465 p->buf, p->bufsize, 0, 0, 0, 0));
3466
3467 return p;
3468}
3469
3470static void
3471pipe_mbxtofd_ast(pPipe p)
3472{
22d4bb9c
CB		 3473 int iss = p->iosb.status;
3474 int done = p->info->done;
3475 int iss2;
3476 int eof = (iss == SS$_ENDOFFILE);
3477 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3478 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 3479#if defined(PERL_IMPLICIT_CONTEXT)
3480 pTHX = p->thx;
3481#endif
22d4bb9c
CB		 3482
3483 if (done && myeof) { /* end piping */
3484 close(p->fd_out);
3485 sys$dassgn(p->chan_in);
3486 *p->pipe_done = TRUE;
3487 _ckvmssts(sys$setef(pipe_ef));
3488 return;
3489 }
3490
3491 if (!err && !eof) { /* good data to send to file */
3492 p->buf[p->iosb.count] = '\n';
3493 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3494 if (iss2 < 0) {
3495 p->retry++;
3496 if (p->retry < MAX_RETRY) {
3497 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3498 return;
3499 }
3500 }
3501 p->retry = 0;
3502 } else if (err) {
3503 _ckvmssts(iss);
3504 }
3505
3506
3507 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3508 pipe_mbxtofd_ast, p,
3509 p->buf, p->bufsize, 0, 0, 0, 0);
3510 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3511 _ckvmssts(iss);
3512}
3513
3514
3515typedef struct _pipeloc PLOC;
3516typedef struct _pipeloc* pPLOC;
3517
3518struct _pipeloc {
3519 pPLOC next;
3520 char dir[NAM$C_MAXRSS+1];
3521};
3522static pPLOC head_PLOC = 0;
3523
5c0ae288 3524void
fd8cd3a3 3525free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 3526{
3527 pPLOC p, pnext;
ff7adb52 3528 pPLOC *pHead = (pPLOC *)head;
5c0ae288 3529
ff7adb52 3530 p = *pHead;
5c0ae288
CL		 3531 while (p) {
3532 pnext = p->next;
e0ef6b43 3533 PerlMem_free(p);
5c0ae288
CL		 3534 p = pnext;
3535 }
ff7adb52 3536 *pHead = 0;
5c0ae288 3537}
22d4bb9c
CB		 3538
3539static void
fd8cd3a3 3540store_pipelocs(pTHX)
22d4bb9c
CB		 3541{
3542 int i;
3543 pPLOC p;
ff7adb52 3544 AV *av = 0;
22d4bb9c
CB		 3545 SV *dirsv;
3546 GV *gv;
3547 char *dir, *x;
3548 char *unixdir;
3549 char temp[NAM$C_MAXRSS+1];
3550 STRLEN n_a;
3551
ff7adb52 3552 if (head_PLOC)
218fdd94 3553 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 3554
22d4bb9c
CB		 3555/* the . directory from @INC comes last */
3556
e0ef6b43 3557 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
c5375c28 3558 if (p == NULL) _ckvmssts(SS$_INSFMEM);
22d4bb9c
CB		 3559 p->next = head_PLOC;
3560 head_PLOC = p;
3561 strcpy(p->dir,"./");
3562
3563/* get the directory from $^X */
3564
c5375c28
JM		 3565 unixdir = PerlMem_malloc(VMS_MAXRSS);
3566 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3567
218fdd94
CL		 3568#ifdef PERL_IMPLICIT_CONTEXT
3569 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3570#else
22d4bb9c 3571 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 3572#endif
22d4bb9c
CB		 3573 strcpy(temp, PL_origargv[0]);
3574 x = strrchr(temp,']');
2497a41f
JM		 3575 if (x == NULL) {
3576 x = strrchr(temp,'>');
3577 if (x == NULL) {
3578 /* It could be a UNIX path */
3579 x = strrchr(temp,'/');
3580 }
3581 }
3582 if (x)
3583 x[1] = '\0';
3584 else {
3585 /* Got a bare name, so use default directory */
3586 temp[0] = '.';
3587 temp[1] = '\0';
3588 }
22d4bb9c 3589
360732b5 3590 if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
e0ef6b43 3591 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
c5375c28 3592 if (p == NULL) _ckvmssts(SS$_INSFMEM);
22d4bb9c
CB		 3593 p->next = head_PLOC;
3594 head_PLOC = p;
3595 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3596 p->dir[NAM$C_MAXRSS] = '\0';
c5375c28 3597 }
22d4bb9c
CB		 3598 }
3599
3600/* reverse order of @INC entries, skip "." since entered above */
3601
218fdd94
CL		 3602#ifdef PERL_IMPLICIT_CONTEXT
3603 if (aTHX)
3604#endif
ff7adb52
CL		 3605 if (PL_incgv) av = GvAVn(PL_incgv);
3606
3607 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB		 3608 dirsv = *av_fetch(av,i,TRUE);
3609
3610 if (SvROK(dirsv)) continue;
3611 dir = SvPVx(dirsv,n_a);
3612 if (strcmp(dir,".") == 0) continue;
360732b5 3613 if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
22d4bb9c
CB		 3614 continue;
3615
e0ef6b43 3616 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 3617 p->next = head_PLOC;
3618 head_PLOC = p;
3619 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3620 p->dir[NAM$C_MAXRSS] = '\0';
3621 }
3622
3623/* most likely spot (ARCHLIB) put first in the list */
3624
3625#ifdef ARCHLIB_EXP
360732b5 3626 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
e0ef6b43 3627 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
c5375c28 3628 if (p == NULL) _ckvmssts(SS$_INSFMEM);
22d4bb9c
CB		 3629 p->next = head_PLOC;
3630 head_PLOC = p;
3631 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3632 p->dir[NAM$C_MAXRSS] = '\0';
3633 }
3634#endif
c5375c28 3635 PerlMem_free(unixdir);
22d4bb9c
CB		 3636}
3637
a1887106
JM		 3638static I32
3639Perl_cando_by_name_int
3640 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3641#if !defined(PERL_IMPLICIT_CONTEXT)
3642#define cando_by_name_int Perl_cando_by_name_int
3643#else
3644#define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3645#endif
22d4bb9c
CB		 3646
3647static char *
fd8cd3a3 3648find_vmspipe(pTHX)
22d4bb9c
CB		 3649{
3650 static int vmspipe_file_status = 0;
3651 static char vmspipe_file[NAM$C_MAXRSS+1];
3652
3653 /* already found? Check and use ... need read+execute permission */
3654
3655 if (vmspipe_file_status == 1) {
a1887106
JM		 3656 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3657 && cando_by_name_int
3658 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3659 return vmspipe_file;
3660 }
3661 vmspipe_file_status = 0;
3662 }
3663
3664 /* scan through stored @INC, $^X */
3665
3666 if (vmspipe_file_status == 0) {
3667 char file[NAM$C_MAXRSS+1];
3668 pPLOC p = head_PLOC;
3669
3670 while (p) {
2f4077ca 3671 char * exp_res;
4d743a9b 3672 int dirlen;
22d4bb9c 3673 strcpy(file, p->dir);
4d743a9b
JM		 3674 dirlen = strlen(file);
3675 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
22d4bb9c
CB		 3676 file[NAM$C_MAXRSS] = '\0';
3677 p = p->next;
3678
2f4077ca 3679 exp_res = do_rmsexpand
360732b5 3680 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
2f4077ca 3681 if (!exp_res) continue;
22d4bb9c 3682
a1887106
JM		 3683 if (cando_by_name_int
3684 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3685 && cando_by_name_int
3686 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3687 vmspipe_file_status = 1;
3688 return vmspipe_file;
3689 }
3690 }
3691 vmspipe_file_status = -1; /* failed, use tempfiles */
3692 }
3693
3694 return 0;
3695}
3696
3697static FILE *
fd8cd3a3 3698vmspipe_tempfile(pTHX)
22d4bb9c
CB		 3699{
3700 char file[NAM$C_MAXRSS+1];
3701 FILE *fp;
3702 static int index = 0;
2497a41f
JM		 3703 Stat_t s0, s1;
3704 int cmp_result;
22d4bb9c
CB		 3705
3706 /* create a tempfile */
3707
3708 /* we can't go from W, shr=get to R, shr=get without
3709 an intermediate vulnerable state, so don't bother trying...
3710
3711 and lib$spawn doesn't shr=put, so have to close the write
3712
3713 So... match up the creation date/time and the FID to
3714 make sure we're dealing with the same file
3715
3716 */
3717
3718 index++;
2497a41f
JM		 3719 if (!decc_filename_unix_only) {
3720 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3721 fp = fopen(file,"w");
3722 if (!fp) {
22d4bb9c
CB		 3723 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3724 fp = fopen(file,"w");
3725 if (!fp) {
3726 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3727 fp = fopen(file,"w");
2497a41f
JM		 3728 }
3729 }
3730 }
3731 else {
3732 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3733 fp = fopen(file,"w");
3734 if (!fp) {
3735 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3736 fp = fopen(file,"w");
3737 if (!fp) {
3738 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3739 fp = fopen(file,"w");
3740 }
3741 }
22d4bb9c
CB		 3742 }
3743 if (!fp) return 0; /* we're hosed */
3744
f9ecfa39 3745 fprintf(fp,"$! 'f$verify(0)'\n");
22d4bb9c
CB		 3746 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3747 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3748 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3749 fprintf(fp,"$ perl_on = \"set noon\"\n");
3750 fprintf(fp,"$ perl_exit = \"exit\"\n");
3751 fprintf(fp,"$ perl_del = \"delete\"\n");
3752 fprintf(fp,"$ pif = \"if\"\n");
3753 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 3754 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3755 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 3756 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL		 3757 fprintf(fp,"$! --- build command line to get max possible length\n");
3758 fprintf(fp,"$c=perl_popen_cmd0\n");
3759 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3760 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3761 fprintf(fp,"$x=perl_popen_cmd3\n");
3762 fprintf(fp,"$c=c+x\n");
22d4bb9c 3763 fprintf(fp,"$ perl_on\n");
f9ecfa39 3764 fprintf(fp,"$ 'c'\n");
22d4bb9c 3765 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 3766 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 3767 fprintf(fp,"$ perl_exit 'perl_status'\n");
3768 fsync(fileno(fp));
3769
3770 fgetname(fp, file, 1);
2497a41f 3771 fstat(fileno(fp), (struct stat *)&s0);
22d4bb9c
CB		 3772 fclose(fp);
3773
2497a41f 3774 if (decc_filename_unix_only)
360732b5 3775 do_tounixspec(file, file, 0, NULL);
22d4bb9c
CB		 3776 fp = fopen(file,"r","shr=get");
3777 if (!fp) return 0;
2497a41f
JM		 3778 fstat(fileno(fp), (struct stat *)&s1);
3779
682e4b71 3780 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
2497a41f 3781 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
22d4bb9c
CB		 3782 fclose(fp);
3783 return 0;
3784 }
3785
3786 return fp;
3787}
3788
3789
cd1191f1
CB		 3790static int vms_is_syscommand_xterm(void)
3791{
3792 const static struct dsc$descriptor_s syscommand_dsc =
3793 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3794
3795 const static struct dsc$descriptor_s decwdisplay_dsc =
3796 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3797
3798 struct item_list_3 items[2];
3799 unsigned short dvi_iosb[4];
3800 unsigned long devchar;
3801 unsigned long devclass;
3802 int status;
3803
3804 /* Very simple check to guess if sys$command is a decterm? */
3805 /* First see if the DECW$DISPLAY: device exists */
3806 items[0].len = 4;
3807 items[0].code = DVI$_DEVCHAR;
3808 items[0].bufadr = &devchar;
3809 items[0].retadr = NULL;
3810 items[1].len = 0;
3811 items[1].code = 0;
3812
3813 status = sys$getdviw
3814 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3815
3816 if ($VMS_STATUS_SUCCESS(status)) {
3817 status = dvi_iosb[0];
3818 }
3819
3820 if (!$VMS_STATUS_SUCCESS(status)) {
3821 SETERRNO(EVMSERR, status);
3822 return -1;
3823 }
3824
3825 /* If it does, then for now assume that we are on a workstation */
3826 /* Now verify that SYS$COMMAND is a terminal */
3827 /* for creating the debugger DECTerm */
3828
3829 items[0].len = 4;
3830 items[0].code = DVI$_DEVCLASS;
3831 items[0].bufadr = &devclass;
3832 items[0].retadr = NULL;
3833 items[1].len = 0;
3834 items[1].code = 0;
3835
3836 status = sys$getdviw
3837 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3838
3839 if ($VMS_STATUS_SUCCESS(status)) {
3840 status = dvi_iosb[0];
3841 }
3842
3843 if (!$VMS_STATUS_SUCCESS(status)) {
3844 SETERRNO(EVMSERR, status);
3845 return -1;
3846 }
3847 else {
3848 if (devclass == DC$_TERM) {
3849 return 0;
3850 }
3851 }
3852 return -1;
3853}
3854
3855/* If we are on a DECTerm, we can pretend to fork xterms when requested */
3856static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3857{
3858 int status;
3859 int ret_stat;
3860 char * ret_char;
3861 char device_name[65];
3862 unsigned short device_name_len;
3863 struct dsc$descriptor_s customization_dsc;
3864 struct dsc$descriptor_s device_name_dsc;
3865 const char * cptr;
3866 char * tptr;
3867 char customization[200];
3868 char title[40];
3869 pInfo info = NULL;
3870 char mbx1[64];
3871 unsigned short p_chan;
3872 int n;
3873 unsigned short iosb[4];
3874 struct item_list_3 items[2];
3875 const char * cust_str =
3876 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3877 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3878 DSC$K_CLASS_S, mbx1};
3879
8cb5d3d5
JM		 3880 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3881 /*---------------------------------------*/
d30c1055 3882 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
8cb5d3d5
JM		 3883
3884
3885 /* Make sure that this is from the Perl debugger */
cd1191f1
CB		 3886 ret_char = strstr(cmd," xterm ");
3887 if (ret_char == NULL)
3888 return NULL;
3889 cptr = ret_char + 7;
3890 ret_char = strstr(cmd,"tty");
3891 if (ret_char == NULL)
3892 return NULL;
3893 ret_char = strstr(cmd,"sleep");
3894 if (ret_char == NULL)
3895 return NULL;
3896
8cb5d3d5
JM		 3897 if (decw_term_port == 0) {
3898 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3899 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3900 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3901
d30c1055 3902 status = lib$find_image_symbol
8cb5d3d5
JM		 3903 (&filename1_dsc,
3904 &decw_term_port_dsc,
3905 (void *)&decw_term_port,
3906 NULL,
3907 0);
3908
3909 /* Try again with the other image name */
3910 if (!$VMS_STATUS_SUCCESS(status)) {
3911
d30c1055 3912 status = lib$find_image_symbol
8cb5d3d5
JM		 3913 (&filename2_dsc,
3914 &decw_term_port_dsc,
3915 (void *)&decw_term_port,
3916 NULL,
3917 0);
3918
3919 }
3920
3921 }
3922
3923
3924 /* No decw$term_port, give it up */
3925 if (!$VMS_STATUS_SUCCESS(status))
3926 return NULL;
3927
cd1191f1
CB		 3928 /* Are we on a workstation? */
3929 /* to do: capture the rows / columns and pass their properties */
3930 ret_stat = vms_is_syscommand_xterm();
3931 if (ret_stat < 0)
3932 return NULL;
3933
3934 /* Make the title: */
3935 ret_char = strstr(cptr,"-title");
3936 if (ret_char != NULL) {
3937 while ((*cptr != 0) && (*cptr != '\"')) {
3938 cptr++;
3939 }
3940 if (*cptr == '\"')
3941 cptr++;
3942 n = 0;
3943 while ((*cptr != 0) && (*cptr != '\"')) {
3944 title[n] = *cptr;
3945 n++;
3946 if (n == 39) {
3947 title[39] == 0;
3948 break;
3949 }
3950 cptr++;
3951 }
3952 title[n] = 0;
3953 }
3954 else {
3955 /* Default title */
3956 strcpy(title,"Perl Debug DECTerm");
3957 }
3958 sprintf(customization, cust_str, title);
3959
3960 customization_dsc.dsc$a_pointer = customization;
3961 customization_dsc.dsc$w_length = strlen(customization);
3962 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3963 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3964
3965 device_name_dsc.dsc$a_pointer = device_name;
3966 device_name_dsc.dsc$w_length = sizeof device_name -1;
3967 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3968 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3969
3970 device_name_len = 0;
3971
3972 /* Try to create the window */
8cb5d3d5 3973 status = (*decw_term_port)
cd1191f1
CB		 3974 (NULL,
3975 NULL,
3976 &customization_dsc,
3977 &device_name_dsc,
3978 &device_name_len,
3979 NULL,
3980 NULL,
3981 NULL);
3982 if (!$VMS_STATUS_SUCCESS(status)) {
3983 SETERRNO(EVMSERR, status);
3984 return NULL;
3985 }
3986
3987 device_name[device_name_len] = '\0';
3988
3989 /* Need to set this up to look like a pipe for cleanup */
3990 n = sizeof(Info);
3991 status = lib$get_vm(&n, &info);
3992 if (!$VMS_STATUS_SUCCESS(status)) {
3993 SETERRNO(ENOMEM, status);
3994 return NULL;
3995 }
3996
3997 info->mode = *mode;
3998 info->done = FALSE;
3999 info->completion = 0;
4000 info->closing = FALSE;
4001 info->in = 0;
4002 info->out = 0;
4003 info->err = 0;
4004 info->fp = Nullfp;
4005 info->useFILE = 0;
4006 info->waiting = 0;
4007 info->in_done = TRUE;
4008 info->out_done = TRUE;
4009 info->err_done = TRUE;
4010
4011 /* Assign a channel on this so that it will persist, and not login */
4012 /* We stash this channel in the info structure for reference. */
4013 /* The created xterm self destructs when the last channel is removed */
4014 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4015 /* So leave this assigned. */
4016 device_name_dsc.dsc$w_length = device_name_len;
4017 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4018 if (!$VMS_STATUS_SUCCESS(status)) {
4019 SETERRNO(EVMSERR, status);
4020 return NULL;
4021 }
4022 info->xchan_valid = 1;
4023
4024 /* Now create a mailbox to be read by the application */
4025
4026 create_mbx(aTHX_ &p_chan, &d_mbx1);
4027
4028 /* write the name of the created terminal to the mailbox */
4029 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4030 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4031
4032 if (!$VMS_STATUS_SUCCESS(status)) {
4033 SETERRNO(EVMSERR, status);
4034 return NULL;
4035 }
4036
4037 info->fp = PerlIO_open(mbx1, mode);
4038
4039 /* Done with this channel */
4040 sys$dassgn(p_chan);
4041
4042 /* If any errors, then clean up */
4043 if (!info->fp) {
4044 n = sizeof(Info);
4045 _ckvmssts(lib$free_vm(&n, &info));
4046 return NULL;
4047 }
4048
4049 /* All done */
4050 return info->fp;
4051}
22d4bb9c 4052
8fde5078 4053static PerlIO *
2fbb330f 4054safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
a0d0e21e 4055{
748a9306 4056 static int handler_set_up = FALSE;
55f2b99c 4057 unsigned long int sts, flags = CLI$M_NOWAIT;
f9ecfa39
PP		 4058 /* The use of a GLOBAL table (as was done previously) rendered
4059 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4060 * environment. Hence we've switched to LOCAL symbol table.
4061 */
4062 unsigned int table = LIB$K_CLI_LOCAL_SYM;
d4c83939 4063 int j, wait = 0, n;
ff7adb52 4064 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
cfcfe586 4065 char *in, *out, *err, mbx[512];
22d4bb9c
CB		 4066 FILE *tpipe = 0;
4067 char tfilebuf[NAM$C_MAXRSS+1];
d4c83939 4068 pInfo info = NULL;
48b5a746 4069 char cmd_sym_name[20];
22d4bb9c
CB		 4070 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4071 DSC$K_CLASS_S, symbol};
22d4bb9c 4072 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
a0d0e21e 4073 DSC$K_CLASS_S, 0};
48b5a746
CL		 4074 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4075 DSC$K_CLASS_S, cmd_sym_name};
218fdd94 4076 struct dsc$descriptor_s *vmscmd;
22d4bb9c 4077 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
0e06870b 4078 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
22d4bb9c 4079 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
cd1191f1 4080
cd1191f1
CB		 4081 /* Check here for Xterm create request. This means looking for
4082 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4083 * is possible to create an xterm.
4084 */
4085 if (*in_mode == 'r') {
4086 PerlIO * xterm_fd;
4087
4088 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4089 if (xterm_fd != Nullfp)
4090 return xterm_fd;
4091 }
cd1191f1 4092
afd8f436
JH		 4093 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4094
22d4bb9c
CB		 4095 /* once-per-program initialization...
4096 note that the SETAST calls and the dual test of pipe_ef
4097 makes sure that only the FIRST thread through here does
4098 the initialization...all other threads wait until it's
4099 done.
4100
4101 Yeah, uglier than a pthread call, it's got all the stuff inline
4102 rather than in a separate routine.
4103 */
4104
4105 if (!pipe_ef) {
4106 _ckvmssts(sys$setast(0));
4107 if (!pipe_ef) {
4108 unsigned long int pidcode = JPI$_PID;
4109 $DESCRIPTOR(d_delay, RETRY_DELAY);
4110 _ckvmssts(lib$get_ef(&pipe_ef));
4111 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4112 _ckvmssts(sys$bintim(&d_delay, delaytime));
4113 }
4114 if (!handler_set_up) {
4115 _ckvmssts(sys$dclexh(&pipe_exitblock));
4116 handler_set_up = TRUE;
4117 }
4118 _ckvmssts(sys$setast(1));
4119 }
4120
4121 /* see if we can find a VMSPIPE.COM */
4122
4123 tfilebuf[0] = '@';
fd8cd3a3 4124 vmspipe = find_vmspipe(aTHX);
22d4bb9c
CB		 4125 if (vmspipe) {
4126 strcpy(tfilebuf+1,vmspipe);
4127 } else { /* uh, oh...we're in tempfile hell */
fd8cd3a3 4128 tpipe = vmspipe_tempfile(aTHX);
22d4bb9c
CB		 4129 if (!tpipe) { /* a fish popular in Boston */
4130 if (ckWARN(WARN_PIPE)) {
f98bc0c6 4131 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
22d4bb9c
CB		 4132 }
4133 return Nullfp;
4134 }
4135 fgetname(tpipe,tfilebuf+1,1);
4136 }
4137 vmspipedsc.dsc$a_pointer = tfilebuf;
4138 vmspipedsc.dsc$w_length = strlen(tfilebuf);
a0d0e21e 4139
218fdd94 4140 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
a2669cfc
JH		 4141 if (!(sts & 1)) {
4142 switch (sts) {
4143 case RMS$_FNF: case RMS$_DNF:
4144 set_errno(ENOENT); break;
4145 case RMS$_DIR:
4146 set_errno(ENOTDIR); break;
4147 case RMS$_DEV:
4148 set_errno(ENODEV); break;
4149 case RMS$_PRV:
4150 set_errno(EACCES); break;
4151 case RMS$_SYN:
4152 set_errno(EINVAL); break;
4153 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4154 set_errno(E2BIG); break;
4155 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4156 _ckvmssts(sts); /* fall through */
4157 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4158 set_errno(EVMSERR);
4159 }
4160 set_vaxc_errno(sts);
cd1191f1 4161 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
f98bc0c6 4162 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
a2669cfc 4163 }
ff7adb52 4164 *psts = sts;
a2669cfc
JH		 4165 return Nullfp;
4166 }
d4c83939
CB		 4167 n = sizeof(Info);
4168 _ckvmssts(lib$get_vm(&n, &info));
22d4bb9c 4169
ff7adb52 4170 strcpy(mode,in_mode);
22d4bb9c
CB		 4171 info->mode = *mode;
4172 info->done = FALSE;
4173 info->completion = 0;
4174 info->closing = FALSE;
4175 info->in = 0;
4176 info->out = 0;
4177 info->err = 0;
ff7adb52
CL		 4178 info->fp = Nullfp;
4179 info->useFILE = 0;
4180 info->waiting = 0;
22d4bb9c
CB		 4181 info->in_done = TRUE;
4182 info->out_done = TRUE;
4183 info->err_done = TRUE;
cd1191f1
CB		 4184 info->xchan = 0;
4185 info->xchan_valid = 0;
cfcfe586
JM		 4186
4187 in = PerlMem_malloc(VMS_MAXRSS);
4188 if (in == NULL) _ckvmssts(SS$_INSFMEM);
4189 out = PerlMem_malloc(VMS_MAXRSS);
4190 if (out == NULL) _ckvmssts(SS$_INSFMEM);
4191 err = PerlMem_malloc(VMS_MAXRSS);
4192 if (err == NULL) _ckvmssts(SS$_INSFMEM);
4193
0e06870b 4194 in[0] = out[0] = err[0] = '\0';
22d4bb9c 4195
ff7adb52
CL		 4196 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4197 info->useFILE = 1;
4198 strcpy(p,p+1);
4199 }
4200 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4201 wait = 1;
4202 strcpy(p,p+1);
4203 }
4204
22d4bb9c 4205 if (*mode == 'r') { /* piping from subroutine */
22d4bb9c 4206
fd8cd3a3 4207 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
22d4bb9c
CB		 4208 if (info->out) {
4209 info->out->pipe_done = &info->out_done;
4210 info->out_done = FALSE;
4211 info->out->info = info;
4212 }
ff7adb52 4213 if (!info->useFILE) {
cd1191f1 4214 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 4215 } else {
4216 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4217 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4218 }
4219
22d4bb9c
CB		 4220 if (!info->fp && info->out) {
4221 sys$cancel(info->out->chan_out);
4222
4223 while (!info->out_done) {
4224 int done;
4225 _ckvmssts(sys$setast(0));
4226 done = info->out_done;
4227 if (!done) _ckvmssts(sys$clref(pipe_ef));
4228 _ckvmssts(sys$setast(1));
4229 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
0e06870b 4230 }
22d4bb9c 4231
d4c83939
CB		 4232 if (info->out->buf) {
4233 n = info->out->bufsize * sizeof(char);
4234 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4235 }
4236 n = sizeof(Pipe);
4237 _ckvmssts(lib$free_vm(&n, &info->out));
4238 n = sizeof(Info);
4239 _ckvmssts(lib$free_vm(&n, &info));
ff7adb52 4240 *psts = RMS$_FNF;
22d4bb9c 4241 return Nullfp;
0e06870b 4242 }
22d4bb9c 4243
fd8cd3a3 4244 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
22d4bb9c
CB		 4245 if (info->err) {
4246 info->err->pipe_done = &info->err_done;
4247 info->err_done = FALSE;
4248 info->err->info = info;
4249 }
a0d0e21e 4250
ff7adb52
CL		 4251 } else if (*mode == 'w') { /* piping to subroutine */
4252
4253 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4254 if (info->out) {
4255 info->out->pipe_done = &info->out_done;
4256 info->out_done = FALSE;
4257 info->out->info = info;
4258 }
4259
4260 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4261 if (info->err) {
4262 info->err->pipe_done = &info->err_done;
4263 info->err_done = FALSE;
4264 info->err->info = info;
4265 }
a0d0e21e 4266
fd8cd3a3 4267 info->in = pipe_tochild_setup(aTHX_ in,mbx);
ff7adb52 4268 if (!info->useFILE) {
a480973c 4269 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 4270 } else {
4271 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4272 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4273 }
4274
22d4bb9c
CB		 4275 if (info->in) {
4276 info->in->pipe_done = &info->in_done;
4277 info->in_done = FALSE;
4278 info->in->info = info;
4279 }
a0d0e21e 4280
22d4bb9c
CB		 4281 /* error cleanup */
4282 if (!info->fp && info->in) {
4283 info->done = TRUE;
4284 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4285 0, 0, 0, 0, 0, 0, 0, 0));
4286
4287 while (!info->in_done) {
4288 int done;
4289 _ckvmssts(sys$setast(0));
4290 done = info->in_done;
4291 if (!done) _ckvmssts(sys$clref(pipe_ef));
4292 _ckvmssts(sys$setast(1));
4293 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4294 }
a0d0e21e 4295
d4c83939
CB		 4296 if (info->in->buf) {
4297 n = info->in->bufsize * sizeof(char);
4298 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4299 }
4300 n = sizeof(Pipe);
4301 _ckvmssts(lib$free_vm(&n, &info->in));
4302 n = sizeof(Info);
4303 _ckvmssts(lib$free_vm(&n, &info));
ff7adb52 4304 *psts = RMS$_FNF;
0e06870b 4305 return Nullfp;
22d4bb9c 4306 }
a0d0e21e 4307
22d4bb9c 4308
ff7adb52 4309 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
fd8cd3a3 4310 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
22d4bb9c
CB		 4311 if (info->out) {
4312 info->out->pipe_done = &info->out_done;
4313 info->out_done = FALSE;
4314 info->out->info = info;
4315 }
0e06870b 4316
fd8cd3a3 4317 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
0e06870b
CB		 4318 if (info->err) {
4319 info->err->pipe_done = &info->err_done;
4320 info->err_done = FALSE;
4321 info->err->info = info;
4322 }
748a9306 4323 }
22d4bb9c
CB		 4324
4325 symbol[MAX_DCL_SYMBOL] = '\0';
4326
4327 strncpy(symbol, in, MAX_DCL_SYMBOL);
4328 d_symbol.dsc$w_length = strlen(symbol);
4329 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4330
4331 strncpy(symbol, err, MAX_DCL_SYMBOL);
4332 d_symbol.dsc$w_length = strlen(symbol);
4333 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4334
0e06870b
CB		 4335 strncpy(symbol, out, MAX_DCL_SYMBOL);
4336 d_symbol.dsc$w_length = strlen(symbol);
4337 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
22d4bb9c 4338
cfcfe586
JM		 4339 /* Done with the names for the pipes */
4340 PerlMem_free(err);
4341 PerlMem_free(out);
4342 PerlMem_free(in);
4343
218fdd94 4344 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB		 4345 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4346 if (*p == '$') p++; /* remove leading $ */
4347 while (*p == ' ' || *p == '\t') p++;
48b5a746
CL		 4348
4349 for (j = 0; j < 4; j++) {
4350 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4351 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4352
22d4bb9c
CB		 4353 strncpy(symbol, p, MAX_DCL_SYMBOL);
4354 d_symbol.dsc$w_length = strlen(symbol);
4355 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4356
48b5a746
CL		 4357 if (strlen(p) > MAX_DCL_SYMBOL) {
4358 p += MAX_DCL_SYMBOL;
4359 } else {
4360 p += strlen(p);
4361 }
4362 }
22d4bb9c 4363 _ckvmssts(sys$setast(0));
a0d0e21e
LW		 4364 info->next=open_pipes; /* prepend to list */
4365 open_pipes=info;
22d4bb9c 4366 _ckvmssts(sys$setast(1));
55f2b99c
CB		 4367 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4368 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4369 * have SYS$COMMAND if we need it.
4370 */
4371 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
22d4bb9c
CB		 4372 0, &info->pid, &info->completion,
4373 0, popen_completion_ast,info,0,0,0));
4374
4375 /* if we were using a tempfile, close it now */
4376
4377 if (tpipe) fclose(tpipe);
4378
ff7adb52 4379 /* once the subprocess is spawned, it has copied the symbols and
22d4bb9c
CB		 4380 we can get rid of ours */
4381
48b5a746
CL		 4382 for (j = 0; j < 4; j++) {
4383 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4384 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
22d4bb9c 4385 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
48b5a746 4386 }
22d4bb9c
CB		 4387 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4388 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
0e06870b 4389 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
218fdd94 4390 vms_execfree(vmscmd);
a0d0e21e 4391
218fdd94
CL		 4392#ifdef PERL_IMPLICIT_CONTEXT
4393 if (aTHX)
4394#endif
6b88bc9c 4395 PL_forkprocess = info->pid;
218fdd94 4396
ff7adb52
CL		 4397 if (wait) {
4398 int done = 0;
4399 while (!done) {
4400 _ckvmssts(sys$setast(0));
4401 done = info->done;
4402 if (!done) _ckvmssts(sys$clref(pipe_ef));
4403 _ckvmssts(sys$setast(1));
4404 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4405 }
4406 *psts = info->completion;
2fbb330f
JM		 4407/* Caller thinks it is open and tries to close it. */
4408/* This causes some problems, as it changes the error status */
4409/* my_pclose(info->fp); */
ff7adb52 4410 } else {
eed5d6a1 4411 *psts = info->pid;
ff7adb52 4412 }
a0d0e21e 4413 return info->fp;
1e422769 4414} /* end of safe_popen */
4415
4416
a15cef0c
CB		 4417/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4418PerlIO *
2fbb330f 4419Perl_my_popen(pTHX_ const char *cmd, const char *mode)
1e422769 4420{
ff7adb52 4421 int sts;
1e422769 4422 TAINT_ENV();
4423 TAINT_PROPER("popen");
45bc9206 4424 PERL_FLUSHALL_FOR_CHILD;
ff7adb52 4425 return safe_popen(aTHX_ cmd,mode,&sts);
a0d0e21e 4426}
1e422769 4427
a0d0e21e
LW		 4428/*}}}*/
4429
a15cef0c
CB		 4430/*{{{ I32 my_pclose(PerlIO *fp)*/
4431I32 Perl_my_pclose(pTHX_ PerlIO *fp)
a0d0e21e 4432{
22d4bb9c 4433 pInfo info, last = NULL;
748a9306 4434 unsigned long int retsts;
d4c83939 4435 int done, iss, n;
cd1191f1 4436 int status;
a0d0e21e
LW		 4437
4438 for (info = open_pipes; info != NULL; last = info, info = info->next)
4439 if (info->fp == fp) break;
4440
1e422769 4441 if (info == NULL) { /* no such pipe open */
4442 set_errno(ECHILD); /* quoth POSIX */
4443 set_vaxc_errno(SS$_NONEXPR);
4444 return -1;
4445 }
748a9306 4446
bbce6d69 4447 /* If we were writing to a subprocess, insure that someone reading from
4448 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
22d4bb9c
CB		 4449 * produce an EOF record in the mailbox.
4450 *
4451 * well, at least sometimes it *does*, so we have to watch out for
4452 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4453 */
ff7adb52 4454 if (info->fp) {
5ce486e0
CB		 4455 if (!info->useFILE
4456#if defined(USE_ITHREADS)
4457 && my_perl
4458#endif
4459 && PL_perlio_fd_refcnt)
4460 PerlIO_flush(info->fp);
ff7adb52
CL		 4461 else
4462 fflush((FILE *)info->fp);
4463 }
22d4bb9c 4464
b08af3f0 4465 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 4466 info->closing = TRUE;
4467 done = info->done && info->in_done && info->out_done && info->err_done;
4468 /* hanging on write to Perl's input? cancel it */
4469 if (info->mode == 'r' && info->out && !info->out_done) {
4470 if (info->out->chan_out) {
4471 _ckvmssts(sys$cancel(info->out->chan_out));
4472 if (!info->out->chan_in) { /* EOF generation, need AST */
4473 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4474 }
4475 }
4476 }
4477 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4478 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4479 0, 0, 0, 0, 0, 0));
b08af3f0 4480 _ckvmssts(sys$setast(1));
ff7adb52 4481 if (info->fp) {
5ce486e0
CB		 4482 if (!info->useFILE
4483#if defined(USE_ITHREADS)
4484 && my_perl
4485#endif
4486 && PL_perlio_fd_refcnt)
d4c83939 4487 PerlIO_close(info->fp);
ff7adb52
CL		 4488 else
4489 fclose((FILE *)info->fp);
4490 }
22d4bb9c
CB		 4491 /*
4492 we have to wait until subprocess completes, but ALSO wait until all
4493 the i/o completes...otherwise we'll be freeing the "info" structure
4494 that the i/o ASTs could still be using...
4495 */
4496
4497 while (!done) {
4498 _ckvmssts(sys$setast(0));
4499 done = info->done && info->in_done && info->out_done && info->err_done;
4500 if (!done) _ckvmssts(sys$clref(pipe_ef));
4501 _ckvmssts(sys$setast(1));
4502 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4503 }
4504 retsts = info->completion;
a0d0e21e 4505
a0d0e21e 4506 /* remove from list of open pipes */
b08af3f0 4507 _ckvmssts(sys$setast(0));
a0d0e21e
LW		 4508 if (last) last->next = info->next;
4509 else open_pipes = info->next;
b08af3f0 4510 _ckvmssts(sys$setast(1));
22d4bb9c
CB		 4511
4512 /* free buffers and structures */
4513
4514 if (info->in) {
d4c83939
CB		 4515 if (info->in->buf) {
4516 n = info->in->bufsize * sizeof(char);
4517 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4518 }
4519 n = sizeof(Pipe);
4520 _ckvmssts(lib$free_vm(&n, &info->in));
22d4bb9c
CB		 4521 }
4522 if (info->out) {
d4c83939
CB		 4523 if (info->out->buf) {
4524 n = info->out->bufsize * sizeof(char);
4525 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4526 }
4527 n = sizeof(Pipe);
4528 _ckvmssts(lib$free_vm(&n, &info->out));
22d4bb9c
CB		 4529 }
4530 if (info->err) {
d4c83939
CB		 4531 if (info->err->buf) {
4532 n = info->err->bufsize * sizeof(char);
4533 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4534 }
4535 n = sizeof(Pipe);
4536 _ckvmssts(lib$free_vm(&n, &info->err));
22d4bb9c 4537 }
d4c83939
CB		 4538 n = sizeof(Info);
4539 _ckvmssts(lib$free_vm(&n, &info));
a0d0e21e
LW		 4540
4541 return retsts;
748a9306 4542
a0d0e21e
LW		 4543} /* end of my_pclose() */
4544
119586db 4545#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB		 4546 /* Roll our own prototype because we want this regardless of whether
4547 * _VMS_WAIT is defined.
4548 */
4549 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4550#endif
4551/* sort-of waitpid; special handling of pipe clean-up for subprocesses
4552 created with popen(); otherwise partially emulate waitpid() unless
4553 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4554 Also check processes not considered by the CRTL waitpid().
4555 */
4fdae800 4556/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4557Pid_t
fd8cd3a3 4558Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
a0d0e21e 4559{
22d4bb9c
CB		 4560 pInfo info;
4561 int done;
aeb5cf3c 4562 int sts;
d85f548a 4563 int j;
aeb5cf3c
CB		 4564
4565 if (statusp) *statusp = 0;
a0d0e21e
LW		 4566
4567 for (info = open_pipes; info != NULL; info = info->next)
4568 if (info->pid == pid) break;
4569
4570 if (info != NULL) { /* we know about this child */
748a9306 4571 while (!info->done) {
22d4bb9c
CB		 4572 _ckvmssts(sys$setast(0));
4573 done = info->done;
4574 if (!done) _ckvmssts(sys$clref(pipe_ef));
4575 _ckvmssts(sys$setast(1));
4576 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
a0d0e21e
LW		 4577 }
4578
aeb5cf3c 4579 if (statusp) *statusp = info->completion;
a0d0e21e 4580 return pid;
d85f548a
JH		 4581 }
4582
4583 /* child that already terminated? */
aeb5cf3c 4584
d85f548a
JH		 4585 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4586 if (closed_list[j].pid == pid) {
4587 if (statusp) *statusp = closed_list[j].completion;
4588 return pid;
4589 }
a0d0e21e 4590 }
d85f548a
JH		 4591
4592 /* fall through if this child is not one of our own pipe children */
aeb5cf3c 4593
119586db 4594#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB		 4595
4596 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4597 * in 7.2 did we get a version that fills in the VMS completion
4598 * status as Perl has always tried to do.
4599 */
4600
4601 sts = __vms_waitpid( pid, statusp, flags );
4602
4603 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4604 return sts;
4605
4606 /* If the real waitpid tells us the child does not exist, we
4607 * fall through here to implement waiting for a child that
4608 * was created by some means other than exec() (say, spawned
4609 * from DCL) or to wait for a process that is not a subprocess
4610 * of the current process.
4611 */
4612
119586db 4613#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
aeb5cf3c 4614
21bc9d50 4615 {
a0d0e21e 4616 $DESCRIPTOR(intdsc,"0 00:00:01");
aeb5cf3c
CB		 4617 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4618 unsigned long int pidcode = JPI$_PID, mypid;
4619 unsigned long int interval[2];
aeb5cf3c 4620 unsigned int jpi_iosb[2];
d85f548a 4621 struct itmlst_3 jpilist[2] = {
aeb5cf3c 4622 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
aeb5cf3c
CB		 4623 { 0, 0, 0, 0}
4624 };
aeb5cf3c
CB		 4625
4626 if (pid <= 0) {
4627 /* Sorry folks, we don't presently implement rooting around for
4628 the first child we can find, and we definitely don't want to
4629 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4630 */
4631 set_errno(ENOTSUP);
4632 return -1;
4633 }
4634
d85f548a
JH		 4635 /* Get the owner of the child so I can warn if it's not mine. If the
4636 * process doesn't exist or I don't have the privs to look at it,
4637 * I can go home early.
aeb5cf3c
CB		 4638 */
4639 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4640 if (sts & 1) sts = jpi_iosb[0];
4641 if (!(sts & 1)) {
4642 switch (sts) {
4643 case SS$_NONEXPR:
4644 set_errno(ECHILD);
4645 break;
4646 case SS$_NOPRIV:
4647 set_errno(EACCES);
4648 break;
4649 default:
4650 _ckvmssts(sts);
4651 }
4652 set_vaxc_errno(sts);
4653 return -1;
4654 }
a0d0e21e 4655
3eeba6fb 4656 if (ckWARN(WARN_EXEC)) {
aeb5cf3c
CB		 4657 /* remind folks they are asking for non-standard waitpid behavior */
4658 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
748a9306 4659 if (ownerpid != mypid)
f98bc0c6 4660 Perl_warner(aTHX_ packWARN(WARN_EXEC),
aeb5cf3c
CB		 4661 "waitpid: process %x is not a child of process %x",
4662 pid,mypid);
748a9306 4663 }
a0d0e21e 4664
d85f548a
JH		 4665 /* simply check on it once a second until it's not there anymore. */
4666
4667 _ckvmssts(sys$bintim(&intdsc,interval));
4668 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
aeb5cf3c
CB		 4669 _ckvmssts(sys$schdwk(0,0,interval,0));
4670 _ckvmssts(sys$hiber());
d85f548a
JH		 4671 }
4672 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
aeb5cf3c
CB		 4673
4674 _ckvmssts(sts);
a0d0e21e 4675 return pid;
21bc9d50 4676 }
a0d0e21e 4677} /* end of waitpid() */
a0d0e21e
LW		 4678/*}}}*/
4679/*}}}*/
4680/*}}}*/
4681
4682/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4683char *
4684my_gconvert(double val, int ndig, int trail, char *buf)
4685{
4686 static char __gcvtbuf[DBL_DIG+1];
4687 char *loc;
4688
4689 loc = buf ? buf : __gcvtbuf;
71be2cbc 4690
4691#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4692 if (val < 1) {
4693 sprintf(loc,"%.*g",ndig,val);
4694 return loc;
4695 }
4696#endif
4697
a0d0e21e
LW		 4698 if (val) {
4699 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4700 return gcvt(val,ndig,loc);
4701 }
4702 else {
4703 loc[0] = '0'; loc[1] = '\0';
4704 return loc;
4705 }
4706
4707}
4708/*}}}*/
4709
988c775c 4710#if defined(__VAX) || !defined(NAML$C_MAXRSS)
a480973c
JM		 4711static int rms_free_search_context(struct FAB * fab)
4712{
4713struct NAM * nam;
4714
4715 nam = fab->fab$l_nam;
4716 nam->nam$b_nop |= NAM$M_SYNCHK;
4717 nam->nam$l_rlf = NULL;
4718 fab->fab$b_dns = 0;
4719 return sys$parse(fab, NULL, NULL);
4720}
4721
4722#define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4d743a9b 4723#define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
a480973c
JM		 4724#define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4725#define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4726#define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4727#define rms_nam_esll(nam) nam.nam$b_esl
4728#define rms_nam_esl(nam) nam.nam$b_esl
4729#define rms_nam_name(nam) nam.nam$l_name
4730#define rms_nam_namel(nam) nam.nam$l_name
4731#define rms_nam_type(nam) nam.nam$l_type
4732#define rms_nam_typel(nam) nam.nam$l_type
4733#define rms_nam_ver(nam) nam.nam$l_ver
4734#define rms_nam_verl(nam) nam.nam$l_ver
4735#define rms_nam_rsll(nam) nam.nam$b_rsl
4736#define rms_nam_rsl(nam) nam.nam$b_rsl
4737#define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4738#define rms_set_fna(fab, nam, name, size) \
a1887106 4739 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
a480973c
JM		 4740#define rms_get_fna(fab, nam) fab.fab$l_fna
4741#define rms_set_dna(fab, nam, name, size) \
a1887106
JM		 4742 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4743#define rms_nam_dns(fab, nam) fab.fab$b_dns
d584a1c6 4744#define rms_set_esa(nam, name, size) \
a1887106 4745 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
a480973c 4746#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4747 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
a480973c 4748#define rms_set_rsa(nam, name, size) \
a1887106 4749 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
a480973c 4750#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106
JM		 4751 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4752#define rms_nam_name_type_l_size(nam) \
4753 (nam.nam$b_name + nam.nam$b_type)
a480973c
JM		 4754#else
4755static int rms_free_search_context(struct FAB * fab)
4756{
4757struct NAML * nam;
4758
4759 nam = fab->fab$l_naml;
4760 nam->naml$b_nop |= NAM$M_SYNCHK;
4761 nam->naml$l_rlf = NULL;
4762 nam->naml$l_long_defname_size = 0;
988c775c 4763
a480973c
JM		 4764 fab->fab$b_dns = 0;
4765 return sys$parse(fab, NULL, NULL);
4766}
4767
4768#define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4d743a9b 4769#define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
a480973c
JM		 4770#define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4771#define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4772#define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4773#define rms_nam_esll(nam) nam.naml$l_long_expand_size
4774#define rms_nam_esl(nam) nam.naml$b_esl
4775#define rms_nam_name(nam) nam.naml$l_name
4776#define rms_nam_namel(nam) nam.naml$l_long_name
4777#define rms_nam_type(nam) nam.naml$l_type
4778#define rms_nam_typel(nam) nam.naml$l_long_type
4779#define rms_nam_ver(nam) nam.naml$l_ver
4780#define rms_nam_verl(nam) nam.naml$l_long_ver
4781#define rms_nam_rsll(nam) nam.naml$l_long_result_size
4782#define rms_nam_rsl(nam) nam.naml$b_rsl
4783#define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4784#define rms_set_fna(fab, nam, name, size) \
a1887106 4785 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
a480973c 4786 nam.naml$l_long_filename_size = size; \
a1887106 4787 nam.naml$l_long_filename = name;}
a480973c
JM		 4788#define rms_get_fna(fab, nam) nam.naml$l_long_filename
4789#define rms_set_dna(fab, nam, name, size) \
a1887106 4790 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
a480973c 4791 nam.naml$l_long_defname_size = size; \
a1887106 4792 nam.naml$l_long_defname = name; }
a480973c 4793#define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
d584a1c6 4794#define rms_set_esa(nam, name, size) \
a1887106 4795 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
a480973c 4796 nam.naml$l_long_expand_alloc = size; \
a1887106 4797 nam.naml$l_long_expand = name; }
a480973c 4798#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4799 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
a480973c 4800 nam.naml$l_long_expand = l_name; \
a1887106 4801 nam.naml$l_long_expand_alloc = l_size; }
a480973c 4802#define rms_set_rsa(nam, name, size) \
a1887106 4803 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
a480973c 4804 nam.naml$l_long_result = name; \
a1887106 4805 nam.naml$l_long_result_alloc = size; }
a480973c 4806#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106 4807 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
a480973c 4808 nam.naml$l_long_result = l_name; \
a1887106
JM		 4809 nam.naml$l_long_result_alloc = l_size; }
4810#define rms_nam_name_type_l_size(nam) \
4811 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
a480973c
JM		 4812#endif
4813
4fdf8f88 4814
e0e5e8d6
JM		 4815/* rms_erase
4816 * The CRTL for 8.3 and later can create symbolic links in any mode,
4fdf8f88 4817 * however in 8.3 the unlink/remove/delete routines will only properly handle
e0e5e8d6 4818 * them if one of the PCP modes is active.
e0e5e8d6
JM		 4819 */
4820static int rms_erase(const char * vmsname)
4821{
4822 int status;
4823 struct FAB myfab = cc$rms_fab;
4824 rms_setup_nam(mynam);
4825
4826 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4827 rms_bind_fab_nam(myfab, mynam);
4fdf8f88 4828
e0e5e8d6
JM		 4829 /* Are we removing all versions? */
4830 if (vms_unlink_all_versions == 1) {
4831 const char * defspec = ";*";
4832 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4833 }
4834
4835#ifdef NAML$M_OPEN_SPECIAL
4836 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4837#endif
4838
d30c1055 4839 status = sys$erase(&myfab, 0, 0);
e0e5e8d6
JM		 4840
4841 return status;
4842}
4843
bbce6d69 4844
4fdf8f88
JM		 4845static int
4846vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4847 const struct dsc$descriptor_s * vms_dst_dsc,
4848 unsigned long flags)
4849{
4850 /* VMS and UNIX handle file permissions differently and the
4851 * the same ACL trick may be needed for renaming files,
4852 * especially if they are directories.
4853 */
4854
4855 /* todo: get kill_file and rename to share common code */
4856 /* I can not find online documentation for $change_acl
4857 * it appears to be replaced by $set_security some time ago */
4858
4859const unsigned int access_mode = 0;
4860$DESCRIPTOR(obj_file_dsc,"FILE");
4861char *vmsname;
4862char *rslt;
4863unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4864int aclsts, fndsts, rnsts = -1;
4865unsigned int ctx = 0;
4866struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4867struct dsc$descriptor_s * clean_dsc;
4868
4869struct myacedef {
4870 unsigned char myace$b_length;
4871 unsigned char myace$b_type;
4872 unsigned short int myace$w_flags;
4873 unsigned long int myace$l_access;
4874 unsigned long int myace$l_ident;
4875} newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4876 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4877 0},
4878 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4879
4880struct item_list_3
4881 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4882 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4883 {0,0,0,0}},
4884 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4885 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4886 {0,0,0,0}};
4887
4888
4889 /* Expand the input spec using RMS, since we do not want to put
4890 * ACLs on the target of a symbolic link */
4891 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4892 if (vmsname == NULL)
4893 return SS$_INSFMEM;
4894
4895 rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
4896 vmsname,
4897 0,
4898 NULL,
4899 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
4900 NULL,
4901 NULL);
4902 if (rslt == NULL) {
4903 PerlMem_free(vmsname);
4904 return SS$_INSFMEM;
4905 }
4906
4907 /* So we get our own UIC to use as a rights identifier,
4908 * and the insert an ACE at the head of the ACL which allows us
4909 * to delete the file.
4910 */
4911 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4912
4913 fildsc.dsc$w_length = strlen(vmsname);
4914 fildsc.dsc$a_pointer = vmsname;
4915 ctx = 0;
4916 newace.myace$l_ident = oldace.myace$l_ident;
4917 rnsts = SS$_ABORT;
4918
4919 /* Grab any existing ACEs with this identifier in case we fail */
4920 clean_dsc = &fildsc;
4921 aclsts = fndsts = sys$get_security(&obj_file_dsc,
4922 &fildsc,
4923 NULL,
4924 OSS$M_WLOCK,
4925 findlst,
4926 &ctx,
4927 &access_mode);
4928
4929 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
4930 /* Add the new ACE . . . */
4931
4932 /* if the sys$get_security succeeded, then ctx is valid, and the
4933 * object/file descriptors will be ignored. But otherwise they
4934 * are needed
4935 */
4936 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4937 OSS$M_RELCTX, addlst, &ctx, &access_mode);
4938 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4939 set_errno(EVMSERR);
4940 set_vaxc_errno(aclsts);
4941 PerlMem_free(vmsname);
4942 return aclsts;
4943 }
4944
4945 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4946 NULL, NULL,
4947 &flags,
4948 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4949
4950 if ($VMS_STATUS_SUCCESS(rnsts)) {
4951 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4952 }
4953
4954 /* Put things back the way they were. */
4955 ctx = 0;
4956 aclsts = sys$get_security(&obj_file_dsc,
4957 clean_dsc,
4958 NULL,
4959 OSS$M_WLOCK,
4960 findlst,
4961 &ctx,
4962 &access_mode);
4963
4964 if ($VMS_STATUS_SUCCESS(aclsts)) {
4965 int sec_flags;
4966
4967 sec_flags = 0;
4968 if (!$VMS_STATUS_SUCCESS(fndsts))
4969 sec_flags = OSS$M_RELCTX;
4970
4971 /* Get rid of the new ACE */
4972 aclsts = sys$set_security(NULL, NULL, NULL,
4973 sec_flags, dellst, &ctx, &access_mode);
4974
4975 /* If there was an old ACE, put it back */
4976 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
4977 addlst[0].bufadr = &oldace;
4978 aclsts = sys$set_security(NULL, NULL, NULL,
4979 OSS$M_RELCTX, addlst, &ctx, &access_mode);
4980 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4981 set_errno(EVMSERR);
4982 set_vaxc_errno(aclsts);
4983 rnsts = aclsts;
4984 }
4985 } else {
4986 int aclsts2;
4987
4988 /* Try to clear the lock on the ACL list */
4989 aclsts2 = sys$set_security(NULL, NULL, NULL,
4990 OSS$M_RELCTX, NULL, &ctx, &access_mode);
4991
4992 /* Rename errors are most important */
4993 if (!$VMS_STATUS_SUCCESS(rnsts))
4994 aclsts = rnsts;
4995 set_errno(EVMSERR);
4996 set_vaxc_errno(aclsts);
4997 rnsts = aclsts;
4998 }
4999 }
5000 else {
5001 if (aclsts != SS$_ACLEMPTY)
5002 rnsts = aclsts;
5003 }
5004 }
5005 else
5006 rnsts = fndsts;
5007
5008 PerlMem_free(vmsname);
5009 return rnsts;
5010}
5011
5012
5013/*{{{int rename(const char *, const char * */
5014/* Not exactly what X/Open says to do, but doing it absolutely right
5015 * and efficiently would require a lot more work. This should be close
5016 * enough to pass all but the most strict X/Open compliance test.
5017 */
5018int
5019Perl_rename(pTHX_ const char *src, const char * dst)
5020{
5021int retval;
5022int pre_delete = 0;
5023int src_sts;
5024int dst_sts;
5025Stat_t src_st;
5026Stat_t dst_st;
5027
5028 /* Validate the source file */
5029 src_sts = flex_lstat(src, &src_st);
5030 if (src_sts != 0) {
5031
5032 /* No source file or other problem */
5033 return src_sts;
5034 }
5035
5036 dst_sts = flex_lstat(dst, &dst_st);
5037 if (dst_sts == 0) {
5038
5039 if (dst_st.st_dev != src_st.st_dev) {
5040 /* Must be on the same device */
5041 errno = EXDEV;
5042 return -1;
5043 }
5044
5045 /* VMS_INO_T_COMPARE is true if the inodes are different
5046 * to match the output of memcmp
5047 */
5048
5049 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5050 /* That was easy, the files are the same! */
5051 return 0;
5052 }
5053
5054 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5055 /* If source is a directory, so must be dest */
5056 errno = EISDIR;
5057 return -1;
5058 }
5059
5060 }
5061
5062
5063 if ((dst_sts == 0) &&
5064 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5065
5066 /* We have issues here if vms_unlink_all_versions is set
5067 * If the destination exists, and is not a directory, then
5068 * we must delete in advance.
5069 *
5070 * If the src is a directory, then we must always pre-delete
5071 * the destination.
5072 *
5073 * If we successfully delete the dst in advance, and the rename fails
5074 * X/Open requires that errno be EIO.
5075 *
5076 */
5077
5078 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5079 int d_sts;
5080 d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5081 if (d_sts != 0)
5082 return d_sts;
5083
5084 /* We killed the destination, so only errno now is EIO */
5085 pre_delete = 1;
5086 }
5087 }
5088
5089 /* Originally the idea was to call the CRTL rename() and only
5090 * try the lib$rename_file if it failed.
5091 * It turns out that there are too many variants in what the
5092 * the CRTL rename might do, so only use lib$rename_file
5093 */
5094 retval = -1;
5095
5096 {
5097 /* Is the source and dest both in VMS format */
5098 /* if the source is a directory, then need to fileify */
5099 /* and dest must be a directory or non-existant. */
5100
5101 char * vms_src;
5102 char * vms_dst;
5103 int sts;
5104 char * ret_str;
5105 unsigned long flags;
5106 struct dsc$descriptor_s old_file_dsc;
5107 struct dsc$descriptor_s new_file_dsc;
5108
5109 /* We need to modify the src and dst depending
5110 * on if one or more of them are directories.
5111 */
5112
5113 vms_src = PerlMem_malloc(VMS_MAXRSS);
5114 if (vms_src == NULL)
5115 _ckvmssts(SS$_INSFMEM);
5116
5117 /* Source is always a VMS format file */
5118 ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5119 if (ret_str == NULL) {
5120 PerlMem_free(vms_src);
5121 errno = EIO;
5122 return -1;
5123 }
5124
5125 vms_dst = PerlMem_malloc(VMS_MAXRSS);
5126 if (vms_dst == NULL)
5127 _ckvmssts(SS$_INSFMEM);
5128
5129 if (S_ISDIR(src_st.st_mode)) {
5130 char * ret_str;
5131 char * vms_dir_file;
5132
5133 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5134 if (vms_dir_file == NULL)
5135 _ckvmssts(SS$_INSFMEM);
5136
5137 /* The source must be a file specification */
5138 ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5139 if (ret_str == NULL) {
5140 PerlMem_free(vms_src);
5141 PerlMem_free(vms_dst);
5142 PerlMem_free(vms_dir_file);
5143 errno = EIO;
5144 return -1;
5145 }
5146 PerlMem_free(vms_src);
5147 vms_src = vms_dir_file;
5148
5149 /* If the dest is a directory, we must remove it
5150 if (dst_sts == 0) {
5151 int d_sts;
5152 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5153 if (d_sts != 0) {
5154 PerlMem_free(vms_src);
5155 PerlMem_free(vms_dst);
5156 errno = EIO;
5157 return sts;
5158 }
5159
5160 pre_delete = 1;
5161 }
5162
5163 /* The dest must be a VMS file specification */
5164 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5165 if (ret_str == NULL) {
5166 PerlMem_free(vms_src);
5167 PerlMem_free(vms_dst);
5168 errno = EIO;
5169 return -1;
5170 }
5171
5172 /* The source must be a file specification */
5173 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5174 if (vms_dir_file == NULL)
5175 _ckvmssts(SS$_INSFMEM);
5176
5177 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5178 if (ret_str == NULL) {
5179 PerlMem_free(vms_src);
5180 PerlMem_free(vms_dst);
5181 PerlMem_free(vms_dir_file);
5182 errno = EIO;
5183 return -1;
5184 }
5185 PerlMem_free(vms_dst);
5186 vms_dst = vms_dir_file;
5187
5188 } else {
5189 /* File to file or file to new dir */
5190
5191 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5192 /* VMS pathify a dir target */
5193 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5194 if (ret_str == NULL) {
5195 PerlMem_free(vms_src);
5196 PerlMem_free(vms_dst);
5197 errno = EIO;
5198 return -1;
5199 }
5200 } else {
5201
5202 /* fileify a target VMS file specification */
5203 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5204 if (ret_str == NULL) {
5205 PerlMem_free(vms_src);
5206 PerlMem_free(vms_dst);
5207 errno = EIO;
5208 return -1;
5209 }
5210 }
5211 }
5212
5213 old_file_dsc.dsc$a_pointer = vms_src;
5214 old_file_dsc.dsc$w_length = strlen(vms_src);
5215 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5216 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5217
5218 new_file_dsc.dsc$a_pointer = vms_dst;
5219 new_file_dsc.dsc$w_length = strlen(vms_dst);
5220 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5221 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5222
5223 flags = 0;
5224#if !defined(__VAX) && defined(NAML$C_MAXRSS)
5225 flags |= 2; /* LIB$M_FIL_LONG_NAMES */
5226#endif
5227
5228 sts = lib$rename_file(&old_file_dsc,
5229 &new_file_dsc,
5230 NULL, NULL,
5231 &flags,
5232 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5233 if (!$VMS_STATUS_SUCCESS(sts)) {
5234
5235 /* We could have failed because VMS style permissions do not
5236 * permit renames that UNIX will allow. Just like the hack
5237 * in for kill_file.
5238 */
5239 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5240 }
5241
5242 PerlMem_free(vms_src);
5243 PerlMem_free(vms_dst);
5244 if (!$VMS_STATUS_SUCCESS(sts)) {
5245 errno = EIO;
5246 return -1;
5247 }
5248 retval = 0;
5249 }
5250
5251 if (vms_unlink_all_versions) {
5252 /* Now get rid of any previous versions of the source file that
5253 * might still exist
5254 */
5255 int save_errno;
5256 save_errno = errno;
5257 src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5258 errno = save_errno;
5259 }
5260
5261 /* We deleted the destination, so must force the error to be EIO */
5262 if ((retval != 0) && (pre_delete != 0))
5263 errno = EIO;
5264
5265 return retval;
5266}
5267/*}}}*/
5268
5269
bbce6d69 5270/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5271/* Shortcut for common case of simple calls to $PARSE and $SEARCH
5272 * to expand file specification. Allows for a single default file
5273 * specification and a simple mask of options. If outbuf is non-NULL,
5274 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5275 * the resultant file specification is placed. If outbuf is NULL, the
5276 * resultant file specification is placed into a static buffer.
5277 * The third argument, if non-NULL, is taken to be a default file
5278 * specification string. The fourth argument is unused at present.
5279 * rmesexpand() returns the address of the resultant string if
5280 * successful, and NULL on error.
e886094b
JM		 5281 *
5282 * New functionality for previously unused opts value:
5283 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
a1887106
JM		 5284 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5285 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
e0e5e8d6 5286 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
bbce6d69 5287 */
360732b5 5288static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
96e4d5b1 5289
bbce6d69 5290static char *
360732b5
JM		 5291mp_do_rmsexpand
5292 (pTHX_ const char *filespec,
5293 char *outbuf,
5294 int ts,
5295 const char *defspec,
5296 unsigned opts,
5297 int * fs_utf8,
5298 int * dfs_utf8)
bbce6d69 5299{
a1887106 5300 static char __rmsexpand_retbuf[VMS_MAXRSS];
18a3d61e
JM		 5301 char * vmsfspec, *tmpfspec;
5302 char * esa, *cp, *out = NULL;
c5375c28 5303 char * tbuf;
7566800d 5304 char * esal = NULL;
18a3d61e
JM		 5305 char * outbufl;
5306 struct FAB myfab = cc$rms_fab;
a480973c 5307 rms_setup_nam(mynam);
18a3d61e
JM		 5308 STRLEN speclen;
5309 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5310 int sts;
5311
360732b5
JM		 5312 /* temp hack until UTF8 is actually implemented */
5313 if (fs_utf8 != NULL)
5314 *fs_utf8 = 0;
5315
18a3d61e
JM		 5316 if (!filespec || !*filespec) {
5317 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5318 return NULL;
5319 }
5320 if (!outbuf) {
5321 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5322 else outbuf = __rmsexpand_retbuf;
5323 }
5324
5325 vmsfspec = NULL;
5326 tmpfspec = NULL;
5327 outbufl = NULL;
a1887106
JM		 5328
5329 isunix = 0;
5330 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5331 isunix = is_unix_filespec(filespec);
5332 if (isunix) {
5333 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5334 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
360732b5 5335 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
c5375c28 5336 PerlMem_free(vmsfspec);
18a3d61e
JM		 5337 if (out)
5338 Safefree(out);
5339 return NULL;
a1887106
JM		 5340 }
5341 filespec = vmsfspec;
18a3d61e 5342
a1887106
JM		 5343 /* Unless we are forcing to VMS format, a UNIX input means
5344 * UNIX output, and that requires long names to be used
5345 */
5346 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
18a3d61e 5347 opts |= PERL_RMSEXPAND_M_LONG;
a1887106 5348 else {
18a3d61e 5349 isunix = 0;
a1887106 5350 }
18a3d61e
JM		 5351 }
5352 }
5353
a480973c
JM		 5354 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5355 rms_bind_fab_nam(myfab, mynam);
18a3d61e
JM		 5356
5357 if (defspec && *defspec) {
5358 int t_isunix;
5359 t_isunix = is_unix_filespec(defspec);
5360 if (t_isunix) {
c5375c28
JM		 5361 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5362 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
360732b5 5363 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
c5375c28 5364 PerlMem_free(tmpfspec);
18a3d61e 5365 if (vmsfspec != NULL)
c5375c28 5366 PerlMem_free(vmsfspec);
18a3d61e
JM		 5367 if (out)
5368 Safefree(out);
5369 return NULL;
5370 }
5371 defspec = tmpfspec;
5372 }
a480973c 5373 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
18a3d61e
JM		 5374 }
5375
c5375c28
JM		 5376 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5377 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
a480973c 5378#if !defined(__VAX) && defined(NAML$C_MAXRSS)
a1887106 5379 esal = PerlMem_malloc(VMS_MAXRSS);
c5375c28 5380 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
a480973c 5381#endif
a1887106 5382 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
18a3d61e 5383
d584a1c6
JM		 5384 /* If a NAML block is used RMS always writes to the long and short
5385 * addresses unless you suppress the short name.
5386 */
a480973c 5387#if !defined(__VAX) && defined(NAML$C_MAXRSS)
d584a1c6
JM		 5388 outbufl = PerlMem_malloc(VMS_MAXRSS);
5389 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
a480973c 5390#endif
d584a1c6 5391 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
18a3d61e 5392
f7ddb74a
JM		 5393#ifdef NAM$M_NO_SHORT_UPCASE
5394 if (decc_efs_case_preserve)
a480973c 5395 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 5396#endif
18a3d61e 5397
e0e5e8d6
JM		 5398 /* We may not want to follow symbolic links */
5399#ifdef NAML$M_OPEN_SPECIAL
5400 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5401 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5402#endif
5403
18a3d61e
JM		 5404 /* First attempt to parse as an existing file */
5405 retsts = sys$parse(&myfab,0,0);
5406 if (!(retsts & STS$K_SUCCESS)) {
5407
5408 /* Could not find the file, try as syntax only if error is not fatal */
a480973c 5409 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
18a3d61e
JM		 5410 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5411 retsts = sys$parse(&myfab,0,0);
5412 if (retsts & STS$K_SUCCESS) goto expanded;
5413 }
5414
5415 /* Still could not parse the file specification */
5416 /*----------------------------------------------*/
a480973c 5417 sts = rms_free_search_context(&myfab); /* Free search context */
18a3d61e
JM		 5418 if (out) Safefree(out);
5419 if (tmpfspec != NULL)
c5375c28 5420 PerlMem_free(tmpfspec);
18a3d61e 5421 if (vmsfspec != NULL)
c5375c28
JM		 5422 PerlMem_free(vmsfspec);
5423 if (outbufl != NULL)
5424 PerlMem_free(outbufl);
5425 PerlMem_free(esa);
7566800d
CB		 5426 if (esal != NULL)
5427 PerlMem_free(esal);
18a3d61e
JM		 5428 set_vaxc_errno(retsts);
5429 if (retsts == RMS$_PRV) set_errno(EACCES);
5430 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5431 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5432 else set_errno(EVMSERR);
5433 return NULL;
5434 }
5435 retsts = sys$search(&myfab,0,0);
5436 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
a480973c 5437 sts = rms_free_search_context(&myfab); /* Free search context */
18a3d61e
JM		 5438 if (out) Safefree(out);
5439 if (tmpfspec != NULL)
c5375c28 5440 PerlMem_free(tmpfspec);
18a3d61e 5441 if (vmsfspec != NULL)
c5375c28
JM		 5442 PerlMem_free(vmsfspec);
5443 if (outbufl != NULL)
5444 PerlMem_free(outbufl);
5445 PerlMem_free(esa);
7566800d
CB		 5446 if (esal != NULL)
5447 PerlMem_free(esal);
18a3d61e
JM		 5448 set_vaxc_errno(retsts);
5449 if (retsts == RMS$_PRV) set_errno(EACCES);
5450 else set_errno(EVMSERR);
5451 return NULL;
5452 }
5453
5454 /* If the input filespec contained any lowercase characters,
5455 * downcase the result for compatibility with Unix-minded code. */
5456 expanded:
5457 if (!decc_efs_case_preserve) {
c5375c28
JM		 5458 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5459 if (islower(*tbuf)) { haslower = 1; break; }
18a3d61e
JM		 5460 }
5461
5462 /* Is a long or a short name expected */
5463 /*------------------------------------*/
5464 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 5465 if (rms_nam_rsll(mynam)) {
d584a1c6 5466 tbuf = outbufl;
a480973c 5467 speclen = rms_nam_rsll(mynam);
18a3d61e
JM		 5468 }
5469 else {
c5375c28 5470 tbuf = esal; /* Not esa */
a480973c 5471 speclen = rms_nam_esll(mynam);
18a3d61e
JM		 5472 }
5473 }
5474 else {
a480973c 5475 if (rms_nam_rsl(mynam)) {
c5375c28 5476 tbuf = outbuf;
a480973c 5477 speclen = rms_nam_rsl(mynam);
18a3d61e
JM		 5478 }
5479 else {
c5375c28 5480 tbuf = esa; /* Not esal */
a480973c 5481 speclen = rms_nam_esl(mynam);
18a3d61e
JM		 5482 }
5483 }
4d743a9b
JM		 5484 tbuf[speclen] = '\0';
5485
18a3d61e
JM		 5486 /* Trim off null fields added by $PARSE
5487 * If type > 1 char, must have been specified in original or default spec
5488 * (not true for version; $SEARCH may have added version of existing file).
5489 */
a480973c 5490 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
18a3d61e 5491 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 5492 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5493 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
18a3d61e
JM		 5494 }
5495 else {
a480973c
JM		 5496 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5497 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
18a3d61e
JM		 5498 }
5499 if (trimver || trimtype) {
5500 if (defspec && *defspec) {
5501 char *defesal = NULL;
d584a1c6
JM		 5502 char *defesa = NULL;
5503 defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5504 if (defesa != NULL) {
5505#if !defined(__VAX) && defined(NAML$C_MAXRSS)
5506 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5507 if (defesal == NULL) _ckvmssts(SS$_INSFMEM);
5508#endif
18a3d61e 5509 struct FAB deffab = cc$rms_fab;
a480973c 5510 rms_setup_nam(defnam);
18a3d61e 5511
a480973c
JM		 5512 rms_bind_fab_nam(deffab, defnam);
5513
5514 /* Cast ok */
5515 rms_set_fna
5516 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5517
d584a1c6
JM		 5518 /* RMS needs the esa/esal as a work area if wildcards are involved */
5519 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
a480973c 5520
4d743a9b 5521 rms_clear_nam_nop(defnam);
a480973c 5522 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
18a3d61e
JM		 5523#ifdef NAM$M_NO_SHORT_UPCASE
5524 if (decc_efs_case_preserve)
a480973c 5525 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
18a3d61e 5526#endif
e0e5e8d6
JM		 5527#ifdef NAML$M_OPEN_SPECIAL
5528 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5529 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5530#endif
18a3d61e
JM		 5531 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5532 if (trimver) {
a480973c 5533 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
18a3d61e
JM		 5534 }
5535 if (trimtype) {
a480973c 5536 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
18a3d61e
JM		 5537 }
5538 }
d584a1c6
JM		 5539 if (defesal != NULL)
5540 PerlMem_free(defesal);
5541 PerlMem_free(defesa);
18a3d61e
JM		 5542 }
5543 }
5544 if (trimver) {
5545 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 5546 if (*(rms_nam_verl(mynam)) != '\"')
c5375c28 5547 speclen = rms_nam_verl(mynam) - tbuf;
18a3d61e
JM		 5548 }
5549 else {
a480973c 5550 if (*(rms_nam_ver(mynam)) != '\"')
c5375c28 5551 speclen = rms_nam_ver(mynam) - tbuf;
18a3d61e
JM		 5552 }
5553 }
5554 if (trimtype) {
5555 /* If we didn't already trim version, copy down */
5556 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
c5375c28 5557 if (speclen > rms_nam_verl(mynam) - tbuf)
18a3d61e 5558 memmove
a480973c
JM		 5559 (rms_nam_typel(mynam),
5560 rms_nam_verl(mynam),
c5375c28 5561 speclen - (rms_nam_verl(mynam) - tbuf));
a480973c 5562 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
18a3d61e
JM		 5563 }
5564 else {
c5375c28 5565 if (speclen > rms_nam_ver(mynam) - tbuf)
18a3d61e 5566 memmove
a480973c
JM		 5567 (rms_nam_type(mynam),
5568 rms_nam_ver(mynam),
c5375c28 5569 speclen - (rms_nam_ver(mynam) - tbuf));
a480973c 5570 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
18a3d61e
JM		 5571 }
5572 }
5573 }
5574
5575 /* Done with these copies of the input files */
5576 /*-------------------------------------------*/
5577 if (vmsfspec != NULL)
c5375c28 5578 PerlMem_free(vmsfspec);
18a3d61e 5579 if (tmpfspec != NULL)
c5375c28 5580 PerlMem_free(tmpfspec);
18a3d61e
JM		 5581
5582 /* If we just had a directory spec on input, $PARSE "helpfully"
5583 * adds an empty name and type for us */
d584a1c6 5584#if !defined(__VAX) && defined(NAML$C_MAXRSS)
18a3d61e 5585 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 5586 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5587 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5588 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
c5375c28 5589 speclen = rms_nam_namel(mynam) - tbuf;
18a3d61e 5590 }
d584a1c6
JM		 5591 else
5592#endif
5593 {
a480973c
JM		 5594 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5595 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5596 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
c5375c28 5597 speclen = rms_nam_name(mynam) - tbuf;
18a3d61e
JM		 5598 }
5599
5600 /* Posix format specifications must have matching quotes */
4d743a9b
JM		 5601 if (speclen < (VMS_MAXRSS - 1)) {
5602 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5603 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5604 tbuf[speclen] = '\"';
5605 speclen++;
5606 }
18a3d61e
JM		 5607 }
5608 }
c5375c28
JM		 5609 tbuf[speclen] = '\0';
5610 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
18a3d61e
JM		 5611
5612 /* Have we been working with an expanded, but not resultant, spec? */
5613 /* Also, convert back to Unix syntax if necessary. */
d584a1c6
JM		 5614 {
5615 int rsl;
18a3d61e 5616
d584a1c6
JM		 5617#if !defined(__VAX) && defined(NAML$C_MAXRSS)
5618 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5619 rsl = rms_nam_rsll(mynam);
5620 } else
5621#endif
5622 {
5623 rsl = rms_nam_rsl(mynam);
5624 }
5625 if (!rsl) {
5626 if (isunix) {
5627 if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5628 if (out) Safefree(out);
5629 if (esal != NULL)
7566800d 5630 PerlMem_free(esal);
d584a1c6
JM		 5631 PerlMem_free(esa);
5632 if (outbufl != NULL)
c5375c28 5633 PerlMem_free(outbufl);
d584a1c6
JM		 5634 return NULL;
5635 }
18a3d61e 5636 }
d584a1c6 5637 else strcpy(outbuf, tbuf);
18a3d61e 5638 }
d584a1c6
JM		 5639 else if (isunix) {
5640 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5641 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5642 if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
c5375c28
JM		 5643 if (out) Safefree(out);
5644 PerlMem_free(esa);
7566800d
CB		 5645 if (esal != NULL)
5646 PerlMem_free(esal);
c5375c28
JM		 5647 PerlMem_free(tmpfspec);
5648 if (outbufl != NULL)
5649 PerlMem_free(outbufl);
18a3d61e 5650 return NULL;
d584a1c6
JM		 5651 }
5652 strcpy(outbuf,tmpfspec);
5653 PerlMem_free(tmpfspec);
18a3d61e 5654 }
18a3d61e 5655 }
a480973c
JM		 5656 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5657 sts = rms_free_search_context(&myfab); /* Free search context */
c5375c28 5658 PerlMem_free(esa);
7566800d
CB		 5659 if (esal != NULL)
5660 PerlMem_free(esal);
c5375c28
JM		 5661 if (outbufl != NULL)
5662 PerlMem_free(outbufl);
bbce6d69 5663 return outbuf;
5664}
5665/*}}}*/
5666/* External entry points */
2fbb330f 5667char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
360732b5 5668{ return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
2fbb330f 5669char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
360732b5
JM		 5670{ return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5671char *Perl_rmsexpand_utf8
5672 (pTHX_ const char *spec, char *buf, const char *def,
5673 unsigned opt, int * fs_utf8, int * dfs_utf8)
5674{ return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5675char *Perl_rmsexpand_utf8_ts
5676 (pTHX_ const char *spec, char *buf, const char *def,
5677 unsigned opt, int * fs_utf8, int * dfs_utf8)
5678{ return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
bbce6d69 5679
5680
a0d0e21e
LW		 5681/*
5682** The following routines are provided to make life easier when
5683** converting among VMS-style and Unix-style directory specifications.
5684** All will take input specifications in either VMS or Unix syntax. On
5685** failure, all return NULL. If successful, the routines listed below
748a9306 5686** return a pointer to a buffer containing the appropriately
a0d0e21e
LW		 5687** reformatted spec (and, therefore, subsequent calls to that routine
5688** will clobber the result), while the routines of the same names with
5689** a _ts suffix appended will return a pointer to a mallocd string
5690** containing the appropriately reformatted spec.
5691** In all cases, only explicit syntax is altered; no check is made that
5692** the resulting string is valid or that the directory in question
5693** actually exists.
5694**
5695** fileify_dirspec() - convert a directory spec into the name of the
5696** directory file (i.e. what you can stat() to see if it's a dir).
5697** The style (VMS or Unix) of the result is the same as the style
5698** of the parameter passed in.
5699** pathify_dirspec() - convert a directory spec into a path (i.e.
5700** what you prepend to a filename to indicate what directory it's in).
5701** The style (VMS or Unix) of the result is the same as the style
5702** of the parameter passed in.
5703** tounixpath() - convert a directory spec into a Unix-style path.
5704** tovmspath() - convert a directory spec into a VMS-style path.
5705** tounixspec() - convert any file spec into a Unix-style file spec.
5706** tovmsspec() - convert any file spec into a VMS-style spec.
360732b5 5707** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
e518068a 5708**
bd3fa61c 5709** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
01b8edb6 5710** Permission is given to distribute this code as part of the Perl
5711** standard distribution under the terms of the GNU General Public
5712** License or the Perl Artistic License. Copies of each may be
5713** found in the Perl standard distribution.
a0d0e21e
LW		 5714 */
5715
360732b5
JM		 5716/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5717static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
a0d0e21e 5718{
a480973c 5719 static char __fileify_retbuf[VMS_MAXRSS];
b7ae7a0d 5720 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
a0d0e21e 5721 char *retspec, *cp1, *cp2, *lastdir;
a480973c 5722 char *trndir, *vmsdir;
2d9f3838 5723 unsigned short int trnlnm_iter_count;
f7ddb74a 5724 int sts;
360732b5
JM		 5725 if (utf8_fl != NULL)
5726 *utf8_fl = 0;
a0d0e21e 5727
c07a80fd 5728 if (!dir || !*dir) {
5729 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5730 }
a0d0e21e 5731 dirlen = strlen(dir);
a2a90019 5732 while (dirlen && dir[dirlen-1] == '/') --dirlen;
61bb5906 5733 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
f7ddb74a
JM		 5734 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5735 dir = "/sys$disk";
5736 dirlen = 9;
5737 }
5738 else
5739 dirlen = 1;
61bb5906 5740 }
a480973c
JM		 5741 if (dirlen > (VMS_MAXRSS - 1)) {
5742 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5743 return NULL;
c07a80fd 5744 }
c5375c28
JM		 5745 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5746 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
f7ddb74a
JM		 5747 if (!strpbrk(dir+1,"/]>:") &&
5748 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
e518068a 5749 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2d9f3838 5750 trnlnm_iter_count = 0;
e538e23f 5751 while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
2d9f3838
CB		 5752 trnlnm_iter_count++;
5753 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5754 }
b8ffc8df 5755 dirlen = strlen(trndir);
e518068a 5756 }
01b8edb6 5757 else {
5758 strncpy(trndir,dir,dirlen);
5759 trndir[dirlen] = '\0';
01b8edb6 5760 }
b8ffc8df
RGS		 5761
5762 /* At this point we are done with *dir and use *trndir which is a
5763 * copy that can be modified. *dir must not be modified.
5764 */
5765
c07a80fd 5766 /* If we were handed a rooted logical name or spec, treat it like a
5767 * simple directory, so that
5768 * $ Define myroot dev:[dir.]
5769 * ... do_fileify_dirspec("myroot",buf,1) ...
5770 * does something useful.
5771 */
b8ffc8df
RGS		 5772 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5773 trndir[--dirlen] = '\0';
5774 trndir[dirlen-1] = ']';
c07a80fd 5775 }
b8ffc8df
RGS		 5776 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5777 trndir[--dirlen] = '\0';
5778 trndir[dirlen-1] = '>';
46112e17 5779 }
e518068a 5780
b8ffc8df 5781 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
b7ae7a0d 5782 /* If we've got an explicit filename, we can just shuffle the string. */
5783 if (*(cp1+1)) hasfilename = 1;
5784 /* Similarly, we can just back up a level if we've got multiple levels
5785 of explicit directories in a VMS spec which ends with directories. */
5786 else {
b8ffc8df 5787 for (cp2 = cp1; cp2 > trndir; cp2--) {
f7ddb74a
JM		 5788 if (*cp2 == '.') {
5789 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
657054d4 5790/* fix-me, can not scan EFS file specs backward like this */
f7ddb74a
JM		 5791 *cp2 = *cp1; *cp1 = '\0';
5792 hasfilename = 1;
5793 break;
5794 }
b7ae7a0d 5795 }
5796 if (*cp2 == '[' || *cp2 == '<') break;
5797 }
5798 }
5799 }
5800
c5375c28
JM		 5801 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5802 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
a480973c 5803 cp1 = strpbrk(trndir,"]:>");
f7ddb74a 5804 if (hasfilename || !cp1) { /* Unix-style path or filename */
b8ffc8df 5805 if (trndir[0] == '.') {
a480973c 5806 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
c5375c28
JM		 5807 PerlMem_free(trndir);
5808 PerlMem_free(vmsdir);
360732b5 5809 return do_fileify_dirspec("[]",buf,ts,NULL);
a480973c 5810 }
b8ffc8df 5811 else if (trndir[1] == '.' &&
a480973c 5812 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
c5375c28
JM		 5813 PerlMem_free(trndir);
5814 PerlMem_free(vmsdir);
360732b5 5815 return do_fileify_dirspec("[-]",buf,ts,NULL);
a480973c 5816 }
748a9306 5817 }
b8ffc8df 5818 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
a0d0e21e 5819 dirlen -= 1; /* to last element */
b8ffc8df 5820 lastdir = strrchr(trndir,'/');
a0d0e21e 5821 }
b8ffc8df 5822 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
01b8edb6 5823 /* If we have "/." or "/..", VMSify it and let the VMS code
5824 * below expand it, rather than repeating the code to handle
5825 * relative components of a filespec here */
4633a7c4
LW		 5826 do {
5827 if (*(cp1+2) == '.') cp1++;
5828 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
a480973c 5829 char * ret_chr;
360732b5 5830 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
c5375c28
JM		 5831 PerlMem_free(trndir);
5832 PerlMem_free(vmsdir);
a480973c
JM		 5833 return NULL;
5834 }
fc1ce8cc
CB		 5835 if (strchr(vmsdir,'/') != NULL) {
5836 /* If do_tovmsspec() returned it, it must have VMS syntax
5837 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5838 * the time to check this here only so we avoid a recursion
5839 * loop; otherwise, gigo.
5840 */
c5375c28
JM		 5841 PerlMem_free(trndir);
5842 PerlMem_free(vmsdir);
a480973c
JM		 5843 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5844 return NULL;
fc1ce8cc 5845 }
360732b5 5846 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
c5375c28
JM		 5847 PerlMem_free(trndir);
5848 PerlMem_free(vmsdir);
a480973c
JM		 5849 return NULL;
5850 }
360732b5 5851 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
c5375c28
JM		 5852 PerlMem_free(trndir);
5853 PerlMem_free(vmsdir);
a480973c 5854 return ret_chr;
4633a7c4
LW		 5855 }
5856 cp1++;
5857 } while ((cp1 = strstr(cp1,"/.")) != NULL);
b8ffc8df 5858 lastdir = strrchr(trndir,'/');
748a9306 5859 }
b8ffc8df 5860 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
a480973c 5861 char * ret_chr;
61bb5906
CB		 5862 /* Ditto for specs that end in an MFD -- let the VMS code
5863 * figure out whether it's a real device or a rooted logical. */
f7ddb74a
JM		 5864
5865 /* This should not happen any more. Allowing the fake /000000
5866 * in a UNIX pathname causes all sorts of problems when trying
5867 * to run in UNIX emulation. So the VMS to UNIX conversions
5868 * now remove the fake /000000 directories.
5869 */
5870
b8ffc8df 5871 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
360732b5 5872 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
c5375c28
JM		 5873 PerlMem_free(trndir);
5874 PerlMem_free(vmsdir);
a480973c
JM		 5875 return NULL;
5876 }
360732b5 5877 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
c5375c28
JM		 5878 PerlMem_free(trndir);
5879 PerlMem_free(vmsdir);
a480973c
JM		 5880 return NULL;
5881 }
360732b5 5882 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
c5375c28
JM		 5883 PerlMem_free(trndir);
5884 PerlMem_free(vmsdir);
a480973c 5885 return ret_chr;
61bb5906 5886 }
a0d0e21e 5887 else {
f7ddb74a 5888
b8ffc8df
RGS		 5889 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5890 !(lastdir = cp1 = strrchr(trndir,']')) &&
5891 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
a0d0e21e 5892 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
b7ae7a0d 5893 int ver; char *cp3;
f7ddb74a
JM		 5894
5895 /* For EFS or ODS-5 look for the last dot */
5896 if (decc_efs_charset) {
5897 cp2 = strrchr(cp1,'.');
5898 }
5899 if (vms_process_case_tolerant) {
5900 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5901 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5902 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5903 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5904 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 5905 (ver || *cp3)))))) {
c5375c28
JM		 5906 PerlMem_free(trndir);
5907 PerlMem_free(vmsdir);
f7ddb74a
JM		 5908 set_errno(ENOTDIR);
5909 set_vaxc_errno(RMS$_DIR);
5910 return NULL;
5911 }
5912 }
5913 else {
5914 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5915 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5916 !*(cp2+3) || *(cp2+3) != 'R' ||
5917 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5918 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5919 (ver || *cp3)))))) {
c5375c28
JM		 5920 PerlMem_free(trndir);
5921 PerlMem_free(vmsdir);
f7ddb74a
JM		 5922 set_errno(ENOTDIR);
5923 set_vaxc_errno(RMS$_DIR);
5924 return NULL;
5925 }
a0d0e21e 5926 }
b8ffc8df 5927 dirlen = cp2 - trndir;
a0d0e21e 5928 }
748a9306 5929 }
f7ddb74a
JM		 5930
5931 retlen = dirlen + 6;
748a9306 5932 if (buf) retspec = buf;
a02a5408 5933 else if (ts) Newx(retspec,retlen+1,char);
748a9306 5934 else retspec = __fileify_retbuf;
f7ddb74a
JM		 5935 memcpy(retspec,trndir,dirlen);
5936 retspec[dirlen] = '\0';
5937
a0d0e21e
LW		 5938 /* We've picked up everything up to the directory file name.
5939 Now just add the type and version, and we're set. */
f7ddb74a
JM		 5940 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5941 strcat(retspec,".dir;1");
5942 else
5943 strcat(retspec,".DIR;1");
c5375c28
JM		 5944 PerlMem_free(trndir);
5945 PerlMem_free(vmsdir);
a0d0e21e
LW		 5946 return retspec;
5947 }
5948 else { /* VMS-style directory spec */
a480973c 5949
d584a1c6
JM		 5950 char *esa, *esal, term, *cp;
5951 char *my_esa;
5952 int my_esa_len;
01b8edb6 5953 unsigned long int sts, cmplen, haslower = 0;
a480973c
JM		 5954 unsigned int nam_fnb;
5955 char * nam_type;
a0d0e21e 5956 struct FAB dirfab = cc$rms_fab;
a480973c
JM		 5957 rms_setup_nam(savnam);
5958 rms_setup_nam(dirnam);
5959
d584a1c6 5960 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
c5375c28 5961 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
d584a1c6
JM		 5962 esal = NULL;
5963#if !defined(__VAX) && defined(NAML$C_MAXRSS)
5964 esal = PerlMem_malloc(VMS_MAXRSS);
5965 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5966#endif
a480973c
JM		 5967 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5968 rms_bind_fab_nam(dirfab, dirnam);
5969 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
d584a1c6 5970 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
f7ddb74a
JM		 5971#ifdef NAM$M_NO_SHORT_UPCASE
5972 if (decc_efs_case_preserve)
a480973c 5973 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 5974#endif
01b8edb6 5975
b8ffc8df 5976 for (cp = trndir; *cp; cp++)
01b8edb6 5977 if (islower(*cp)) { haslower = 1; break; }
a480973c 5978 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
f7ddb74a 5979 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
a480973c
JM		 5980 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5981 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
e518068a 5982 }
5983 if (!sts) {
c5375c28 5984 PerlMem_free(esa);
d584a1c6
JM		 5985 if (esal != NULL)
5986 PerlMem_free(esal);
c5375c28
JM		 5987 PerlMem_free(trndir);
5988 PerlMem_free(vmsdir);
748a9306
LW		 5989 set_errno(EVMSERR);
5990 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 5991 return NULL;
5992 }
e518068a 5993 }
5994 else {
5995 savnam = dirnam;
a480973c
JM		 5996 /* Does the file really exist? */
5997 if (sys$search(&dirfab)& STS$K_SUCCESS) {
e518068a 5998 /* Yes; fake the fnb bits so we'll check type below */
a480973c 5999 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
e518068a 6000 }
752635ea
CB		 6001 else { /* No; just work with potential name */
6002 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6003 else {
2623a4a6
JM		 6004 int fab_sts;
6005 fab_sts = dirfab.fab$l_sts;
6006 sts = rms_free_search_context(&dirfab);
c5375c28 6007 PerlMem_free(esa);
d584a1c6
JM		 6008 if (esal != NULL)
6009 PerlMem_free(esal);
c5375c28
JM		 6010 PerlMem_free(trndir);
6011 PerlMem_free(vmsdir);
2623a4a6 6012 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
e518068a 6013 return NULL;
6014 }
e518068a 6015 }
a0d0e21e 6016 }
d584a1c6
JM		 6017
6018 /* Make sure we are using the right buffer */
6019 if (esal != NULL) {
6020 my_esa = esal;
6021 my_esa_len = rms_nam_esll(dirnam);
6022 } else {
6023 my_esa = esa;
6024 my_esa_len = rms_nam_esl(dirnam);
6025 }
6026 my_esa[my_esa_len] = '\0';
a480973c 6027 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
d584a1c6
JM		 6028 cp1 = strchr(my_esa,']');
6029 if (!cp1) cp1 = strchr(my_esa,'>');
748a9306 6030 if (cp1) { /* Should always be true */
d584a1c6
JM		 6031 my_esa_len -= cp1 - my_esa - 1;
6032 memmove(my_esa, cp1 + 1, my_esa_len);
748a9306
LW		 6033 }
6034 }
a480973c 6035 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
a0d0e21e 6036 /* Yep; check version while we're at it, if it's there. */
a480973c
JM		 6037 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6038 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
a0d0e21e 6039 /* Something other than .DIR[;1]. Bzzt. */
a480973c 6040 sts = rms_free_search_context(&dirfab);
c5375c28 6041 PerlMem_free(esa);
d584a1c6
JM		 6042 if (esal != NULL)
6043 PerlMem_free(esal);
c5375c28
JM		 6044 PerlMem_free(trndir);
6045 PerlMem_free(vmsdir);
748a9306
LW		 6046 set_errno(ENOTDIR);
6047 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 6048 return NULL;
6049 }
748a9306 6050 }
ae6d78fe 6051
a480973c 6052 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
748a9306
LW		 6053 /* They provided at least the name; we added the type, if necessary, */
6054 if (buf) retspec = buf; /* in sys$parse() */
d584a1c6 6055 else if (ts) Newx(retspec, my_esa_len + 1, char);
748a9306 6056 else retspec = __fileify_retbuf;
d584a1c6 6057 strcpy(retspec,my_esa);
a480973c 6058 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 6059 PerlMem_free(trndir);
6060 PerlMem_free(esa);
d584a1c6
JM		 6061 if (esal != NULL)
6062 PerlMem_free(esal);
c5375c28 6063 PerlMem_free(vmsdir);
748a9306
LW		 6064 return retspec;
6065 }
c07a80fd 6066 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6067 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6068 *cp1 = '\0';
d584a1c6 6069 my_esa_len -= 9;
c07a80fd 6070 }
d584a1c6 6071 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
752635ea 6072 if (cp1 == NULL) { /* should never happen */
a480973c 6073 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 6074 PerlMem_free(trndir);
6075 PerlMem_free(esa);
d584a1c6
JM		 6076 if (esal != NULL)
6077 PerlMem_free(esal);
c5375c28 6078 PerlMem_free(vmsdir);
752635ea
CB		 6079 return NULL;
6080 }
748a9306
LW		 6081 term = *cp1;
6082 *cp1 = '\0';
d584a1c6
JM		 6083 retlen = strlen(my_esa);
6084 cp1 = strrchr(my_esa,'.');
f7ddb74a 6085 /* ODS-5 directory specifications can have extra "." in them. */
657054d4 6086 /* Fix-me, can not scan EFS file specifications backwards */
f7ddb74a 6087 while (cp1 != NULL) {
d584a1c6 6088 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
f7ddb74a
JM		 6089 break;
6090 else {
6091 cp1--;
d584a1c6 6092 while ((cp1 > my_esa) && (*cp1 != '.'))
f7ddb74a
JM		 6093 cp1--;
6094 }
d584a1c6 6095 if (cp1 == my_esa)
f7ddb74a
JM		 6096 cp1 = NULL;
6097 }
6098
6099 if ((cp1) != NULL) {
748a9306
LW		 6100 /* There's more than one directory in the path. Just roll back. */
6101 *cp1 = term;
6102 if (buf) retspec = buf;
a02a5408 6103 else if (ts) Newx(retspec,retlen+7,char);
748a9306 6104 else retspec = __fileify_retbuf;
d584a1c6 6105 strcpy(retspec,my_esa);
a0d0e21e
LW		 6106 }
6107 else {
a480973c 6108 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
748a9306 6109 /* Go back and expand rooted logical name */
a480973c 6110 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
f7ddb74a
JM		 6111#ifdef NAM$M_NO_SHORT_UPCASE
6112 if (decc_efs_case_preserve)
a480973c 6113 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6114#endif
a480973c
JM		 6115 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6116 sts = rms_free_search_context(&dirfab);
c5375c28 6117 PerlMem_free(esa);
d584a1c6
JM		 6118 if (esal != NULL)
6119 PerlMem_free(esal);
c5375c28
JM		 6120 PerlMem_free(trndir);
6121 PerlMem_free(vmsdir);
748a9306
LW		 6122 set_errno(EVMSERR);
6123 set_vaxc_errno(dirfab.fab$l_sts);
6124 return NULL;
6125 }
d584a1c6
JM		 6126
6127 /* This changes the length of the string of course */
6128 if (esal != NULL) {
6129 my_esa_len = rms_nam_esll(dirnam);
6130 } else {
6131 my_esa_len = rms_nam_esl(dirnam);
6132 }
6133
6134 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
a0d0e21e 6135 if (buf) retspec = buf;
a02a5408 6136 else if (ts) Newx(retspec,retlen+16,char);
a0d0e21e 6137 else retspec = __fileify_retbuf;
d584a1c6
JM		 6138 cp1 = strstr(my_esa,"][");
6139 if (!cp1) cp1 = strstr(my_esa,"]<");
6140 dirlen = cp1 - my_esa;
6141 memcpy(retspec,my_esa,dirlen);
748a9306
LW		 6142 if (!strncmp(cp1+2,"000000]",7)) {
6143 retspec[dirlen-1] = '\0';
657054d4 6144 /* fix-me Not full ODS-5, just extra dots in directories for now */
f7ddb74a
JM		 6145 cp1 = retspec + dirlen - 1;
6146 while (cp1 > retspec)
6147 {
6148 if (*cp1 == '[')
6149 break;
6150 if (*cp1 == '.') {
6151 if (*(cp1-1) != '^')
6152 break;
6153 }
6154 cp1--;
6155 }
4633a7c4
LW		 6156 if (*cp1 == '.') *cp1 = ']';
6157 else {
6158 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
18a3d61e 6159 memmove(cp1+1,"000000]",7);
4633a7c4 6160 }
748a9306
LW		 6161 }
6162 else {
18a3d61e 6163 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
748a9306
LW		 6164 retspec[retlen] = '\0';
6165 /* Convert last '.' to ']' */
f7ddb74a
JM		 6166 cp1 = retspec+retlen-1;
6167 while (*cp != '[') {
6168 cp1--;
6169 if (*cp1 == '.') {
6170 /* Do not trip on extra dots in ODS-5 directories */
6171 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6172 break;
6173 }
6174 }
4633a7c4
LW		 6175 if (*cp1 == '.') *cp1 = ']';
6176 else {
6177 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
18a3d61e 6178 memmove(cp1+1,"000000]",7);
4633a7c4 6179 }
748a9306 6180 }
a0d0e21e 6181 }
748a9306 6182 else { /* This is a top-level dir. Add the MFD to the path. */
a0d0e21e 6183 if (buf) retspec = buf;
a02a5408 6184 else if (ts) Newx(retspec,retlen+16,char);
a0d0e21e 6185 else retspec = __fileify_retbuf;
d584a1c6 6186 cp1 = my_esa;
a0d0e21e 6187 cp2 = retspec;
bbdb6c9a 6188 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
a0d0e21e
LW		 6189 strcpy(cp2,":[000000]");
6190 cp1 += 2;
6191 strcpy(cp2+9,cp1);
6192 }
748a9306 6193 }
a480973c 6194 sts = rms_free_search_context(&dirfab);
748a9306 6195 /* We've set up the string up through the filename. Add the
a0d0e21e
LW		 6196 type and version, and we're done. */
6197 strcat(retspec,".DIR;1");
01b8edb6 6198
6199 /* $PARSE may have upcased filespec, so convert output to lower
6200 * case if input contained any lowercase characters. */
f7ddb74a 6201 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
c5375c28
JM		 6202 PerlMem_free(trndir);
6203 PerlMem_free(esa);
d584a1c6
JM		 6204 if (esal != NULL)
6205 PerlMem_free(esal);
c5375c28 6206 PerlMem_free(vmsdir);
a0d0e21e
LW		 6207 return retspec;
6208 }
6209} /* end of do_fileify_dirspec() */
6210/*}}}*/
6211/* External entry points */
b8ffc8df 6212char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
360732b5 6213{ return do_fileify_dirspec(dir,buf,0,NULL); }
b8ffc8df 6214char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
360732b5
JM		 6215{ return do_fileify_dirspec(dir,buf,1,NULL); }
6216char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6217{ return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6218char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6219{ return do_fileify_dirspec(dir,buf,1,utf8_fl); }
a0d0e21e
LW		 6220
6221/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
360732b5 6222static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
a0d0e21e 6223{
a480973c 6224 static char __pathify_retbuf[VMS_MAXRSS];
a0d0e21e 6225 unsigned long int retlen;
a480973c 6226 char *retpath, *cp1, *cp2, *trndir;
2d9f3838 6227 unsigned short int trnlnm_iter_count;
baf3cf9c 6228 STRLEN trnlen;
f7ddb74a 6229 int sts;
360732b5
JM		 6230 if (utf8_fl != NULL)
6231 *utf8_fl = 0;
a0d0e21e 6232
c07a80fd 6233 if (!dir || !*dir) {
6234 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6235 }
6236
c5375c28
JM		 6237 trndir = PerlMem_malloc(VMS_MAXRSS);
6238 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
c07a80fd 6239 if (*dir) strcpy(trndir,dir);
a480973c 6240 else getcwd(trndir,VMS_MAXRSS - 1);
c07a80fd 6241
2d9f3838 6242 trnlnm_iter_count = 0;
93948341
CB		 6243 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6244 && my_trnlnm(trndir,trndir,0)) {
2d9f3838
CB		 6245 trnlnm_iter_count++;
6246 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
baf3cf9c 6247 trnlen = strlen(trndir);
a0d0e21e 6248
c07a80fd 6249 /* Trap simple rooted lnms, and return lnm:[000000] */
6250 if (!strcmp(trndir+trnlen-2,".]")) {
6251 if (buf) retpath = buf;
a02a5408 6252 else if (ts) Newx(retpath,strlen(dir)+10,char);
c07a80fd 6253 else retpath = __pathify_retbuf;
6254 strcpy(retpath,dir);
6255 strcat(retpath,":[000000]");
c5375c28 6256 PerlMem_free(trndir);
c07a80fd 6257 return retpath;
6258 }
6259 }
748a9306 6260
b8ffc8df
RGS		 6261 /* At this point we do not work with *dir, but the copy in
6262 * *trndir that is modifiable.
6263 */
6264
6265 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6266 if (*trndir == '.' && (*(trndir+1) == '\0' ||
6267 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6268 retlen = 2 + (*(trndir+1) != '\0');
748a9306 6269 else {
b8ffc8df
RGS		 6270 if ( !(cp1 = strrchr(trndir,'/')) &&
6271 !(cp1 = strrchr(trndir,']')) &&
6272 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
f86702cc 6273 if ((cp2 = strchr(cp1,'.')) != NULL &&
6274 (*(cp2-1) != '/' || /* Trailing '.', '..', */
6275 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
6276 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6277 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
b7ae7a0d 6278 int ver; char *cp3;
f7ddb74a
JM		 6279
6280 /* For EFS or ODS-5 look for the last dot */
6281 if (decc_efs_charset) {
6282 cp2 = strrchr(cp1,'.');
6283 }
6284 if (vms_process_case_tolerant) {
6285 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6286 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6287 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6288 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6289 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 6290 (ver || *cp3)))))) {
c5375c28 6291 PerlMem_free(trndir);
f7ddb74a
JM		 6292 set_errno(ENOTDIR);
6293 set_vaxc_errno(RMS$_DIR);
6294 return NULL;
6295 }
6296 }
6297 else {
6298 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6299 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6300 !*(cp2+3) || *(cp2+3) != 'R' ||
6301 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6302 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6303 (ver || *cp3)))))) {
c5375c28 6304 PerlMem_free(trndir);
f7ddb74a
JM		 6305 set_errno(ENOTDIR);
6306 set_vaxc_errno(RMS$_DIR);
6307 return NULL;
6308 }
6309 }
b8ffc8df 6310 retlen = cp2 - trndir + 1;
a0d0e21e 6311 }
748a9306 6312 else { /* No file type present. Treat the filename as a directory. */
b8ffc8df 6313 retlen = strlen(trndir) + 1;
a0d0e21e
LW		 6314 }
6315 }
a0d0e21e 6316 if (buf) retpath = buf;
a02a5408 6317 else if (ts) Newx(retpath,retlen+1,char);
a0d0e21e 6318 else retpath = __pathify_retbuf;
b8ffc8df 6319 strncpy(retpath, trndir, retlen-1);
a0d0e21e
LW		 6320 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6321 retpath[retlen-1] = '/'; /* with '/', add it. */
6322 retpath[retlen] = '\0';
6323 }
6324 else retpath[retlen-1] = '\0';
6325 }
6326 else { /* VMS-style directory spec */
d584a1c6
JM		 6327 char *esa, *esal, *cp;
6328 char *my_esa;
6329 int my_esa_len;
01b8edb6 6330 unsigned long int sts, cmplen, haslower;
a0d0e21e 6331 struct FAB dirfab = cc$rms_fab;
a480973c
JM		 6332 int dirlen;
6333 rms_setup_nam(savnam);
6334 rms_setup_nam(dirnam);
a0d0e21e 6335
b7ae7a0d 6336 /* If we've got an explicit filename, we can just shuffle the string. */
b8ffc8df
RGS		 6337 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6338 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
b7ae7a0d 6339 if ((cp2 = strchr(cp1,'.')) != NULL) {
6340 int ver; char *cp3;
f7ddb74a
JM		 6341 if (vms_process_case_tolerant) {
6342 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6343 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6344 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6345 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6346 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 6347 (ver || *cp3)))))) {
c5375c28 6348 PerlMem_free(trndir);
f7ddb74a
JM		 6349 set_errno(ENOTDIR);
6350 set_vaxc_errno(RMS$_DIR);
6351 return NULL;
6352 }
6353 }
6354 else {
6355 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6356 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6357 !*(cp2+3) || *(cp2+3) != 'R' ||
6358 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6359 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6360 (ver || *cp3)))))) {
c5375c28 6361 PerlMem_free(trndir);
f7ddb74a
JM		 6362 set_errno(ENOTDIR);
6363 set_vaxc_errno(RMS$_DIR);
6364 return NULL;
6365 }
6366 }
b7ae7a0d 6367 }
6368 else { /* No file type, so just draw name into directory part */
6369 for (cp2 = cp1; *cp2; cp2++) ;
6370 }
6371 *cp2 = *cp1;
6372 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
6373 *cp1 = '.';
6374 /* We've now got a VMS 'path'; fall through */
6375 }
a480973c
JM		 6376
6377 dirlen = strlen(trndir);
6378 if (trndir[dirlen-1] == ']' ||
6379 trndir[dirlen-1] == '>' ||
6380 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
748a9306 6381 if (buf) retpath = buf;
f7ddb74a 6382 else if (ts) Newx(retpath,strlen(trndir)+1,char);
748a9306 6383 else retpath = __pathify_retbuf;
b8ffc8df 6384 strcpy(retpath,trndir);
c5375c28 6385 PerlMem_free(trndir);
748a9306 6386 return retpath;
a480973c
JM		 6387 }
6388 rms_set_fna(dirfab, dirnam, trndir, dirlen);
c5375c28
JM		 6389 esa = PerlMem_malloc(VMS_MAXRSS);
6390 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
d584a1c6
JM		 6391 esal = NULL;
6392#if !defined(__VAX) && defined(NAML$C_MAXRSS)
6393 esal = PerlMem_malloc(VMS_MAXRSS);
6394 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
6395#endif
a480973c
JM		 6396 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6397 rms_bind_fab_nam(dirfab, dirnam);
d584a1c6 6398 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
f7ddb74a
JM		 6399#ifdef NAM$M_NO_SHORT_UPCASE
6400 if (decc_efs_case_preserve)
a480973c 6401 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6402#endif
01b8edb6 6403
b8ffc8df 6404 for (cp = trndir; *cp; cp++)
01b8edb6 6405 if (islower(*cp)) { haslower = 1; break; }
6406
a480973c 6407 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
f7ddb74a 6408 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
a480973c
JM		 6409 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6410 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
e518068a 6411 }
6412 if (!sts) {
c5375c28
JM		 6413 PerlMem_free(trndir);
6414 PerlMem_free(esa);
d584a1c6
JM		 6415 if (esal != NULL)
6416 PerlMem_free(esal);
748a9306
LW		 6417 set_errno(EVMSERR);
6418 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 6419 return NULL;
6420 }
a0d0e21e 6421 }
e518068a 6422 else {
6423 savnam = dirnam;
a480973c
JM		 6424 /* Does the file really exist? */
6425 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
e518068a 6426 if (dirfab.fab$l_sts != RMS$_FNF) {
f7ddb74a 6427 int sts1;
a480973c 6428 sts1 = rms_free_search_context(&dirfab);
c5375c28
JM		 6429 PerlMem_free(trndir);
6430 PerlMem_free(esa);
d584a1c6
JM		 6431 if (esal != NULL)
6432 PerlMem_free(esal);
e518068a 6433 set_errno(EVMSERR);
6434 set_vaxc_errno(dirfab.fab$l_sts);
6435 return NULL;
6436 }
6437 dirnam = savnam; /* No; just work with potential name */
6438 }
6439 }
a480973c 6440 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
a0d0e21e 6441 /* Yep; check version while we're at it, if it's there. */
a480973c
JM		 6442 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6443 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
f7ddb74a 6444 int sts2;
a0d0e21e 6445 /* Something other than .DIR[;1]. Bzzt. */
a480973c 6446 sts2 = rms_free_search_context(&dirfab);
c5375c28
JM		 6447 PerlMem_free(trndir);
6448 PerlMem_free(esa);
d584a1c6
JM		 6449 if (esal != NULL)
6450 PerlMem_free(esal);
748a9306
LW		 6451 set_errno(ENOTDIR);
6452 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 6453 return NULL;
6454 }
a0d0e21e 6455 }
d584a1c6
JM		 6456 /* Make sure we are using the right buffer */
6457 if (esal != NULL) {
6458 /* We only need one, clean up the other */
6459 my_esa = esal;
6460 my_esa_len = rms_nam_esll(dirnam);
6461 } else {
6462 my_esa = esa;
6463 my_esa_len = rms_nam_esl(dirnam);
6464 }
6465
6466 /* Null terminate the buffer */
6467 my_esa[my_esa_len] = '\0';
6468
748a9306
LW		 6469 /* OK, the type was fine. Now pull any file name into the
6470 directory path. */
d584a1c6 6471 if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
a0d0e21e 6472 else {
d584a1c6 6473 cp1 = strrchr(my_esa,'>');
a480973c 6474 *(rms_nam_typel(dirnam)) = '>';
a0d0e21e 6475 }
748a9306 6476 *cp1 = '.';
a480973c 6477 *(rms_nam_typel(dirnam) + 1) = '\0';
d584a1c6 6478 retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
a0d0e21e 6479 if (buf) retpath = buf;
a02a5408 6480 else if (ts) Newx(retpath,retlen,char);
a0d0e21e 6481 else retpath = __pathify_retbuf;
d584a1c6 6482 strcpy(retpath,my_esa);
c5375c28 6483 PerlMem_free(esa);
d584a1c6
JM		 6484 if (esal != NULL)
6485 PerlMem_free(esal);
a480973c 6486 sts = rms_free_search_context(&dirfab);
01b8edb6 6487 /* $PARSE may have upcased filespec, so convert output to lower
6488 * case if input contained any lowercase characters. */
f7ddb74a 6489 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
a0d0e21e
LW		 6490 }
6491
c5375c28 6492 PerlMem_free(trndir);
a0d0e21e
LW		 6493 return retpath;
6494} /* end of do_pathify_dirspec() */
6495/*}}}*/
6496/* External entry points */
b8ffc8df 6497char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
360732b5 6498{ return do_pathify_dirspec(dir,buf,0,NULL); }
b8ffc8df 6499char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
360732b5
JM		 6500{ return do_pathify_dirspec(dir,buf,1,NULL); }
6501char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6502{ return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6503char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6504{ return do_pathify_dirspec(dir,buf,1,utf8_fl); }
a0d0e21e 6505
360732b5
JM		 6506/*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6507static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
a0d0e21e 6508{
a480973c 6509 static char __tounixspec_retbuf[VMS_MAXRSS];
2f4077ca 6510 char *dirend, *rslt, *cp1, *cp3, *tmp;
b8ffc8df 6511 const char *cp2;
a480973c 6512 int devlen, dirlen, retlen = VMS_MAXRSS;
0f20d7df 6513 int expand = 1; /* guarantee room for leading and trailing slashes */
2d9f3838 6514 unsigned short int trnlnm_iter_count;
f7ddb74a 6515 int cmp_rslt;
360732b5
JM		 6516 if (utf8_fl != NULL)
6517 *utf8_fl = 0;
a0d0e21e 6518
748a9306 6519 if (spec == NULL) return NULL;
4d743a9b 6520 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
a0d0e21e 6521 if (buf) rslt = buf;
e518068a 6522 else if (ts) {
4d743a9b 6523 Newx(rslt, VMS_MAXRSS, char);
e518068a 6524 }
a0d0e21e 6525 else rslt = __tounixspec_retbuf;
f7ddb74a 6526
2497a41f
JM		 6527 /* New VMS specific format needs translation
6528 * glob passes filenames with trailing '\n' and expects this preserved.
6529 */
6530 if (decc_posix_compliant_pathnames) {
6531 if (strncmp(spec, "\"^UP^", 5) == 0) {
6532 char * uspec;
6533 char *tunix;
6534 int tunix_len;
6535 int nl_flag;
6536
c5375c28
JM		 6537 tunix = PerlMem_malloc(VMS_MAXRSS);
6538 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
2497a41f
JM		 6539 strcpy(tunix, spec);
6540 tunix_len = strlen(tunix);
6541 nl_flag = 0;
6542 if (tunix[tunix_len - 1] == '\n') {
6543 tunix[tunix_len - 1] = '\"';
6544 tunix[tunix_len] = '\0';
6545 tunix_len--;
6546 nl_flag = 1;
6547 }
6548 uspec = decc$translate_vms(tunix);
367e4b85 6549 PerlMem_free(tunix);
2497a41f
JM		 6550 if ((int)uspec > 0) {
6551 strcpy(rslt,uspec);
6552 if (nl_flag) {
6553 strcat(rslt,"\n");
6554 }
6555 else {
6556 /* If we can not translate it, makemaker wants as-is */
6557 strcpy(rslt, spec);
6558 }
6559 return rslt;
6560 }
6561 }
6562 }
6563
f7ddb74a
JM		 6564 cmp_rslt = 0; /* Presume VMS */
6565 cp1 = strchr(spec, '/');
6566 if (cp1 == NULL)
6567 cmp_rslt = 0;
6568
6569 /* Look for EFS ^/ */
6570 if (decc_efs_charset) {
6571 while (cp1 != NULL) {
6572 cp2 = cp1 - 1;
6573 if (*cp2 != '^') {
6574 /* Found illegal VMS, assume UNIX */
6575 cmp_rslt = 1;
6576 break;
6577 }
6578 cp1++;
6579 cp1 = strchr(cp1, '/');
6580 }
6581 }
6582
6583 /* Look for "." and ".." */
6584 if (decc_filename_unix_report) {
6585 if (spec[0] == '.') {
6586 if ((spec[1] == '\0') || (spec[1] == '\n')) {
6587 cmp_rslt = 1;
6588 }
6589 else {
6590 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6591 cmp_rslt = 1;
6592 }
6593 }
6594 }
6595 }
6596 /* This is already UNIX or at least nothing VMS understands */
6597 if (cmp_rslt) {
a0d0e21e
LW		 6598 strcpy(rslt,spec);
6599 return rslt;
6600 }
6601
6602 cp1 = rslt;
6603 cp2 = spec;
6604 dirend = strrchr(spec,']');
6605 if (dirend == NULL) dirend = strrchr(spec,'>');
6606 if (dirend == NULL) dirend = strchr(spec,':');
6607 if (dirend == NULL) {
6608 strcpy(rslt,spec);
6609 return rslt;
6610 }
f7ddb74a
JM		 6611
6612 /* Special case 1 - sys$posix_root = / */
6613#if __CRTL_VER >= 70000000
6614 if (!decc_disable_posix_root) {
6615 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6616 *cp1 = '/';
6617 cp1++;
6618 cp2 = cp2 + 15;
6619 }
6620 }
6621#endif
6622
6623 /* Special case 2 - Convert NLA0: to /dev/null */
6624#if __CRTL_VER < 70000000
6625 cmp_rslt = strncmp(spec,"NLA0:", 5);
6626 if (cmp_rslt != 0)
6627 cmp_rslt = strncmp(spec,"nla0:", 5);
6628#else
6629 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6630#endif
6631 if (cmp_rslt == 0) {
6632 strcpy(rslt, "/dev/null");
6633 cp1 = cp1 + 9;
6634 cp2 = cp2 + 5;
6635 if (spec[6] != '\0') {
6636 cp1[9] == '/';
6637 cp1++;
6638 cp2++;
6639 }
6640 }
6641
6642 /* Also handle special case "SYS$SCRATCH:" */
6643#if __CRTL_VER < 70000000
6644 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6645 if (cmp_rslt != 0)
6646 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6647#else
6648 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6649#endif
c5375c28
JM		 6650 tmp = PerlMem_malloc(VMS_MAXRSS);
6651 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
f7ddb74a
JM		 6652 if (cmp_rslt == 0) {
6653 int islnm;
6654
6655 islnm = my_trnlnm(tmp, "TMP", 0);
6656 if (!islnm) {
6657 strcpy(rslt, "/tmp");
6658 cp1 = cp1 + 4;
6659 cp2 = cp2 + 12;
6660 if (spec[12] != '\0') {
6661 cp1[4] == '/';
6662 cp1++;
6663 cp2++;
6664 }
6665 }
6666 }
6667
a5f75d66 6668 if (*cp2 != '[' && *cp2 != '<') {
a0d0e21e
LW		 6669 *(cp1++) = '/';
6670 }
6671 else { /* the VMS spec begins with directories */
6672 cp2++;
a5f75d66 6673 if (*cp2 == ']' || *cp2 == '>') {
f86702cc 6674 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
367e4b85 6675 PerlMem_free(tmp);
a5f75d66
AD		 6676 return rslt;
6677 }
f7ddb74a 6678 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2f4077ca 6679 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
a0d0e21e 6680 if (ts) Safefree(rslt);
367e4b85 6681 PerlMem_free(tmp);
a0d0e21e
LW		 6682 return NULL;
6683 }
2d9f3838 6684 trnlnm_iter_count = 0;
a0d0e21e
LW		 6685 do {
6686 cp3 = tmp;
6687 while (*cp3 != ':' && *cp3) cp3++;
6688 *(cp3++) = '\0';
6689 if (strchr(cp3,']') != NULL) break;
2d9f3838
CB		 6690 trnlnm_iter_count++;
6691 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
f675dbe5 6692 } while (vmstrnenv(tmp,tmp,0,fildev,0));
f86702cc 6693 if (ts && !buf &&
e518068a 6694 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
e518068a 6695 retlen = devlen + dirlen;
f86702cc 6696 Renew(rslt,retlen+1+2*expand,char);
6697 cp1 = rslt;
6698 }
6699 cp3 = tmp;
6700 *(cp1++) = '/';
6701 while (*cp3) {
6702 *(cp1++) = *(cp3++);
2f4077ca 6703 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
367e4b85 6704 PerlMem_free(tmp);
2f4077ca
JM		 6705 return NULL; /* No room */
6706 }
a0d0e21e 6707 }
f86702cc 6708 *(cp1++) = '/';
6709 }
f7ddb74a
JM		 6710 if ((*cp2 == '^')) {
6711 /* EFS file escape, pass the next character as is */
38a44b82 6712 /* Fix me: HEX encoding for Unicode not implemented */
f7ddb74a
JM		 6713 cp2++;
6714 }
f86702cc 6715 else if ( *cp2 == '.') {
6716 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6717 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6718 cp2 += 3;
6719 }
6720 else cp2++;
a0d0e21e 6721 }
a0d0e21e 6722 }
367e4b85 6723 PerlMem_free(tmp);
a0d0e21e 6724 for (; cp2 <= dirend; cp2++) {
f7ddb74a
JM		 6725 if ((*cp2 == '^')) {
6726 /* EFS file escape, pass the next character as is */
38a44b82 6727 /* Fix me: HEX encoding for Unicode not implemented */
42cd432e
CB		 6728 *(cp1++) = *(++cp2);
6729 /* An escaped dot stays as is -- don't convert to slash */
6730 if (*cp2 == '.') cp2++;
f7ddb74a 6731 }
a0d0e21e
LW		 6732 if (*cp2 == ':') {
6733 *(cp1++) = '/';
6734 if (*(cp2+1) == '[') cp2++;
6735 }
f86702cc 6736 else if (*cp2 == ']' || *cp2 == '>') {
6737 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6738 }
f7ddb74a 6739 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
a0d0e21e 6740 *(cp1++) = '/';
e518068a 6741 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6742 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6743 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6744 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6745 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6746 }
f86702cc 6747 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6748 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6749 cp2 += 2;
6750 }
a0d0e21e
LW		 6751 }
6752 else if (*cp2 == '-') {
6753 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6754 while (*cp2 == '-') {
6755 cp2++;
6756 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6757 }
6758 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6759 if (ts) Safefree(rslt); /* filespecs like */
01b8edb6 6760 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
a0d0e21e
LW		 6761 return NULL;
6762 }
a0d0e21e
LW		 6763 }
6764 else *(cp1++) = *cp2;
6765 }
6766 else *(cp1++) = *cp2;
6767 }
42cd432e
CB		 6768 while (*cp2) {
6769 if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */
6770 *(cp1++) = *(cp2++);
6771 }
a0d0e21e
LW		 6772 *cp1 = '\0';
6773
f7ddb74a
JM		 6774 /* This still leaves /000000/ when working with a
6775 * VMS device root or concealed root.
6776 */
6777 {
6778 int ulen;
6779 char * zeros;
6780
6781 ulen = strlen(rslt);
6782
6783 /* Get rid of "000000/ in rooted filespecs */
6784 if (ulen > 7) {
6785 zeros = strstr(rslt, "/000000/");
6786 if (zeros != NULL) {
6787 int mlen;
6788 mlen = ulen - (zeros - rslt) - 7;
6789 memmove(zeros, &zeros[7], mlen);
6790 ulen = ulen - 7;
6791 rslt[ulen] = '\0';
6792 }
6793 }
6794 }
6795
a0d0e21e
LW		 6796 return rslt;
6797
6798} /* end of do_tounixspec() */
6799/*}}}*/
6800/* External entry points */
360732b5
JM		 6801char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6802 { return do_tounixspec(spec,buf,0, NULL); }
6803char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6804 { return do_tounixspec(spec,buf,1, NULL); }
6805char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6806 { return do_tounixspec(spec,buf,0, utf8_fl); }
6807char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6808 { return do_tounixspec(spec,buf,1, utf8_fl); }
a0d0e21e 6809
360732b5 6810#if __CRTL_VER >= 70200000 && !defined(__VAX)
2497a41f 6811
360732b5
JM		 6812/*
6813 This procedure is used to identify if a path is based in either
6814 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6815 it returns the OpenVMS format directory for it.
6816
6817 It is expecting specifications of only '/' or '/xxxx/'
6818
6819 If a posix root does not exist, or 'xxxx' is not a directory
6820 in the posix root, it returns a failure.
6821
6822 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6823
6824 It is used only internally by posix_to_vmsspec_hardway().
6825 */
6826
6827static int posix_root_to_vms
6828 (char *vmspath, int vmspath_len,
6829 const char *unixpath,
d584a1c6
JM		 6830 const int * utf8_fl)
6831{
2497a41f
JM		 6832int sts;
6833struct FAB myfab = cc$rms_fab;
d584a1c6 6834rms_setup_nam(mynam);
2497a41f 6835struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
d584a1c6
JM		 6836struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6837char * esa, * esal, * rsa, * rsal;
2497a41f
JM		 6838char *vms_delim;
6839int dir_flag;
6840int unixlen;
6841
360732b5 6842 dir_flag = 0;
d584a1c6 6843 vmspath[0] = '\0';
360732b5
JM		 6844 unixlen = strlen(unixpath);
6845 if (unixlen == 0) {
360732b5
JM		 6846 return RMS$_FNF;
6847 }
6848
6849#if __CRTL_VER >= 80200000
2497a41f 6850 /* If not a posix spec already, convert it */
360732b5
JM		 6851 if (decc_posix_compliant_pathnames) {
6852 if (strncmp(unixpath,"\"^UP^",5) != 0) {
6853 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6854 }
6855 else {
6856 /* This is already a VMS specification, no conversion */
6857 unixlen--;
6858 strncpy(vmspath,unixpath, vmspath_len);
6859 }
2497a41f 6860 }
360732b5
JM		 6861 else
6862#endif
6863 {
6864 int path_len;
6865 int i,j;
6866
6867 /* Check to see if this is under the POSIX root */
6868 if (decc_disable_posix_root) {
6869 return RMS$_FNF;
6870 }
6871
6872 /* Skip leading / */
6873 if (unixpath[0] == '/') {
6874 unixpath++;
6875 unixlen--;
6876 }
6877
6878
6879 strcpy(vmspath,"SYS$POSIX_ROOT:");
6880
6881 /* If this is only the / , or blank, then... */
6882 if (unixpath[0] == '\0') {
6883 /* by definition, this is the answer */
6884 return SS$_NORMAL;
6885 }
6886
6887 /* Need to look up a directory */
6888 vmspath[15] = '[';
6889 vmspath[16] = '\0';
6890
6891 /* Copy and add '^' escape characters as needed */
6892 j = 16;
6893 i = 0;
6894 while (unixpath[i] != 0) {
6895 int k;
6896
6897 j += copy_expand_unix_filename_escape
6898 (&vmspath[j], &unixpath[i], &k, utf8_fl);
6899 i += k;
6900 }
6901
6902 path_len = strlen(vmspath);
6903 if (vmspath[path_len - 1] == '/')
6904 path_len--;
6905 vmspath[path_len] = ']';
6906 path_len++;
6907 vmspath[path_len] = '\0';
6908
2497a41f
JM		 6909 }
6910 vmspath[vmspath_len] = 0;
6911 if (unixpath[unixlen - 1] == '/')
6912 dir_flag = 1;
d584a1c6
JM		 6913 esal = PerlMem_malloc(VMS_MAXRSS);
6914 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6915 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
c5375c28 6916 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 6917 rsal = PerlMem_malloc(VMS_MAXRSS);
6918 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6919 rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6920 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6921 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
6922 rms_bind_fab_nam(myfab, mynam);
6923 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
6924 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
2497a41f
JM		 6925 if (decc_efs_case_preserve)
6926 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
ea0c9945 6927#ifdef NAML$M_OPEN_SPECIAL
2497a41f 6928 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
ea0c9945 6929#endif
2497a41f
JM		 6930
6931 /* Set up the remaining naml fields */
6932 sts = sys$parse(&myfab);
6933
6934 /* It failed! Try again as a UNIX filespec */
6935 if (!(sts & 1)) {
d584a1c6 6936 PerlMem_free(esal);
367e4b85 6937 PerlMem_free(esa);
d584a1c6
JM		 6938 PerlMem_free(rsal);
6939 PerlMem_free(rsa);
2497a41f
JM		 6940 return sts;
6941 }
6942
6943 /* get the Device ID and the FID */
6944 sts = sys$search(&myfab);
d584a1c6
JM		 6945
6946 /* These are no longer needed */
6947 PerlMem_free(esa);
6948 PerlMem_free(rsal);
6949 PerlMem_free(rsa);
6950
2497a41f
JM		 6951 /* on any failure, returned the POSIX ^UP^ filespec */
6952 if (!(sts & 1)) {
d584a1c6 6953 PerlMem_free(esal);
2497a41f
JM		 6954 return sts;
6955 }
6956 specdsc.dsc$a_pointer = vmspath;
6957 specdsc.dsc$w_length = vmspath_len;
6958
6959 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6960 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6961 sts = lib$fid_to_name
6962 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6963
6964 /* on any failure, returned the POSIX ^UP^ filespec */
6965 if (!(sts & 1)) {
6966 /* This can happen if user does not have permission to read directories */
6967 if (strncmp(unixpath,"\"^UP^",5) != 0)
6968 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6969 else
6970 strcpy(vmspath, unixpath);
6971 }
6972 else {
6973 vmspath[specdsc.dsc$w_length] = 0;
6974
6975 /* Are we expecting a directory? */
6976 if (dir_flag != 0) {
6977 int i;
6978 char *eptr;
6979
6980 eptr = NULL;
6981
6982 i = specdsc.dsc$w_length - 1;
6983 while (i > 0) {
6984 int zercnt;
6985 zercnt = 0;
6986 /* Version must be '1' */
6987 if (vmspath[i--] != '1')
6988 break;
6989 /* Version delimiter is one of ".;" */
6990 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6991 break;
6992 i--;
6993 if (vmspath[i--] != 'R')
6994 break;
6995 if (vmspath[i--] != 'I')
6996 break;
6997 if (vmspath[i--] != 'D')
6998 break;
6999 if (vmspath[i--] != '.')
7000 break;
7001 eptr = &vmspath[i+1];
7002 while (i > 0) {
7003 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7004 if (vmspath[i-1] != '^') {
7005 if (zercnt != 6) {
7006 *eptr = vmspath[i];
7007 eptr[1] = '\0';
7008 vmspath[i] = '.';
7009 break;
7010 }
7011 else {
7012 /* Get rid of 6 imaginary zero directory filename */
7013 vmspath[i+1] = '\0';
7014 }
7015 }
7016 }
7017 if (vmspath[i] == '0')
7018 zercnt++;
7019 else
7020 zercnt = 10;
7021 i--;
7022 }
7023 break;
7024 }
7025 }
7026 }
d584a1c6 7027 PerlMem_free(esal);
2497a41f
JM		 7028 return sts;
7029}
7030
360732b5
JM		 7031/* /dev/mumble needs to be handled special.
7032 /dev/null becomes NLA0:, And there is the potential for other stuff
7033 like /dev/tty which may need to be mapped to something.
7034*/
7035
7036static int
7037slash_dev_special_to_vms
7038 (const char * unixptr,
7039 char * vmspath,
7040 int vmspath_len)
7041{
7042char * nextslash;
7043int len;
7044int cmp;
7045int islnm;
7046
7047 unixptr += 4;
7048 nextslash = strchr(unixptr, '/');
7049 len = strlen(unixptr);
7050 if (nextslash != NULL)
7051 len = nextslash - unixptr;
7052 cmp = strncmp("null", unixptr, 5);
7053 if (cmp == 0) {
7054 if (vmspath_len >= 6) {
7055 strcpy(vmspath, "_NLA0:");
7056 return SS$_NORMAL;
7057 }
7058 }
7059}
7060
7061
7062/* The built in routines do not understand perl's special needs, so
7063 doing a manual conversion from UNIX to VMS
7064
7065 If the utf8_fl is not null and points to a non-zero value, then
7066 treat 8 bit characters as UTF-8.
7067
7068 The sequence starting with '$(' and ending with ')' will be passed
7069 through with out interpretation instead of being escaped.
7070
7071 */
2497a41f 7072static int posix_to_vmsspec_hardway
360732b5
JM		 7073 (char *vmspath, int vmspath_len,
7074 const char *unixpath,
7075 int dir_flag,
7076 int * utf8_fl) {
2497a41f
JM		 7077
7078char *esa;
7079const char *unixptr;
360732b5 7080const char *unixend;
2497a41f
JM		 7081char *vmsptr;
7082const char *lastslash;
7083const char *lastdot;
7084int unixlen;
7085int vmslen;
7086int dir_start;
7087int dir_dot;
7088int quoted;
360732b5
JM		 7089char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7090int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
2497a41f 7091
360732b5
JM		 7092 if (utf8_fl != NULL)
7093 *utf8_fl = 0;
2497a41f
JM		 7094
7095 unixptr = unixpath;
7096 dir_dot = 0;
7097
7098 /* Ignore leading "/" characters */
7099 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7100 unixptr++;
7101 }
7102 unixlen = strlen(unixptr);
7103
7104 /* Do nothing with blank paths */
7105 if (unixlen == 0) {
7106 vmspath[0] = '\0';
7107 return SS$_NORMAL;
7108 }
7109
360732b5
JM		 7110 quoted = 0;
7111 /* This could have a "^UP^ on the front */
7112 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7113 quoted = 1;
7114 unixptr+= 5;
7115 unixlen-= 5;
7116 }
7117
2497a41f
JM		 7118 lastslash = strrchr(unixptr,'/');
7119 lastdot = strrchr(unixptr,'.');
360732b5
JM		 7120 unixend = strrchr(unixptr,'\"');
7121 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7122 unixend = unixptr + unixlen;
7123 }
2497a41f
JM		 7124
7125 /* last dot is last dot or past end of string */
7126 if (lastdot == NULL)
7127 lastdot = unixptr + unixlen;
7128
7129 /* if no directories, set last slash to beginning of string */
7130 if (lastslash == NULL) {
7131 lastslash = unixptr;
7132 }
7133 else {
7134 /* Watch out for trailing "." after last slash, still a directory */
7135 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7136 lastslash = unixptr + unixlen;
7137 }
7138
7139 /* Watch out for traiing ".." after last slash, still a directory */
7140 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7141 lastslash = unixptr + unixlen;
7142 }
7143
7144 /* dots in directories are aways escaped */
7145 if (lastdot < lastslash)
7146 lastdot = unixptr + unixlen;
7147 }
7148
7149 /* if (unixptr < lastslash) then we are in a directory */
7150
7151 dir_start = 0;
2497a41f
JM		 7152
7153 vmsptr = vmspath;
7154 vmslen = 0;
7155
2497a41f
JM		 7156 /* Start with the UNIX path */
7157 if (*unixptr != '/') {
7158 /* relative paths */
360732b5
JM		 7159
7160 /* If allowing logical names on relative pathnames, then handle here */
7161 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7162 !decc_posix_compliant_pathnames) {
7163 char * nextslash;
7164 int seg_len;
7165 char * trn;
7166 int islnm;
7167
7168 /* Find the next slash */
7169 nextslash = strchr(unixptr,'/');
7170
7171 esa = PerlMem_malloc(vmspath_len);
7172 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7173
7174 trn = PerlMem_malloc(VMS_MAXRSS);
7175 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7176
7177 if (nextslash != NULL) {
7178
7179 seg_len = nextslash - unixptr;
7180 strncpy(esa, unixptr, seg_len);
7181 esa[seg_len] = 0;
7182 }
7183 else {
7184 strcpy(esa, unixptr);
7185 seg_len = strlen(unixptr);
7186 }
7187 /* trnlnm(section) */
7188 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7189
7190 if (islnm) {
7191 /* Now fix up the directory */
7192
7193 /* Split up the path to find the components */
7194 sts = vms_split_path
7195 (trn,
7196 &v_spec,
7197 &v_len,
7198 &r_spec,
7199 &r_len,
7200 &d_spec,
7201 &d_len,
7202 &n_spec,
7203 &n_len,
7204 &e_spec,
7205 &e_len,
7206 &vs_spec,
7207 &vs_len);
7208
7209 while (sts == 0) {
7210 char * strt;
7211 int cmp;
7212
7213 /* A logical name must be a directory or the full
7214 specification. It is only a full specification if
7215 it is the only component */
7216 if ((unixptr[seg_len] == '\0') ||
7217 (unixptr[seg_len+1] == '\0')) {
7218
7219 /* Is a directory being required? */
7220 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7221 /* Not a logical name */
7222 break;
7223 }
7224
7225
7226 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7227 /* This must be a directory */
7228 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7229 strcpy(vmsptr, esa);
7230 vmslen=strlen(vmsptr);
7231 vmsptr[vmslen] = ':';
7232 vmslen++;
7233 vmsptr[vmslen] = '\0';
7234 return SS$_NORMAL;
7235 }
7236 }
7237
7238 }
7239
7240
7241 /* must be dev/directory - ignore version */
7242 if ((n_len + e_len) != 0)
7243 break;
7244
7245 /* transfer the volume */
7246 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7247 strncpy(vmsptr, v_spec, v_len);
7248 vmsptr += v_len;
7249 vmsptr[0] = '\0';
7250 vmslen += v_len;
7251 }
7252
7253 /* unroot the rooted directory */
7254 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7255 r_spec[0] = '[';
7256 r_spec[r_len - 1] = ']';
7257
7258 /* This should not be there, but nothing is perfect */
7259 if (r_len > 9) {
7260 cmp = strcmp(&r_spec[1], "000000.");
7261 if (cmp == 0) {
7262 r_spec += 7;
7263 r_spec[7] = '[';
7264 r_len -= 7;
7265 if (r_len == 2)
7266 r_len = 0;
7267 }
7268 }
7269 if (r_len > 0) {
7270 strncpy(vmsptr, r_spec, r_len);
7271 vmsptr += r_len;
7272 vmslen += r_len;
7273 vmsptr[0] = '\0';
7274 }
7275 }
7276 /* Bring over the directory. */
7277 if ((d_len > 0) &&
7278 ((d_len + vmslen) < vmspath_len)) {
7279 d_spec[0] = '[';
7280 d_spec[d_len - 1] = ']';
7281 if (d_len > 9) {
7282 cmp = strcmp(&d_spec[1], "000000.");
7283 if (cmp == 0) {
7284 d_spec += 7;
7285 d_spec[7] = '[';
7286 d_len -= 7;
7287 if (d_len == 2)
7288 d_len = 0;
7289 }
7290 }
7291
7292 if (r_len > 0) {
7293 /* Remove the redundant root */
7294 if (r_len > 0) {
7295 /* remove the ][ */
7296 vmsptr--;
7297 vmslen--;
7298 d_spec++;
7299 d_len--;
7300 }
7301 strncpy(vmsptr, d_spec, d_len);
7302 vmsptr += d_len;
7303 vmslen += d_len;
7304 vmsptr[0] = '\0';
7305 }
7306 }
7307 break;
7308 }
7309 }
7310
7311 PerlMem_free(esa);
7312 PerlMem_free(trn);
7313 }
7314
2497a41f
JM		 7315 if (lastslash > unixptr) {
7316 int dotdir_seen;
7317
7318 /* skip leading ./ */
7319 dotdir_seen = 0;
7320 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7321 dotdir_seen = 1;
7322 unixptr++;
7323 unixptr++;
7324 }
7325
7326 /* Are we still in a directory? */
7327 if (unixptr <= lastslash) {
7328 *vmsptr++ = '[';
7329 vmslen = 1;
7330 dir_start = 1;
7331
7332 /* if not backing up, then it is relative forward. */
7333 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
360732b5 7334 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
2497a41f
JM		 7335 *vmsptr++ = '.';
7336 vmslen++;
7337 dir_dot = 1;
360732b5 7338 }
2497a41f
JM		 7339 }
7340 else {
7341 if (dotdir_seen) {
7342 /* Perl wants an empty directory here to tell the difference
7343 * between a DCL commmand and a filename
7344 */
7345 *vmsptr++ = '[';
7346 *vmsptr++ = ']';
7347 vmslen = 2;
7348 }
7349 }
7350 }
7351 else {
7352 /* Handle two special files . and .. */
7353 if (unixptr[0] == '.') {
360732b5 7354 if (&unixptr[1] == unixend) {
2497a41f
JM		 7355 *vmsptr++ = '[';
7356 *vmsptr++ = ']';
7357 vmslen += 2;
7358 *vmsptr++ = '\0';
7359 return SS$_NORMAL;
7360 }
360732b5 7361 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
2497a41f
JM		 7362 *vmsptr++ = '[';
7363 *vmsptr++ = '-';
7364 *vmsptr++ = ']';
7365 vmslen += 3;
7366 *vmsptr++ = '\0';
7367 return SS$_NORMAL;
7368 }
7369 }
7370 }
7371 }
7372 else { /* Absolute PATH handling */
7373 int sts;
7374 char * nextslash;
7375 int seg_len;
7376 /* Need to find out where root is */
7377
7378 /* In theory, this procedure should never get an absolute POSIX pathname
7379 * that can not be found on the POSIX root.
7380 * In practice, that can not be relied on, and things will show up
7381 * here that are a VMS device name or concealed logical name instead.
7382 * So to make things work, this procedure must be tolerant.
7383 */
c5375c28
JM		 7384 esa = PerlMem_malloc(vmspath_len);
7385 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2497a41f
JM		 7386
7387 sts = SS$_NORMAL;
7388 nextslash = strchr(&unixptr[1],'/');
7389 seg_len = 0;
7390 if (nextslash != NULL) {
360732b5 7391 int cmp;
2497a41f
JM		 7392 seg_len = nextslash - &unixptr[1];
7393 strncpy(vmspath, unixptr, seg_len + 1);
7394 vmspath[seg_len+1] = 0;
360732b5
JM		 7395 cmp = 1;
7396 if (seg_len == 3) {
7397 cmp = strncmp(vmspath, "dev", 4);
7398 if (cmp == 0) {
7399 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7400 if (sts = SS$_NORMAL)
7401 return SS$_NORMAL;
7402 }
7403 }
7404 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
2497a41f
JM		 7405 }
7406
360732b5 7407 if ($VMS_STATUS_SUCCESS(sts)) {
2497a41f
JM		 7408 /* This is verified to be a real path */
7409
360732b5
JM		 7410 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7411 if ($VMS_STATUS_SUCCESS(sts)) {
7412 strcpy(vmspath, esa);
7413 vmslen = strlen(vmspath);
7414 vmsptr = vmspath + vmslen;
7415 unixptr++;
7416 if (unixptr < lastslash) {
7417 char * rptr;
7418 vmsptr--;
7419 *vmsptr++ = '.';
7420 dir_start = 1;
7421 dir_dot = 1;
7422 if (vmslen > 7) {
7423 int cmp;
7424 rptr = vmsptr - 7;
7425 cmp = strcmp(rptr,"000000.");
7426 if (cmp == 0) {
7427 vmslen -= 7;
7428 vmsptr -= 7;
7429 vmsptr[1] = '\0';
7430 } /* removing 6 zeros */
7431 } /* vmslen < 7, no 6 zeros possible */
7432 } /* Not in a directory */
7433 } /* Posix root found */
7434 else {
7435 /* No posix root, fall back to default directory */
7436 strcpy(vmspath, "SYS$DISK:[");
7437 vmsptr = &vmspath[10];
7438 vmslen = 10;
7439 if (unixptr > lastslash) {
7440 *vmsptr = ']';
7441 vmsptr++;
7442 vmslen++;
7443 }
7444 else {
7445 dir_start = 1;
7446 }
7447 }
2497a41f
JM		 7448 } /* end of verified real path handling */
7449 else {
7450 int add_6zero;
7451 int islnm;
7452
7453 /* Ok, we have a device or a concealed root that is not in POSIX
7454 * or we have garbage. Make the best of it.
7455 */
7456
7457 /* Posix to VMS destroyed this, so copy it again */
7458 strncpy(vmspath, &unixptr[1], seg_len);
7459 vmspath[seg_len] = 0;
7460 vmslen = seg_len;
7461 vmsptr = &vmsptr[vmslen];
7462 islnm = 0;
7463
7464 /* Now do we need to add the fake 6 zero directory to it? */
7465 add_6zero = 1;
7466 if ((*lastslash == '/') && (nextslash < lastslash)) {
7467 /* No there is another directory */
7468 add_6zero = 0;
7469 }
7470 else {
7471 int trnend;
360732b5 7472 int cmp;
2497a41f
JM		 7473
7474 /* now we have foo:bar or foo:[000000]bar to decide from */
7ded3206 7475 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
360732b5
JM		 7476
7477 if (!islnm && !decc_posix_compliant_pathnames) {
7478
7479 cmp = strncmp("bin", vmspath, 4);
7480 if (cmp == 0) {
7481 /* bin => SYS$SYSTEM: */
7482 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7483 }
7484 else {
7485 /* tmp => SYS$SCRATCH: */
7486 cmp = strncmp("tmp", vmspath, 4);
7487 if (cmp == 0) {
7488 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7489 }
7490 }
7491 }
7492
7ded3206 7493 trnend = islnm ? islnm - 1 : 0;
2497a41f
JM		 7494
7495 /* if this was a logical name, ']' or '>' must be present */
7496 /* if not a logical name, then assume a device and hope. */
7497 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7498
7499 /* if log name and trailing '.' then rooted - treat as device */
7500 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7501
7502 /* Fix me, if not a logical name, a device lookup should be
7503 * done to see if the device is file structured. If the device
7504 * is not file structured, the 6 zeros should not be put on.
7505 *
7506 * As it is, perl is occasionally looking for dev:[000000]tty.
7507 * which looks a little strange.
360732b5
JM		 7508 *
7509 * Not that easy to detect as "/dev" may be file structured with
7510 * special device files.
2497a41f
JM		 7511 */
7512
360732b5
JM		 7513 if ((add_6zero == 0) && (*nextslash == '/') &&
7514 (&nextslash[1] == unixend)) {
2497a41f
JM		 7515 /* No real directory present */
7516 add_6zero = 1;
7517 }
7518 }
7519
7520 /* Put the device delimiter on */
7521 *vmsptr++ = ':';
7522 vmslen++;
7523 unixptr = nextslash;
7524 unixptr++;
7525
7526 /* Start directory if needed */
7527 if (!islnm || add_6zero) {
7528 *vmsptr++ = '[';
7529 vmslen++;
7530 dir_start = 1;
7531 }
7532
7533 /* add fake 000000] if needed */
7534 if (add_6zero) {
7535 *vmsptr++ = '0';
7536 *vmsptr++ = '0';
7537 *vmsptr++ = '0';
7538 *vmsptr++ = '0';
7539 *vmsptr++ = '0';
7540 *vmsptr++ = '0';
7541 *vmsptr++ = ']';
7542 vmslen += 7;
7543 dir_start = 0;
7544 }
7545
7546 } /* non-POSIX translation */
367e4b85 7547 PerlMem_free(esa);
2497a41f
JM		 7548 } /* End of relative/absolute path handling */
7549
360732b5 7550 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
2497a41f 7551 int dash_flag;
360732b5
JM		 7552 int in_cnt;
7553 int out_cnt;
2497a41f
JM		 7554
7555 dash_flag = 0;
7556
7557 if (dir_start != 0) {
7558
7559 /* First characters in a directory are handled special */
7560 while ((*unixptr == '/') ||
7561 ((*unixptr == '.') &&
360732b5
JM		 7562 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7563 (&unixptr[1]==unixend)))) {
2497a41f
JM		 7564 int loop_flag;
7565
7566 loop_flag = 0;
7567
7568 /* Skip redundant / in specification */
7569 while ((*unixptr == '/') && (dir_start != 0)) {
7570 loop_flag = 1;
7571 unixptr++;
7572 if (unixptr == lastslash)
7573 break;
7574 }
7575 if (unixptr == lastslash)
7576 break;
7577
7578 /* Skip redundant ./ characters */
7579 while ((*unixptr == '.') &&
360732b5 7580 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
2497a41f
JM		 7581 loop_flag = 1;
7582 unixptr++;
7583 if (unixptr == lastslash)
7584 break;
7585 if (*unixptr == '/')
7586 unixptr++;
7587 }
7588 if (unixptr == lastslash)
7589 break;
7590
7591 /* Skip redundant ../ characters */
7592 while ((*unixptr == '.') && (unixptr[1] == '.') &&
360732b5 7593 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
2497a41f
JM		 7594 /* Set the backing up flag */
7595 loop_flag = 1;
7596 dir_dot = 0;
7597 dash_flag = 1;
7598 *vmsptr++ = '-';
7599 vmslen++;
7600 unixptr++; /* first . */
7601 unixptr++; /* second . */
7602 if (unixptr == lastslash)
7603 break;
7604 if (*unixptr == '/') /* The slash */
7605 unixptr++;
7606 }
7607 if (unixptr == lastslash)
7608 break;
7609
7610 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7611 /* Not needed when VMS is pretending to be UNIX. */
7612
7613 /* Is this loop stuck because of too many dots? */
7614 if (loop_flag == 0) {
7615 /* Exit the loop and pass the rest through */
7616 break;
7617 }
7618 }
7619
7620 /* Are we done with directories yet? */
7621 if (unixptr >= lastslash) {
7622
7623 /* Watch out for trailing dots */
7624 if (dir_dot != 0) {
7625 vmslen --;
7626 vmsptr--;
7627 }
7628 *vmsptr++ = ']';
7629 vmslen++;
7630 dash_flag = 0;
7631 dir_start = 0;
7632 if (*unixptr == '/')
7633 unixptr++;
7634 }
7635 else {
7636 /* Have we stopped backing up? */
7637 if (dash_flag) {
7638 *vmsptr++ = '.';
7639 vmslen++;
7640 dash_flag = 0;
7641 /* dir_start continues to be = 1 */
7642 }
7643 if (*unixptr == '-') {
7644 *vmsptr++ = '^';
7645 *vmsptr++ = *unixptr++;
7646 vmslen += 2;
7647 dir_start = 0;
7648
7649 /* Now are we done with directories yet? */
7650 if (unixptr >= lastslash) {
7651
7652 /* Watch out for trailing dots */
7653 if (dir_dot != 0) {
7654 vmslen --;
7655 vmsptr--;
7656 }
7657
7658 *vmsptr++ = ']';
7659 vmslen++;
7660 dash_flag = 0;
7661 dir_start = 0;
7662 }
7663 }
7664 }
7665 }
7666
7667 /* All done? */
360732b5 7668 if (unixptr >= unixend)
2497a41f
JM		 7669 break;
7670
7671 /* Normal characters - More EFS work probably needed */
7672 dir_start = 0;
7673 dir_dot = 0;
7674
7675 switch(*unixptr) {
7676 case '/':
7677 /* remove multiple / */
7678 while (unixptr[1] == '/') {
7679 unixptr++;
7680 }
7681 if (unixptr == lastslash) {
7682 /* Watch out for trailing dots */
7683 if (dir_dot != 0) {
7684 vmslen --;
7685 vmsptr--;
7686 }
7687 *vmsptr++ = ']';
7688 }
7689 else {
7690 dir_start = 1;
7691 *vmsptr++ = '.';
7692 dir_dot = 1;
7693
7694 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7695 /* Not needed when VMS is pretending to be UNIX. */
7696
7697 }
7698 dash_flag = 0;
360732b5 7699 if (unixptr != unixend)
2497a41f
JM		 7700 unixptr++;
7701 vmslen++;
7702 break;
2497a41f 7703 case '.':
360732b5
JM		 7704 if ((unixptr < lastdot) || (unixptr < lastslash) ||
7705 (&unixptr[1] == unixend)) {
2497a41f
JM		 7706 *vmsptr++ = '^';
7707 *vmsptr++ = '.';
7708 vmslen += 2;
7709 unixptr++;
7710
7711 /* trailing dot ==> '^..' on VMS */
360732b5 7712 if (unixptr == unixend) {
2497a41f
JM		 7713 *vmsptr++ = '.';
7714 vmslen++;
360732b5 7715 unixptr++;
2497a41f 7716 }
2497a41f
JM		 7717 break;
7718 }
360732b5 7719
2497a41f 7720 *vmsptr++ = *unixptr++;
360732b5
JM		 7721 vmslen ++;
7722 break;
7723 case '"':
7724 if (quoted && (&unixptr[1] == unixend)) {
7725 unixptr++;
7726 break;
7727 }
7728 in_cnt = copy_expand_unix_filename_escape
7729 (vmsptr, unixptr, &out_cnt, utf8_fl);
7730 vmsptr += out_cnt;
7731 unixptr += in_cnt;
2497a41f
JM		 7732 break;
7733 case '~':
7734 case ';':
7735 case '\\':
360732b5
JM		 7736 case '?':
7737 case ' ':
2497a41f 7738 default:
360732b5
JM		 7739 in_cnt = copy_expand_unix_filename_escape
7740 (vmsptr, unixptr, &out_cnt, utf8_fl);
7741 vmsptr += out_cnt;
7742 unixptr += in_cnt;
2497a41f
JM		 7743 break;
7744 }
7745 }
7746
7747 /* Make sure directory is closed */
7748 if (unixptr == lastslash) {
7749 char *vmsptr2;
7750 vmsptr2 = vmsptr - 1;
7751
7752 if (*vmsptr2 != ']') {
7753 *vmsptr2--;
7754
7755 /* directories do not end in a dot bracket */
7756 if (*vmsptr2 == '.') {
7757 vmsptr2--;
7758
7759 /* ^. is allowed */
7760 if (*vmsptr2 != '^') {
7761 vmsptr--; /* back up over the dot */
7762 }
7763 }
7764 *vmsptr++ = ']';
7765 }
7766 }
7767 else {
7768 char *vmsptr2;
7769 /* Add a trailing dot if a file with no extension */
7770 vmsptr2 = vmsptr - 1;
360732b5
JM		 7771 if ((vmslen > 1) &&
7772 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7773 (*vmsptr2 != ')') && (*lastdot != '.')) {
2497a41f
JM		 7774 *vmsptr++ = '.';
7775 vmslen++;
7776 }
7777 }
7778
7779 *vmsptr = '\0';
7780 return SS$_NORMAL;
7781}
7782#endif
7783
360732b5
JM		 7784 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7785static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7786{
7787char * result;
7788int utf8_flag;
7789
7790 /* If a UTF8 flag is being passed, honor it */
7791 utf8_flag = 0;
7792 if (utf8_fl != NULL) {
7793 utf8_flag = *utf8_fl;
7794 *utf8_fl = 0;
7795 }
7796
7797 if (utf8_flag) {
7798 /* If there is a possibility of UTF8, then if any UTF8 characters
7799 are present, then they must be converted to VTF-7
7800 */
7801 result = strcpy(rslt, path); /* FIX-ME */
7802 }
7803 else
7804 result = strcpy(rslt, path);
7805
7806 return result;
7807}
7808
7809
7810/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7811static char *mp_do_tovmsspec
7812 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
a480973c 7813 static char __tovmsspec_retbuf[VMS_MAXRSS];
e518068a 7814 char *rslt, *dirend;
f7ddb74a
JM		 7815 char *lastdot;
7816 char *vms_delim;
b8ffc8df
RGS		 7817 register char *cp1;
7818 const char *cp2;
e518068a 7819 unsigned long int infront = 0, hasdir = 1;
f7ddb74a
JM		 7820 int rslt_len;
7821 int no_type_seen;
360732b5
JM		 7822 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7823 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e 7824
748a9306 7825 if (path == NULL) return NULL;
4d743a9b 7826 rslt_len = VMS_MAXRSS-1;
a0d0e21e 7827 if (buf) rslt = buf;
a480973c 7828 else if (ts) Newx(rslt, VMS_MAXRSS, char);
a0d0e21e 7829 else rslt = __tovmsspec_retbuf;
360732b5
JM		 7830
7831 /* '.' and '..' are "[]" and "[-]" for a quick check */
7832 if (path[0] == '.') {
7833 if (path[1] == '\0') {
7834 strcpy(rslt,"[]");
7835 if (utf8_flag != NULL)
7836 *utf8_flag = 0;
7837 return rslt;
7838 }
7839 else {
7840 if (path[1] == '.' && path[2] == '\0') {
7841 strcpy(rslt,"[-]");
7842 if (utf8_flag != NULL)
7843 *utf8_flag = 0;
7844 return rslt;
7845 }
7846 }
a0d0e21e 7847 }
f7ddb74a 7848
2497a41f
JM		 7849 /* Posix specifications are now a native VMS format */
7850 /*--------------------------------------------------*/
7851#if __CRTL_VER >= 80200000 && !defined(__VAX)
7852 if (decc_posix_compliant_pathnames) {
7853 if (strncmp(path,"\"^UP^",5) == 0) {
360732b5 7854 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
2497a41f
JM		 7855 return rslt;
7856 }
7857 }
7858#endif
7859
360732b5
JM		 7860 /* This is really the only way to see if this is already in VMS format */
7861 sts = vms_split_path
7862 (path,
7863 &v_spec,
7864 &v_len,
7865 &r_spec,
7866 &r_len,
7867 &d_spec,
7868 &d_len,
7869 &n_spec,
7870 &n_len,
7871 &e_spec,
7872 &e_len,
7873 &vs_spec,
7874 &vs_len);
7875 if (sts == 0) {
7876 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7877 replacement, because the above parse just took care of most of
7878 what is needed to do vmspath when the specification is already
7879 in VMS format.
7880
7881 And if it is not already, it is easier to do the conversion as
7882 part of this routine than to call this routine and then work on
7883 the result.
7884 */
2497a41f 7885
360732b5
JM		 7886 /* If VMS punctuation was found, it is already VMS format */
7887 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7888 if (utf8_flag != NULL)
7889 *utf8_flag = 0;
7890 strcpy(rslt, path);
7891 return rslt;
7892 }
7893 /* Now, what to do with trailing "." cases where there is no
7894 extension? If this is a UNIX specification, and EFS characters
7895 are enabled, then the trailing "." should be converted to a "^.".
7896 But if this was already a VMS specification, then it should be
7897 left alone.
2497a41f 7898
360732b5
JM		 7899 So in the case of ambiguity, leave the specification alone.
7900 */
2497a41f 7901
2497a41f 7902
360732b5
JM		 7903 /* If there is a possibility of UTF8, then if any UTF8 characters
7904 are present, then they must be converted to VTF-7
7905 */
7906 if (utf8_flag != NULL)
7907 *utf8_flag = 0;
7908 strcpy(rslt, path);
2497a41f
JM		 7909 return rslt;
7910 }
7911
360732b5
JM		 7912 dirend = strrchr(path,'/');
7913
7914 if (dirend == NULL) {
7915 /* If we get here with no UNIX directory delimiters, then this is
7916 not a complete file specification, either garbage a UNIX glob
7917 specification that can not be converted to a VMS wildcard, or
7918 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7919 so apparently other programs expect this also.
7920
7921 utf8 flag setting needs to be preserved.
7922 */
7923 strcpy(rslt, path);
7924 return rslt;
7925 }
7926
2497a41f
JM		 7927/* If POSIX mode active, handle the conversion */
7928#if __CRTL_VER >= 80200000 && !defined(__VAX)
360732b5
JM		 7929 if (decc_efs_charset) {
7930 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
2497a41f
JM		 7931 return rslt;
7932 }
7933#endif
f7ddb74a 7934
f86702cc 7935 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
748a9306
LW		 7936 if (!*(dirend+2)) dirend +=2;
7937 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
360732b5
JM		 7938 if (decc_efs_charset == 0) {
7939 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7940 }
748a9306 7941 }
f7ddb74a 7942
a0d0e21e
LW		 7943 cp1 = rslt;
7944 cp2 = path;
f7ddb74a 7945 lastdot = strrchr(cp2,'.');
a0d0e21e 7946 if (*cp2 == '/') {
a480973c 7947 char *trndev;
e518068a 7948 int islnm, rooted;
7949 STRLEN trnend;
7950
b7ae7a0d 7951 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
61bb5906 7952 if (!*(cp2+1)) {
f7ddb74a
JM		 7953 if (decc_disable_posix_root) {
7954 strcpy(rslt,"sys$disk:[000000]");
7955 }
7956 else {
7957 strcpy(rslt,"sys$posix_root:[000000]");
7958 }
360732b5
JM		 7959 if (utf8_flag != NULL)
7960 *utf8_flag = 0;
61bb5906
CB		 7961 return rslt;
7962 }
a0d0e21e 7963 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
e518068a 7964 *cp1 = '\0';
c5375c28
JM		 7965 trndev = PerlMem_malloc(VMS_MAXRSS);
7966 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
c07a80fd 7967 islnm = my_trnlnm(rslt,trndev,0);
f7ddb74a
JM		 7968
7969 /* DECC special handling */
7970 if (!islnm) {
7971 if (strcmp(rslt,"bin") == 0) {
7972 strcpy(rslt,"sys$system");
7973 cp1 = rslt + 10;
7974 *cp1 = 0;
7975 islnm = my_trnlnm(rslt,trndev,0);
7976 }
7977 else if (strcmp(rslt,"tmp") == 0) {
7978 strcpy(rslt,"sys$scratch");
7979 cp1 = rslt + 11;
7980 *cp1 = 0;
7981 islnm = my_trnlnm(rslt,trndev,0);
7982 }
7983 else if (!decc_disable_posix_root) {
7984 strcpy(rslt, "sys$posix_root");
7985 cp1 = rslt + 13;
7986 *cp1 = 0;
7987 cp2 = path;
7988 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7989 islnm = my_trnlnm(rslt,trndev,0);
7990 }
7991 else if (strcmp(rslt,"dev") == 0) {
7992 if (strncmp(cp2,"/null", 5) == 0) {
7993 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7994 strcpy(rslt,"NLA0");
7995 cp1 = rslt + 4;
7996 *cp1 = 0;
7997 cp2 = cp2 + 5;
7998 islnm = my_trnlnm(rslt,trndev,0);
7999 }
8000 }
8001 }
8002 }
8003
e518068a 8004 trnend = islnm ? strlen(trndev) - 1 : 0;
8005 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8006 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8007 /* If the first element of the path is a logical name, determine
8008 * whether it has to be translated so we can add more directories. */
8009 if (!islnm || rooted) {
8010 *(cp1++) = ':';
8011 *(cp1++) = '[';
8012 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8013 else cp2++;
8014 }
8015 else {
8016 if (cp2 != dirend) {
e518068a 8017 strcpy(rslt,trndev);
8018 cp1 = rslt + trnend;
755b3d5d
JM		 8019 if (*cp2 != 0) {
8020 *(cp1++) = '.';
8021 cp2++;
8022 }
e518068a 8023 }
8024 else {
f7ddb74a
JM		 8025 if (decc_disable_posix_root) {
8026 *(cp1++) = ':';
8027 hasdir = 0;
8028 }
e518068a 8029 }
8030 }
367e4b85 8031 PerlMem_free(trndev);
748a9306 8032 }
a0d0e21e
LW		 8033 else {
8034 *(cp1++) = '[';
748a9306
LW		 8035 if (*cp2 == '.') {
8036 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8037 cp2 += 2; /* skip over "./" - it's redundant */
8038 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8039 }
8040 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8041 *(cp1++) = '-'; /* "../" --> "-" */
8042 cp2 += 3;
8043 }
f86702cc 8044 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8045 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8046 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8047 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8048 cp2 += 4;
8049 }
f7ddb74a
JM		 8050 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8051 /* Escape the extra dots in EFS file specifications */
8052 *(cp1++) = '^';
8053 }
748a9306
LW		 8054 if (cp2 > dirend) cp2 = dirend;
8055 }
8056 else *(cp1++) = '.';
8057 }
8058 for (; cp2 < dirend; cp2++) {
8059 if (*cp2 == '/') {
01b8edb6 8060 if (*(cp2-1) == '/') continue;
748a9306
LW		 8061 if (*(cp1-1) != '.') *(cp1++) = '.';
8062 infront = 0;
8063 }
8064 else if (!infront && *cp2 == '.') {
01b8edb6 8065 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8066 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
fd7385b9
CB		 8067 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8068 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
748a9306 8069 else if (*(cp1-2) == '[') *(cp1-1) = '-';
fd7385b9
CB		 8070 else { /* back up over previous directory name */
8071 cp1--;
8072 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8073 if (*(cp1-1) == '[') {
8074 memcpy(cp1,"000000.",7);
8075 cp1 += 7;
8076 }
748a9306
LW		 8077 }
8078 cp2 += 2;
01b8edb6 8079 if (cp2 == dirend) break;
748a9306 8080 }
f86702cc 8081 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8082 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8083 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8084 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8085 if (!*(cp2+3)) {
8086 *(cp1++) = '.'; /* Simulate trailing '/' */
8087 cp2 += 2; /* for loop will incr this to == dirend */
8088 }
8089 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8090 }
f7ddb74a
JM		 8091 else {
8092 if (decc_efs_charset == 0)
8093 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8094 else {
8095 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8096 *(cp1++) = '.';
8097 }
8098 }
748a9306
LW		 8099 }
8100 else {
e518068a 8101 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
f7ddb74a
JM		 8102 if (*cp2 == '.') {
8103 if (decc_efs_charset == 0)
8104 *(cp1++) = '_';
8105 else {
8106 *(cp1++) = '^';
8107 *(cp1++) = '.';
8108 }
8109 }
748a9306
LW		 8110 else *(cp1++) = *cp2;
8111 infront = 1;
8112 }
a0d0e21e 8113 }
748a9306 8114 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
e518068a 8115 if (hasdir) *(cp1++) = ']';
748a9306 8116 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
f7ddb74a
JM		 8117 /* fixme for ODS5 */
8118 no_type_seen = 0;
8119 if (cp2 > lastdot)
8120 no_type_seen = 1;
8121 while (*cp2) {
8122 switch(*cp2) {
8123 case '?':
360732b5
JM		 8124 if (decc_efs_charset == 0)
8125 *(cp1++) = '%';
8126 else
8127 *(cp1++) = '?';
f7ddb74a
JM		 8128 cp2++;
8129 case ' ':
8130 *(cp1)++ = '^';
8131 *(cp1)++ = '_';
8132 cp2++;
8133 break;
8134 case '.':
8135 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8136 decc_readdir_dropdotnotype) {
8137 *(cp1)++ = '^';
8138 *(cp1)++ = '.';
8139 cp2++;
8140
8141 /* trailing dot ==> '^..' on VMS */
8142 if (*cp2 == '\0') {
8143 *(cp1++) = '.';
8144 no_type_seen = 0;
8145 }
8146 }
8147 else {
8148 *(cp1++) = *(cp2++);
8149 no_type_seen = 0;
8150 }
8151 break;
360732b5
JM		 8152 case '$':
8153 /* This could be a macro to be passed through */
8154 *(cp1++) = *(cp2++);
8155 if (*cp2 == '(') {
8156 const char * save_cp2;
8157 char * save_cp1;
8158 int is_macro;
8159
8160 /* paranoid check */
8161 save_cp2 = cp2;
8162 save_cp1 = cp1;
8163 is_macro = 0;
8164
8165 /* Test through */
8166 *(cp1++) = *(cp2++);
8167 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8168 *(cp1++) = *(cp2++);
8169 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8170 *(cp1++) = *(cp2++);
8171 }
8172 if (*cp2 == ')') {
8173 *(cp1++) = *(cp2++);
8174 is_macro = 1;
8175 }
8176 }
8177 if (is_macro == 0) {
8178 /* Not really a macro - never mind */
8179 cp2 = save_cp2;
8180 cp1 = save_cp1;
8181 }
8182 }
8183 break;
f7ddb74a
JM		 8184 case '\"':
8185 case '~':
8186 case '`':
8187 case '!':
8188 case '#':
8189 case '%':
8190 case '^':
adc11f0b
CB		 8191 /* Don't escape again if following character is
8192 * already something we escape.
8193 */
8194 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8195 *(cp1++) = *(cp2++);
8196 break;
8197 }
8198 /* But otherwise fall through and escape it. */
f7ddb74a
JM		 8199 case '&':
8200 case '(':
8201 case ')':
8202 case '=':
8203 case '+':
8204 case '\'':
8205 case '@':
8206 case '[':
8207 case ']':
8208 case '{':
8209 case '}':
8210 case ':':
8211 case '\\':
8212 case '|':
8213 case '<':
8214 case '>':
8215 *(cp1++) = '^';
8216 *(cp1++) = *(cp2++);
8217 break;
8218 case ';':
8219 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
657054d4 8220 * which is wrong. UNIX notation should be ".dir." unless
f7ddb74a
JM		 8221 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8222 * changing this behavior could break more things at this time.
2497a41f
JM		 8223 * efs character set effectively does not allow "." to be a version
8224 * delimiter as a further complication about changing this.
f7ddb74a
JM		 8225 */
8226 if (decc_filename_unix_report != 0) {
8227 *(cp1++) = '^';
8228 }
8229 *(cp1++) = *(cp2++);
8230 break;
8231 default:
8232 *(cp1++) = *(cp2++);
8233 }
8234 }
8235 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8236 char *lcp1;
8237 lcp1 = cp1;
8238 lcp1--;
8239 /* Fix me for "^]", but that requires making sure that you do
8240 * not back up past the start of the filename
8241 */
8242 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8243 *cp1++ = '.';
8244 }
a0d0e21e
LW		 8245 *cp1 = '\0';
8246
360732b5
JM		 8247 if (utf8_flag != NULL)
8248 *utf8_flag = 0;
a0d0e21e
LW		 8249 return rslt;
8250
8251} /* end of do_tovmsspec() */
8252/*}}}*/
8253/* External entry points */
360732b5
JM		 8254char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8255 { return do_tovmsspec(path,buf,0,NULL); }
8256char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8257 { return do_tovmsspec(path,buf,1,NULL); }
8258char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8259 { return do_tovmsspec(path,buf,0,utf8_fl); }
8260char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8261 { return do_tovmsspec(path,buf,1,utf8_fl); }
8262
8263/*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8264static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
a480973c 8265 static char __tovmspath_retbuf[VMS_MAXRSS];
a0d0e21e 8266 int vmslen;
a480973c 8267 char *pathified, *vmsified, *cp;
a0d0e21e 8268
748a9306 8269 if (path == NULL) return NULL;
c5375c28
JM		 8270 pathified = PerlMem_malloc(VMS_MAXRSS);
8271 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
360732b5 8272 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
c5375c28 8273 PerlMem_free(pathified);
a480973c
JM		 8274 return NULL;
8275 }
c5375c28
JM		 8276
8277 vmsified = NULL;
8278 if (buf == NULL)
8279 Newx(vmsified, VMS_MAXRSS, char);
360732b5 8280 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
c5375c28
JM		 8281 PerlMem_free(pathified);
8282 if (vmsified) Safefree(vmsified);
a480973c
JM		 8283 return NULL;
8284 }
c5375c28 8285 PerlMem_free(pathified);
a480973c 8286 if (buf) {
a480973c
JM		 8287 return buf;
8288 }
a0d0e21e
LW		 8289 else if (ts) {
8290 vmslen = strlen(vmsified);
a02a5408 8291 Newx(cp,vmslen+1,char);
a0d0e21e
LW		 8292 memcpy(cp,vmsified,vmslen);
8293 cp[vmslen] = '\0';
a480973c 8294 Safefree(vmsified);
a0d0e21e
LW		 8295 return cp;
8296 }
8297 else {
8298 strcpy(__tovmspath_retbuf,vmsified);
a480973c 8299 Safefree(vmsified);
a0d0e21e
LW		 8300 return __tovmspath_retbuf;
8301 }
8302
8303} /* end of do_tovmspath() */
8304/*}}}*/
8305/* External entry points */
360732b5
JM		 8306char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8307 { return do_tovmspath(path,buf,0, NULL); }
8308char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8309 { return do_tovmspath(path,buf,1, NULL); }
8310char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8311 { return do_tovmspath(path,buf,0,utf8_fl); }
8312char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8313 { return do_tovmspath(path,buf,1,utf8_fl); }
8314
8315
8316/*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8317static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
a480973c 8318 static char __tounixpath_retbuf[VMS_MAXRSS];
a0d0e21e 8319 int unixlen;
a480973c 8320 char *pathified, *unixified, *cp;
a0d0e21e 8321
748a9306 8322 if (path == NULL) return NULL;
c5375c28
JM		 8323 pathified = PerlMem_malloc(VMS_MAXRSS);
8324 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
360732b5 8325 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
c5375c28 8326 PerlMem_free(pathified);
a480973c
JM		 8327 return NULL;
8328 }
c5375c28
JM		 8329
8330 unixified = NULL;
8331 if (buf == NULL) {
8332 Newx(unixified, VMS_MAXRSS, char);
8333 }
360732b5 8334 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
c5375c28
JM		 8335 PerlMem_free(pathified);
8336 if (unixified) Safefree(unixified);
a480973c
JM		 8337 return NULL;
8338 }
c5375c28 8339 PerlMem_free(pathified);
a480973c 8340 if (buf) {
a480973c
JM		 8341 return buf;
8342 }
a0d0e21e
LW		 8343 else if (ts) {
8344 unixlen = strlen(unixified);
a02a5408 8345 Newx(cp,unixlen+1,char);
a0d0e21e
LW		 8346 memcpy(cp,unixified,unixlen);
8347 cp[unixlen] = '\0';
a480973c 8348 Safefree(unixified);
a0d0e21e
LW		 8349 return cp;
8350 }
8351 else {
8352 strcpy(__tounixpath_retbuf,unixified);
a480973c 8353 Safefree(unixified);
a0d0e21e
LW		 8354 return __tounixpath_retbuf;
8355 }
8356
8357} /* end of do_tounixpath() */
8358/*}}}*/
8359/* External entry points */
360732b5
JM		 8360char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8361 { return do_tounixpath(path,buf,0,NULL); }
8362char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8363 { return do_tounixpath(path,buf,1,NULL); }
8364char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8365 { return do_tounixpath(path,buf,0,utf8_fl); }
8366char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8367 { return do_tounixpath(path,buf,1,utf8_fl); }
a0d0e21e
LW		 8368
8369/*
cbb8049c 8370 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
a0d0e21e
LW		 8371 *
8372 *****************************************************************************
8373 * *
cbb8049c 8374 * Copyright (C) 1989-1994, 2007 by *
a0d0e21e
LW		 8375 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
8376 * *
cbb8049c
MP		 8377 * Permission is hereby granted for the reproduction of this software *
8378 * on condition that this copyright notice is included in source *
8379 * distributions of the software. The code may be modified and *
8380 * distributed under the same terms as Perl itself. *
a0d0e21e
LW		 8381 * *
8382 * 27-Aug-1994 Modified for inclusion in perl5 *
cbb8049c 8383 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
a0d0e21e
LW		 8384 *****************************************************************************
8385 */
8386
8387/*
8388 * getredirection() is intended to aid in porting C programs
8389 * to VMS (Vax-11 C). The native VMS environment does not support
8390 * '>' and '<' I/O redirection, or command line wild card expansion,
8391 * or a command line pipe mechanism using the '|' AND background
8392 * command execution '&'. All of these capabilities are provided to any
8393 * C program which calls this procedure as the first thing in the
8394 * main program.
8395 * The piping mechanism will probably work with almost any 'filter' type
8396 * of program. With suitable modification, it may useful for other
8397 * portability problems as well.
8398 *
cbb8049c 8399 * Author: Mark Pizzolato (mark AT infocomm DOT com)
a0d0e21e
LW		 8400 */
8401struct list_item
8402 {
8403 struct list_item *next;
8404 char *value;
8405 };
8406
8407static void add_item(struct list_item **head,
8408 struct list_item **tail,
8409 char *value,
8410 int *count);
8411
4b19af01
CB		 8412static void mp_expand_wild_cards(pTHX_ char *item,
8413 struct list_item **head,
8414 struct list_item **tail,
8415 int *count);
a0d0e21e 8416
8df869cb 8417static int background_process(pTHX_ int argc, char **argv);
a0d0e21e 8418
fd8cd3a3 8419static void pipe_and_fork(pTHX_ char **cmargv);
a0d0e21e
LW		 8420
8421/*{{{ void getredirection(int *ac, char ***av)*/
84902520 8422static void
4b19af01 8423mp_getredirection(pTHX_ int *ac, char ***av)
a0d0e21e
LW		 8424/*
8425 * Process vms redirection arg's. Exit if any error is seen.
8426 * If getredirection() processes an argument, it is erased
8427 * from the vector. getredirection() returns a new argc and argv value.
8428 * In the event that a background command is requested (by a trailing "&"),
8429 * this routine creates a background subprocess, and simply exits the program.
8430 *
8431 * Warning: do not try to simplify the code for vms. The code
8432 * presupposes that getredirection() is called before any data is
8433 * read from stdin or written to stdout.
8434 *
8435 * Normal usage is as follows:
8436 *
8437 * main(argc, argv)
8438 * int argc;
8439 * char *argv[];
8440 * {
8441 * getredirection(&argc, &argv);
8442 * }
8443 */
8444{
8445 int argc = *ac; /* Argument Count */
8446 char **argv = *av; /* Argument Vector */
8447 char *ap; /* Argument pointer */
8448 int j; /* argv[] index */
8449 int item_count = 0; /* Count of Items in List */
8450 struct list_item *list_head = 0; /* First Item in List */
8451 struct list_item *list_tail; /* Last Item in List */
8452 char *in = NULL; /* Input File Name */
8453 char *out = NULL; /* Output File Name */
8454 char *outmode = "w"; /* Mode to Open Output File */
8455 char *err = NULL; /* Error File Name */
8456 char *errmode = "w"; /* Mode to Open Error File */
8457 int cmargc = 0; /* Piped Command Arg Count */
8458 char **cmargv = NULL;/* Piped Command Arg Vector */
a0d0e21e
LW		 8459
8460 /*
8461 * First handle the case where the last thing on the line ends with
8462 * a '&'. This indicates the desire for the command to be run in a
8463 * subprocess, so we satisfy that desire.
8464 */
8465 ap = argv[argc-1];
8466 if (0 == strcmp("&", ap))
8c3eed29 8467 exit(background_process(aTHX_ --argc, argv));
e518068a 8468 if (*ap && '&' == ap[strlen(ap)-1])
a0d0e21e
LW		 8469 {
8470 ap[strlen(ap)-1] = '\0';
8c3eed29 8471 exit(background_process(aTHX_ argc, argv));
a0d0e21e
LW		 8472 }
8473 /*
8474 * Now we handle the general redirection cases that involve '>', '>>',
8475 * '<', and pipes '|'.
8476 */
8477 for (j = 0; j < argc; ++j)
8478 {
8479 if (0 == strcmp("<", argv[j]))
8480 {
8481 if (j+1 >= argc)
8482 {
fd71b04b 8483 fprintf(stderr,"No input file after < on command line");
748a9306 8484 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8485 }
8486 in = argv[++j];
8487 continue;
8488 }
8489 if ('<' == *(ap = argv[j]))
8490 {
8491 in = 1 + ap;
8492 continue;
8493 }
8494 if (0 == strcmp(">", ap))
8495 {
8496 if (j+1 >= argc)
8497 {
fd71b04b 8498 fprintf(stderr,"No output file after > on command line");
748a9306 8499 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8500 }
8501 out = argv[++j];
8502 continue;
8503 }
8504 if ('>' == *ap)
8505 {
8506 if ('>' == ap[1])
8507 {
8508 outmode = "a";
8509 if ('\0' == ap[2])
8510 out = argv[++j];
8511 else
8512 out = 2 + ap;
8513 }
8514 else
8515 out = 1 + ap;
8516 if (j >= argc)
8517 {
fd71b04b 8518 fprintf(stderr,"No output file after > or >> on command line");
748a9306 8519 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8520 }
8521 continue;
8522 }
8523 if (('2' == *ap) && ('>' == ap[1]))
8524 {
8525 if ('>' == ap[2])
8526 {
8527 errmode = "a";
8528 if ('\0' == ap[3])
8529 err = argv[++j];
8530 else
8531 err = 3 + ap;
8532 }
8533 else
8534 if ('\0' == ap[2])
8535 err = argv[++j];
8536 else
748a9306 8537 err = 2 + ap;
a0d0e21e
LW		 8538 if (j >= argc)
8539 {
fd71b04b 8540 fprintf(stderr,"No output file after 2> or 2>> on command line");
748a9306 8541 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8542 }
8543 continue;
8544 }
8545 if (0 == strcmp("|", argv[j]))
8546 {
8547 if (j+1 >= argc)
8548 {
fd71b04b 8549 fprintf(stderr,"No command into which to pipe on command line");
748a9306 8550 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8551 }
8552 cmargc = argc-(j+1);
8553 cmargv = &argv[j+1];
8554 argc = j;
8555 continue;
8556 }
8557 if ('|' == *(ap = argv[j]))
8558 {
8559 ++argv[j];
8560 cmargc = argc-j;
8561 cmargv = &argv[j];
8562 argc = j;
8563 continue;
8564 }
8565 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8566 }
8567 /*
8568 * Allocate and fill in the new argument vector, Some Unix's terminate
8569 * the list with an extra null pointer.
8570 */
e0ef6b43 8571 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
c5375c28 8572 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 8573 *av = argv;
8574 for (j = 0; j < item_count; ++j, list_head = list_head->next)
8575 argv[j] = list_head->value;
8576 *ac = item_count;
8577 if (cmargv != NULL)
8578 {
8579 if (out != NULL)
8580 {
fd71b04b 8581 fprintf(stderr,"'|' and '>' may not both be specified on command line");
748a9306 8582 exit(LIB$_INVARGORD);
a0d0e21e 8583 }
fd8cd3a3 8584 pipe_and_fork(aTHX_ cmargv);
a0d0e21e
LW		 8585 }
8586
8587 /* Check for input from a pipe (mailbox) */
8588
a5f75d66 8589 if (in == NULL && 1 == isapipe(0))
a0d0e21e
LW		 8590 {
8591 char mbxname[L_tmpnam];
8592 long int bufsize;
8593 long int dvi_item = DVI$_DEVBUFSIZ;
8594 $DESCRIPTOR(mbxnam, "");
8595 $DESCRIPTOR(mbxdevnam, "");
8596
8597 /* Input from a pipe, reopen it in binary mode to disable */
8598 /* carriage control processing. */
8599
fd71b04b 8600 fgetname(stdin, mbxname);
a0d0e21e
LW		 8601 mbxnam.dsc$a_pointer = mbxname;
8602 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8603 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8604 mbxdevnam.dsc$a_pointer = mbxname;
8605 mbxdevnam.dsc$w_length = sizeof(mbxname);
8606 dvi_item = DVI$_DEVNAM;
8607 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8608 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
748a9306
LW		 8609 set_errno(0);
8610 set_vaxc_errno(1);
a0d0e21e
LW		 8611 freopen(mbxname, "rb", stdin);
8612 if (errno != 0)
8613 {
fd71b04b 8614 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
748a9306 8615 exit(vaxc$errno);
a0d0e21e
LW		 8616 }
8617 }
8618 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8619 {
fd71b04b 8620 fprintf(stderr,"Can't open input file %s as stdin",in);
748a9306 8621 exit(vaxc$errno);
a0d0e21e
LW		 8622 }
8623 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8624 {
fd71b04b 8625 fprintf(stderr,"Can't open output file %s as stdout",out);
748a9306 8626 exit(vaxc$errno);
a0d0e21e 8627 }
fd8cd3a3 8628 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
0e06870b 8629
748a9306 8630 if (err != NULL) {
71d7ec5d 8631 if (strcmp(err,"&1") == 0) {
a15cef0c 8632 dup2(fileno(stdout), fileno(stderr));
fd8cd3a3 8633 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
71d7ec5d 8634 } else {
748a9306
LW		 8635 FILE *tmperr;
8636 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8637 {
fd71b04b 8638 fprintf(stderr,"Can't open error file %s as stderr",err);
748a9306
LW		 8639 exit(vaxc$errno);
8640 }
8641 fclose(tmperr);
a15cef0c 8642 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
748a9306
LW		 8643 {
8644 exit(vaxc$errno);
8645 }
fd8cd3a3 8646 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
a0d0e21e 8647 }
71d7ec5d 8648 }
a0d0e21e 8649#ifdef ARGPROC_DEBUG
740ce14c 8650 PerlIO_printf(Perl_debug_log, "Arglist:\n");
a0d0e21e 8651 for (j = 0; j < *ac; ++j)
740ce14c 8652 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
a0d0e21e 8653#endif
b7ae7a0d 8654 /* Clear errors we may have hit expanding wildcards, so they don't
8655 show up in Perl's $! later */
8656 set_errno(0); set_vaxc_errno(1);
a0d0e21e
LW		 8657} /* end of getredirection() */
8658/*}}}*/
8659
8660static void add_item(struct list_item **head,
8661 struct list_item **tail,
8662 char *value,
8663 int *count)
8664{
8665 if (*head == 0)
8666 {
e0ef6b43 8667 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 8668 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 8669 *tail = *head;
8670 }
8671 else {
e0ef6b43 8672 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 8673 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 8674 *tail = (*tail)->next;
8675 }
8676 (*tail)->value = value;
8677 ++(*count);
8678}
8679
4b19af01 8680static void mp_expand_wild_cards(pTHX_ char *item,
a0d0e21e
LW		 8681 struct list_item **head,
8682 struct list_item **tail,
8683 int *count)
8684{
8685int expcount = 0;
748a9306 8686unsigned long int context = 0;
a0d0e21e 8687int isunix = 0;
773da73d 8688int item_len = 0;
a0d0e21e
LW		 8689char *had_version;
8690char *had_device;
8691int had_directory;
f675dbe5 8692char *devdir,*cp;
a480973c 8693char *vmsspec;
a0d0e21e 8694$DESCRIPTOR(filespec, "");
748a9306 8695$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
a0d0e21e 8696$DESCRIPTOR(resultspec, "");
a480973c
JM		 8697unsigned long int lff_flags = 0;
8698int sts;
dca5a913 8699int rms_sts;
a480973c
JM		 8700
8701#ifdef VMS_LONGNAME_SUPPORT
8702 lff_flags = LIB$M_FIL_LONG_NAMES;
8703#endif
a0d0e21e 8704
f675dbe5
CB		 8705 for (cp = item; *cp; cp++) {
8706 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8707 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8708 }
8709 if (!*cp || isspace(*cp))
a0d0e21e
LW		 8710 {
8711 add_item(head, tail, item, count);
8712 return;
8713 }
773da73d
JH		 8714 else
8715 {
8716 /* "double quoted" wild card expressions pass as is */
8717 /* From DCL that means using e.g.: */
8718 /* perl program """perl.*""" */
8719 item_len = strlen(item);
8720 if ( '"' == *item && '"' == item[item_len-1] )
8721 {
8722 item++;
8723 item[item_len-2] = '\0';
8724 add_item(head, tail, item, count);
8725 return;
8726 }
8727 }
a0d0e21e
LW		 8728 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8729 resultspec.dsc$b_class = DSC$K_CLASS_D;
8730 resultspec.dsc$a_pointer = NULL;
c5375c28
JM		 8731 vmsspec = PerlMem_malloc(VMS_MAXRSS);
8732 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
748a9306 8733 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
360732b5 8734 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
a0d0e21e
LW		 8735 if (!isunix || !filespec.dsc$a_pointer)
8736 filespec.dsc$a_pointer = item;
8737 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8738 /*
8739 * Only return version specs, if the caller specified a version
8740 */
8741 had_version = strchr(item, ';');
8742 /*
8743 * Only return device and directory specs, if the caller specifed either.
8744 */
8745 had_device = strchr(item, ':');
8746 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8747
a480973c
JM		 8748 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8749 (&filespec, &resultspec, &context,
dca5a913 8750 &defaultspec, 0, &rms_sts, &lff_flags)))
a0d0e21e
LW		 8751 {
8752 char *string;
8753 char *c;
8754
c5375c28
JM		 8755 string = PerlMem_malloc(resultspec.dsc$w_length+1);
8756 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 8757 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8758 string[resultspec.dsc$w_length] = '\0';
8759 if (NULL == had_version)
f7ddb74a 8760 *(strrchr(string, ';')) = '\0';
a0d0e21e
LW		 8761 if ((!had_directory) && (had_device == NULL))
8762 {
8763 if (NULL == (devdir = strrchr(string, ']')))
8764 devdir = strrchr(string, '>');
8765 strcpy(string, devdir + 1);
8766 }
8767 /*
8768 * Be consistent with what the C RTL has already done to the rest of
8769 * the argv items and lowercase all of these names.
8770 */
f7ddb74a
JM		 8771 if (!decc_efs_case_preserve) {
8772 for (c = string; *c; ++c)
a0d0e21e
LW		 8773 if (isupper(*c))
8774 *c = tolower(*c);
f7ddb74a 8775 }
f86702cc 8776 if (isunix) trim_unixpath(string,item,1);
a0d0e21e
LW		 8777 add_item(head, tail, string, count);
8778 ++expcount;
a480973c 8779 }
367e4b85 8780 PerlMem_free(vmsspec);
c07a80fd 8781 if (sts != RMS$_NMF)
8782 {
8783 set_vaxc_errno(sts);
8784 switch (sts)
8785 {
f282b18d 8786 case RMS$_FNF: case RMS$_DNF:
c07a80fd 8787 set_errno(ENOENT); break;
f282b18d
CB		 8788 case RMS$_DIR:
8789 set_errno(ENOTDIR); break;
c07a80fd 8790 case RMS$_DEV:
8791 set_errno(ENODEV); break;
f282b18d 8792 case RMS$_FNM: case RMS$_SYN:
c07a80fd 8793 set_errno(EINVAL); break;
8794 case RMS$_PRV:
8795 set_errno(EACCES); break;
8796 default:
b7ae7a0d 8797 _ckvmssts_noperl(sts);
c07a80fd 8798 }
8799 }
a0d0e21e
LW		 8800 if (expcount == 0)
8801 add_item(head, tail, item, count);
b7ae7a0d 8802 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8803 _ckvmssts_noperl(lib$find_file_end(&context));
a0d0e21e
LW		 8804}
8805
8806static int child_st[2];/* Event Flag set when child process completes */
8807
748a9306 8808static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
a0d0e21e 8809
748a9306 8810static unsigned long int exit_handler(int *status)
a0d0e21e
LW		 8811{
8812short iosb[4];
8813
8814 if (0 == child_st[0])
8815 {
8816#ifdef ARGPROC_DEBUG
740ce14c 8817 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
a0d0e21e
LW		 8818#endif
8819 fflush(stdout); /* Have to flush pipe for binary data to */
8820 /* terminate properly -- <tp@mccall.com> */
8821 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8822 sys$dassgn(child_chan);
8823 fclose(stdout);
8824 sys$synch(0, child_st);
8825 }
8826 return(1);
8827}
8828
8829static void sig_child(int chan)
8830{
8831#ifdef ARGPROC_DEBUG
740ce14c 8832 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
a0d0e21e
LW		 8833#endif
8834 if (child_st[0] == 0)
8835 child_st[0] = 1;
8836}
8837
748a9306 8838static struct exit_control_block exit_block =
a0d0e21e
LW		 8839 {
8840 0,
8841 exit_handler,
8842 1,
8843 &exit_block.exit_status,
8844 0
8845 };
8846
ff7adb52
CL		 8847static void
8848pipe_and_fork(pTHX_ char **cmargv)
a0d0e21e 8849{
ff7adb52 8850 PerlIO *fp;
218fdd94 8851 struct dsc$descriptor_s *vmscmd;
ff7adb52
CL		 8852 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8853 int sts, j, l, ismcr, quote, tquote = 0;
8854
218fdd94
CL		 8855 sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8856 vms_execfree(vmscmd);
ff7adb52
CL		 8857
8858 j = l = 0;
8859 p = subcmd;
8860 q = cmargv[0];
8861 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
8862 && toupper(*(q+2)) == 'R' && !*(q+3);
8863
8864 while (q && l < MAX_DCL_LINE_LENGTH) {
8865 if (!*q) {
8866 if (j > 0 && quote) {
8867 *p++ = '"';
8868 l++;
8869 }
8870 q = cmargv[++j];
8871 if (q) {
8872 if (ismcr && j > 1) quote = 1;
8873 tquote = (strchr(q,' ')) != NULL || *q == '\0';
8874 *p++ = ' ';
8875 l++;
8876 if (quote || tquote) {
8877 *p++ = '"';
8878 l++;
8879 }
988c775c 8880 }
ff7adb52
CL		 8881 } else {
8882 if ((quote||tquote) && *q == '"') {
8883 *p++ = '"';
8884 l++;
988c775c 8885 }
ff7adb52
CL		 8886 *p++ = *q++;
8887 l++;
8888 }
8889 }
8890 *p = '\0';
a0d0e21e 8891
218fdd94 8892 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
ff7adb52
CL		 8893 if (fp == Nullfp) {
8894 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
988c775c 8895 }
a0d0e21e
LW		 8896}
8897
8df869cb 8898static int background_process(pTHX_ int argc, char **argv)
a0d0e21e 8899{
a480973c 8900char command[MAX_DCL_SYMBOL + 1] = "$";
a0d0e21e
LW		 8901$DESCRIPTOR(value, "");
8902static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8903static $DESCRIPTOR(null, "NLA0:");
8904static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8905char pidstring[80];
8906$DESCRIPTOR(pidstr, "");
8907int pid;
748a9306 8908unsigned long int flags = 17, one = 1, retsts;
a480973c 8909int len;
a0d0e21e
LW		 8910
8911 strcat(command, argv[0]);
a480973c
JM		 8912 len = strlen(command);
8913 while (--argc && (len < MAX_DCL_SYMBOL))
a0d0e21e
LW		 8914 {
8915 strcat(command, " \"");
8916 strcat(command, *(++argv));
8917 strcat(command, "\"");
a480973c 8918 len = strlen(command);
a0d0e21e
LW		 8919 }
8920 value.dsc$a_pointer = command;
8921 value.dsc$w_length = strlen(value.dsc$a_pointer);
b7ae7a0d 8922 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
748a9306
LW		 8923 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8924 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
b7ae7a0d 8925 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
748a9306
LW		 8926 }
8927 else {
b7ae7a0d 8928 _ckvmssts_noperl(retsts);
748a9306 8929 }
a0d0e21e 8930#ifdef ARGPROC_DEBUG
740ce14c 8931 PerlIO_printf(Perl_debug_log, "%s\n", command);
a0d0e21e
LW		 8932#endif
8933 sprintf(pidstring, "%08X", pid);
740ce14c 8934 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
a0d0e21e
LW		 8935 pidstr.dsc$a_pointer = pidstring;
8936 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8937 lib$set_symbol(&pidsymbol, &pidstr);
8938 return(SS$_NORMAL);
8939}
8940/*}}}*/
8941/***** End of code taken from Mark Pizzolato's argproc.c package *****/
8942
84902520
TB		 8943
8944/* OS-specific initialization at image activation (not thread startup) */
61bb5906
CB		 8945/* Older VAXC header files lack these constants */
8946#ifndef JPI$_RIGHTS_SIZE
8947# define JPI$_RIGHTS_SIZE 817
8948#endif
8949#ifndef KGB$M_SUBSYSTEM
8950# define KGB$M_SUBSYSTEM 0x8
8951#endif
a480973c 8952
e0ef6b43
CB		 8953/* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8954
84902520
TB		 8955/*{{{void vms_image_init(int *, char ***)*/
8956void
8957vms_image_init(int *argcp, char ***argvp)
8958{
f675dbe5
CB		 8959 char eqv[LNM$C_NAMLENGTH+1] = "";
8960 unsigned int len, tabct = 8, tabidx = 0;
8961 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
61bb5906
CB		 8962 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8963 unsigned short int dummy, rlen;
f675dbe5 8964 struct dsc$descriptor_s **tabvec;
fd8cd3a3
DS		 8965#if defined(PERL_IMPLICIT_CONTEXT)
8966 pTHX = NULL;
8967#endif
61bb5906
CB		 8968 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8969 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8970 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8971 { 0, 0, 0, 0} };
84902520 8972
2e34cc90 8973#ifdef KILL_BY_SIGPRC
f7ddb74a 8974 Perl_csighandler_init();
2e34cc90
CL		 8975#endif
8976
fd8cd3a3
DS		 8977 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8978 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 8979 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8980 if (iprv[i]) { /* Running image installed with privs? */
fd8cd3a3 8981 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
f675dbe5 8982 will_taint = TRUE;
84902520
TB		 8983 break;
8984 }
8985 }
61bb5906 8986 /* Rights identifiers might trigger tainting as well. */
f675dbe5 8987 if (!will_taint && (rlen || rsz)) {
61bb5906
CB		 8988 while (rlen < rsz) {
8989 /* We didn't get all the identifiers on the first pass. Allocate a
8990 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8991 * were needed to hold all identifiers at time of last call; we'll
8992 * allocate that many unsigned long ints), and go back and get 'em.
22d4bb9c
CB		 8993 * If it gave us less than it wanted to despite ample buffer space,
8994 * something's broken. Is your system missing a system identifier?
61bb5906 8995 */
22d4bb9c
CB		 8996 if (rsz <= jpilist[1].buflen) {
8997 /* Perl_croak accvios when used this early in startup. */
8998 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8999 rsz, (unsigned long) jpilist[1].buflen,
9000 "Check your rights database for corruption.\n");
9001 exit(SS$_ABORT);
9002 }
e0ef6b43
CB		 9003 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9004 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
c5375c28 9005 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
61bb5906 9006 jpilist[1].buflen = rsz * sizeof(unsigned long int);
fd8cd3a3
DS		 9007 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9008 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 9009 }
9010 mask = jpilist[1].bufadr;
9011 /* Check attribute flags for each identifier (2nd longword); protected
9012 * subsystem identifiers trigger tainting.
9013 */
9014 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9015 if (mask[i] & KGB$M_SUBSYSTEM) {
f675dbe5 9016 will_taint = TRUE;
61bb5906
CB		 9017 break;
9018 }
9019 }
367e4b85 9020 if (mask != rlst) PerlMem_free(mask);
61bb5906 9021 }
f7ddb74a
JM		 9022
9023 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9024 * logical, some versions of the CRTL will add a phanthom /000000/
9025 * directory. This needs to be removed.
9026 */
9027 if (decc_filename_unix_report) {
9028 char * zeros;
9029 int ulen;
9030 ulen = strlen(argvp[0][0]);
9031 if (ulen > 7) {
9032 zeros = strstr(argvp[0][0], "/000000/");
9033 if (zeros != NULL) {
9034 int mlen;
9035 mlen = ulen - (zeros - argvp[0][0]) - 7;
9036 memmove(zeros, &zeros[7], mlen);
9037 ulen = ulen - 7;
9038 argvp[0][0][ulen] = '\0';
9039 }
9040 }
9041 /* It also may have a trailing dot that needs to be removed otherwise
9042 * it will be converted to VMS mode incorrectly.
9043 */
9044 ulen--;
9045 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9046 argvp[0][0][ulen] = '\0';
9047 }
9048
61bb5906 9049 /* We need to use this hack to tell Perl it should run with tainting,
6b88bc9c 9050 * since its tainting flag may be part of the PL_curinterp struct, which
61bb5906
CB		 9051 * hasn't been allocated when vms_image_init() is called.
9052 */
f675dbe5 9053 if (will_taint) {
ec618cdf
CB		 9054 char **newargv, **oldargv;
9055 oldargv = *argvp;
e0ef6b43 9056 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
c5375c28 9057 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf 9058 newargv[0] = oldargv[0];
c5375c28
JM		 9059 newargv[1] = PerlMem_malloc(3 * sizeof(char));
9060 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf
CB		 9061 strcpy(newargv[1], "-T");
9062 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9063 (*argcp)++;
9064 newargv[*argcp] = NULL;
61bb5906
CB		 9065 /* We orphan the old argv, since we don't know where it's come from,
9066 * so we don't know how to free it.
9067 */
ec618cdf 9068 *argvp = newargv;
61bb5906 9069 }
f675dbe5
CB		 9070 else { /* Did user explicitly request tainting? */
9071 int i;
9072 char *cp, **av = *argvp;
9073 for (i = 1; i < *argcp; i++) {
9074 if (*av[i] != '-') break;
9075 for (cp = av[i]+1; *cp; cp++) {
9076 if (*cp == 'T') { will_taint = 1; break; }
9077 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9078 strchr("DFIiMmx",*cp)) break;
9079 }
9080 if (will_taint) break;
9081 }
9082 }
9083
9084 for (tabidx = 0;
9085 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9086 tabidx++) {
c5375c28
JM		 9087 if (!tabidx) {
9088 tabvec = (struct dsc$descriptor_s **)
9089 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9090 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9091 }
f675dbe5
CB		 9092 else if (tabidx >= tabct) {
9093 tabct += 8;
e0ef6b43 9094 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
c5375c28 9095 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f675dbe5 9096 }
e0ef6b43 9097 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
c5375c28 9098 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f675dbe5
CB		 9099 tabvec[tabidx]->dsc$w_length = 0;
9100 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9101 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9102 tabvec[tabidx]->dsc$a_pointer = NULL;
fd8cd3a3 9103 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
f675dbe5
CB		 9104 }
9105 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9106
84902520 9107 getredirection(argcp,argvp);
3bc25146
CB		 9108#if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9109 {
9110# include <reentrancy.h>
f7ddb74a 9111 decc$set_reentrancy(C$C_MULTITHREAD);
3bc25146
CB		 9112 }
9113#endif
84902520
TB		 9114 return;
9115}
9116/*}}}*/
9117
9118
a0d0e21e
LW		 9119/* trim_unixpath()
9120 * Trim Unix-style prefix off filespec, so it looks like what a shell
9121 * glob expansion would return (i.e. from specified prefix on, not
9122 * full path). Note that returned filespec is Unix-style, regardless
9123 * of whether input filespec was VMS-style or Unix-style.
9124 *
a3e9d8c9 9125 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
f86702cc 9126 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9127 * vector of options; at present, only bit 0 is used, and if set tells
9128 * trim unixpath to try the current default directory as a prefix when
9129 * presented with a possibly ambiguous ... wildcard.
a3e9d8c9 9130 *
9131 * Returns !=0 on success, with trimmed filespec replacing contents of
9132 * fspec, and 0 on failure, with contents of fpsec unchanged.
a0d0e21e 9133 */
f86702cc 9134/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
a0d0e21e 9135int
2fbb330f 9136Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
a0d0e21e 9137{
a480973c 9138 char *unixified, *unixwild,
f86702cc 9139 *template, *base, *end, *cp1, *cp2;
9140 register int tmplen, reslen = 0, dirs = 0;
a0d0e21e 9141
c5375c28
JM		 9142 unixwild = PerlMem_malloc(VMS_MAXRSS);
9143 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
a3e9d8c9 9144 if (!wildspec || !fspec) return 0;
2fbb330f 9145 template = unixwild;
a3e9d8c9 9146 if (strpbrk(wildspec,"]>:") != NULL) {
360732b5 9147 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
367e4b85 9148 PerlMem_free(unixwild);
a480973c
JM		 9149 return 0;
9150 }
a3e9d8c9 9151 }
2fbb330f 9152 else {
a480973c
JM		 9153 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9154 unixwild[VMS_MAXRSS-1] = 0;
2fbb330f 9155 }
c5375c28
JM		 9156 unixified = PerlMem_malloc(VMS_MAXRSS);
9157 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
a0d0e21e 9158 if (strpbrk(fspec,"]>:") != NULL) {
360732b5 9159 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
367e4b85
JM		 9160 PerlMem_free(unixwild);
9161 PerlMem_free(unixified);
a480973c
JM		 9162 return 0;
9163 }
a0d0e21e 9164 else base = unixified;
a3e9d8c9 9165 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9166 * check to see that final result fits into (isn't longer than) fspec */
9167 reslen = strlen(fspec);
a0d0e21e
LW		 9168 }
9169 else base = fspec;
a3e9d8c9 9170
9171 /* No prefix or absolute path on wildcard, so nothing to remove */
9172 if (!*template || *template == '/') {
367e4b85 9173 PerlMem_free(unixwild);
a480973c 9174 if (base == fspec) {
367e4b85 9175 PerlMem_free(unixified);
a480973c
JM		 9176 return 1;
9177 }
a3e9d8c9 9178 tmplen = strlen(unixified);
a480973c 9179 if (tmplen > reslen) {
367e4b85 9180 PerlMem_free(unixified);
a480973c
JM		 9181 return 0; /* not enough space */
9182 }
a3e9d8c9 9183 /* Copy unixified resultant, including trailing NUL */
9184 memmove(fspec,unixified,tmplen+1);
367e4b85 9185 PerlMem_free(unixified);
a3e9d8c9 9186 return 1;
9187 }
a0d0e21e 9188
f86702cc 9189 for (end = base; *end; end++) ; /* Find end of resultant filespec */
9190 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9191 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9192 for (cp1 = end ;cp1 >= base; cp1--)
9193 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9194 { cp1++; break; }
9195 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
367e4b85
JM		 9196 PerlMem_free(unixified);
9197 PerlMem_free(unixwild);
a3e9d8c9 9198 return 1;
9199 }
f86702cc 9200 else {
a480973c 9201 char *tpl, *lcres;
f86702cc 9202 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9203 int ells = 1, totells, segdirs, match;
a480973c 9204 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
f86702cc 9205 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9206
9207 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9208 totells = ells;
9209 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
367e4b85 9210 tpl = PerlMem_malloc(VMS_MAXRSS);
c5375c28 9211 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
f86702cc 9212 if (ellipsis == template && opts & 1) {
9213 /* Template begins with an ellipsis. Since we can't tell how many
9214 * directory names at the front of the resultant to keep for an
9215 * arbitrary starting point, we arbitrarily choose the current
9216 * default directory as a starting point. If it's there as a prefix,
9217 * clip it off. If not, fall through and act as if the leading
9218 * ellipsis weren't there (i.e. return shortest possible path that
9219 * could match template).
9220 */
a480973c 9221 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
367e4b85
JM		 9222 PerlMem_free(tpl);
9223 PerlMem_free(unixified);
9224 PerlMem_free(unixwild);
a480973c
JM		 9225 return 0;
9226 }
f7ddb74a
JM		 9227 if (!decc_efs_case_preserve) {
9228 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9229 if (_tolower(*cp1) != _tolower(*cp2)) break;
9230 }
f86702cc 9231 segdirs = dirs - totells; /* Min # of dirs we must have left */
9232 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9233 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
18a3d61e 9234 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 9235 PerlMem_free(tpl);
9236 PerlMem_free(unixified);
9237 PerlMem_free(unixwild);
f86702cc 9238 return 1;
a3e9d8c9 9239 }
a3e9d8c9 9240 }
f86702cc 9241 /* First off, back up over constant elements at end of path */
9242 if (dirs) {
9243 for (front = end ; front >= base; front--)
9244 if (*front == '/' && !dirs--) { front++; break; }
a3e9d8c9 9245 }
c5375c28
JM		 9246 lcres = PerlMem_malloc(VMS_MAXRSS);
9247 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
a480973c
JM		 9248 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9249 cp1++,cp2++) {
9250 if (!decc_efs_case_preserve) {
9251 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9252 }
9253 else {
9254 *cp2 = *cp1;
9255 }
9256 }
9257 if (cp1 != '\0') {
367e4b85
JM		 9258 PerlMem_free(tpl);
9259 PerlMem_free(unixified);
9260 PerlMem_free(unixwild);
c5375c28 9261 PerlMem_free(lcres);
a480973c 9262 return 0; /* Path too long. */
f7ddb74a 9263 }
f86702cc 9264 lcend = cp2;
9265 *cp2 = '\0'; /* Pick up with memcpy later */
9266 lcfront = lcres + (front - base);
9267 /* Now skip over each ellipsis and try to match the path in front of it. */
9268 while (ells--) {
9269 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9270 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9271 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
9272 if (cp1 < template) break; /* template started with an ellipsis */
9273 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9274 ellipsis = cp1; continue;
9275 }
a480973c 9276 wilddsc.dsc$a_pointer = tpl;
f86702cc 9277 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9278 nextell = cp1;
9279 for (segdirs = 0, cp2 = tpl;
a480973c 9280 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
f86702cc 9281 cp1++, cp2++) {
9282 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
f7ddb74a
JM		 9283 else {
9284 if (!decc_efs_case_preserve) {
9285 *cp2 = _tolower(*cp1); /* else lowercase for match */
9286 }
9287 else {
9288 *cp2 = *cp1; /* else preserve case for match */
9289 }
9290 }
f86702cc 9291 if (*cp2 == '/') segdirs++;
9292 }
a480973c 9293 if (cp1 != ellipsis - 1) {
367e4b85
JM		 9294 PerlMem_free(tpl);
9295 PerlMem_free(unixified);
9296 PerlMem_free(unixwild);
9297 PerlMem_free(lcres);
a480973c
JM		 9298 return 0; /* Path too long */
9299 }
f86702cc 9300 /* Back up at least as many dirs as in template before matching */
9301 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9302 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9303 for (match = 0; cp1 > lcres;) {
9304 resdsc.dsc$a_pointer = cp1;
9305 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9306 match++;
9307 if (match == 1) lcfront = cp1;
9308 }
9309 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9310 }
a480973c 9311 if (!match) {
367e4b85
JM		 9312 PerlMem_free(tpl);
9313 PerlMem_free(unixified);
9314 PerlMem_free(unixwild);
9315 PerlMem_free(lcres);
a480973c
JM		 9316 return 0; /* Can't find prefix ??? */
9317 }
f86702cc 9318 if (match > 1 && opts & 1) {
9319 /* This ... wildcard could cover more than one set of dirs (i.e.
9320 * a set of similar dir names is repeated). If the template
9321 * contains more than 1 ..., upstream elements could resolve the
9322 * ambiguity, but it's not worth a full backtracking setup here.
9323 * As a quick heuristic, clip off the current default directory
9324 * if it's present to find the trimmed spec, else use the
9325 * shortest string that this ... could cover.
9326 */
9327 char def[NAM$C_MAXRSS+1], *st;
9328
a480973c
JM		 9329 if (getcwd(def, sizeof def,0) == NULL) {
9330 Safefree(unixified);
9331 Safefree(unixwild);
9332 Safefree(lcres);
9333 Safefree(tpl);
9334 return 0;
9335 }
f7ddb74a
JM		 9336 if (!decc_efs_case_preserve) {
9337 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9338 if (_tolower(*cp1) != _tolower(*cp2)) break;
9339 }
f86702cc 9340 segdirs = dirs - totells; /* Min # of dirs we must have left */
9341 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9342 if (*cp1 == '\0' && *cp2 == '/') {
18a3d61e 9343 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 9344 PerlMem_free(tpl);
9345 PerlMem_free(unixified);
9346 PerlMem_free(unixwild);
9347 PerlMem_free(lcres);
f86702cc 9348 return 1;
9349 }
9350 /* Nope -- stick with lcfront from above and keep going. */
9351 }
9352 }
18a3d61e 9353 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
367e4b85
JM		 9354 PerlMem_free(tpl);
9355 PerlMem_free(unixified);
9356 PerlMem_free(unixwild);
9357 PerlMem_free(lcres);
a3e9d8c9 9358 return 1;
f86702cc 9359 ellipsis = nextell;
a0d0e21e 9360 }
a0d0e21e
LW		 9361
9362} /* end of trim_unixpath() */
9363/*}}}*/
9364
a0d0e21e
LW		 9365
9366/*
9367 * VMS readdir() routines.
9368 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
a0d0e21e 9369 *
bd3fa61c 9370 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
a0d0e21e
LW		 9371 * Minor modifications to original routines.
9372 */
9373
a9852f7c
CB		 9374/* readdir may have been redefined by reentr.h, so make sure we get
9375 * the local version for what we do here.
9376 */
9377#ifdef readdir
9378# undef readdir
9379#endif
9380#if !defined(PERL_IMPLICIT_CONTEXT)
9381# define readdir Perl_readdir
9382#else
9383# define readdir(a) Perl_readdir(aTHX_ a)
9384#endif
9385
a0d0e21e
LW		 9386 /* Number of elements in vms_versions array */
9387#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
9388
9389/*
9390 * Open a directory, return a handle for later use.
9391 */
9392/*{{{ DIR *opendir(char*name) */
ddcbaa1c 9393DIR *
b8ffc8df 9394Perl_opendir(pTHX_ const char *name)
a0d0e21e 9395{
ddcbaa1c 9396 DIR *dd;
657054d4 9397 char *dir;
61bb5906 9398 Stat_t sb;
657054d4
JM		 9399
9400 Newx(dir, VMS_MAXRSS, char);
360732b5 9401 if (do_tovmspath(name,dir,0,NULL) == NULL) {
657054d4 9402 Safefree(dir);
61bb5906 9403 return NULL;
a0d0e21e 9404 }
ada67d10
CB		 9405 /* Check access before stat; otherwise stat does not
9406 * accurately report whether it's a directory.
9407 */
a1887106 9408 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
fac786e7 9409 /* cando_by_name has already set errno */
657054d4 9410 Safefree(dir);
ada67d10
CB		 9411 return NULL;
9412 }
61bb5906
CB		 9413 if (flex_stat(dir,&sb) == -1) return NULL;
9414 if (!S_ISDIR(sb.st_mode)) {
657054d4 9415 Safefree(dir);
61bb5906
CB		 9416 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
9417 return NULL;
9418 }
61bb5906 9419 /* Get memory for the handle, and the pattern. */
ddcbaa1c 9420 Newx(dd,1,DIR);
a02a5408 9421 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
a0d0e21e
LW		 9422
9423 /* Fill in the fields; mainly playing with the descriptor. */
f7ddb74a 9424 sprintf(dd->pattern, "%s*.*",dir);
657054d4 9425 Safefree(dir);
a0d0e21e
LW		 9426 dd->context = 0;
9427 dd->count = 0;
657054d4 9428 dd->flags = 0;
a096370a
CB		 9429 /* By saying we always want the result of readdir() in unix format, we
9430 * are really saying we want all the escapes removed. Otherwise the caller,
9431 * having no way to know whether it's already in VMS format, might send it
9432 * through tovmsspec again, thus double escaping.
9433 */
9434 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
a0d0e21e
LW		 9435 dd->pat.dsc$a_pointer = dd->pattern;
9436 dd->pat.dsc$w_length = strlen(dd->pattern);
9437 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9438 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3bc25146 9439#if defined(USE_ITHREADS)
a02a5408 9440 Newx(dd->mutex,1,perl_mutex);
a9852f7c
CB		 9441 MUTEX_INIT( (perl_mutex *) dd->mutex );
9442#else
9443 dd->mutex = NULL;
9444#endif
a0d0e21e
LW		 9445
9446 return dd;
9447} /* end of opendir() */
9448/*}}}*/
9449
9450/*
9451 * Set the flag to indicate we want versions or not.
9452 */
9453/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9454void
ddcbaa1c 9455vmsreaddirversions(DIR *dd, int flag)
a0d0e21e 9456{
657054d4
JM		 9457 if (flag)
9458 dd->flags |= PERL_VMSDIR_M_VERSIONS;
9459 else
9460 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
a0d0e21e
LW		 9461}
9462/*}}}*/
9463
9464/*
9465 * Free up an opened directory.
9466 */
9467/*{{{ void closedir(DIR *dd)*/
9468void
ddcbaa1c 9469Perl_closedir(DIR *dd)
a0d0e21e 9470{
f7ddb74a
JM		 9471 int sts;
9472
9473 sts = lib$find_file_end(&dd->context);
a0d0e21e 9474 Safefree(dd->pattern);
3bc25146 9475#if defined(USE_ITHREADS)
a9852f7c
CB		 9476 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9477 Safefree(dd->mutex);
9478#endif
f7ddb74a 9479 Safefree(dd);
a0d0e21e
LW		 9480}
9481/*}}}*/
9482
9483/*
9484 * Collect all the version numbers for the current file.
9485 */
9486static void
ddcbaa1c 9487collectversions(pTHX_ DIR *dd)
a0d0e21e
LW		 9488{
9489 struct dsc$descriptor_s pat;
9490 struct dsc$descriptor_s res;
ddcbaa1c 9491 struct dirent *e;
657054d4 9492 char *p, *text, *buff;
a0d0e21e
LW		 9493 int i;
9494 unsigned long context, tmpsts;
9495
9496 /* Convenient shorthand. */
9497 e = &dd->entry;
9498
9499 /* Add the version wildcard, ignoring the "*.*" put on before */
9500 i = strlen(dd->pattern);
a02a5408 9501 Newx(text,i + e->d_namlen + 3,char);
f7ddb74a
JM		 9502 strcpy(text, dd->pattern);
9503 sprintf(&text[i - 3], "%s;*", e->d_name);
a0d0e21e
LW		 9504
9505 /* Set up the pattern descriptor. */
9506 pat.dsc$a_pointer = text;
9507 pat.dsc$w_length = i + e->d_namlen - 1;
9508 pat.dsc$b_dtype = DSC$K_DTYPE_T;
9509 pat.dsc$b_class = DSC$K_CLASS_S;
9510
9511 /* Set up result descriptor. */
657054d4 9512 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 9513 res.dsc$a_pointer = buff;
657054d4 9514 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 9515 res.dsc$b_dtype = DSC$K_DTYPE_T;
9516 res.dsc$b_class = DSC$K_CLASS_S;
9517
9518 /* Read files, collecting versions. */
9519 for (context = 0, e->vms_verscount = 0;
9520 e->vms_verscount < VERSIZE(e);
9521 e->vms_verscount++) {
657054d4
JM		 9522 unsigned long rsts;
9523 unsigned long flags = 0;
9524
9525#ifdef VMS_LONGNAME_SUPPORT
988c775c 9526 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 9527#endif
9528 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
a0d0e21e 9529 if (tmpsts == RMS$_NMF || context == 0) break;
748a9306 9530 _ckvmssts(tmpsts);
657054d4 9531 buff[VMS_MAXRSS - 1] = '\0';
748a9306 9532 if ((p = strchr(buff, ';')))
a0d0e21e
LW		 9533 e->vms_versions[e->vms_verscount] = atoi(p + 1);
9534 else
9535 e->vms_versions[e->vms_verscount] = -1;
9536 }
9537
748a9306 9538 _ckvmssts(lib$find_file_end(&context));
a0d0e21e 9539 Safefree(text);
657054d4 9540 Safefree(buff);
a0d0e21e
LW		 9541
9542} /* end of collectversions() */
9543
9544/*
9545 * Read the next entry from the directory.
9546 */
9547/*{{{ struct dirent *readdir(DIR *dd)*/
ddcbaa1c
CB		 9548struct dirent *
9549Perl_readdir(pTHX_ DIR *dd)
a0d0e21e
LW		 9550{
9551 struct dsc$descriptor_s res;
657054d4 9552 char *p, *buff;
a0d0e21e 9553 unsigned long int tmpsts;
657054d4
JM		 9554 unsigned long rsts;
9555 unsigned long flags = 0;
dca5a913 9556 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
657054d4 9557 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e
LW		 9558
9559 /* Set up result descriptor, and get next file. */
657054d4 9560 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 9561 res.dsc$a_pointer = buff;
657054d4 9562 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 9563 res.dsc$b_dtype = DSC$K_DTYPE_T;
9564 res.dsc$b_class = DSC$K_CLASS_S;
657054d4
JM		 9565
9566#ifdef VMS_LONGNAME_SUPPORT
988c775c 9567 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 9568#endif
9569
9570 tmpsts = lib$find_file
9571 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
4633a7c4
LW		 9572 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
9573 if (!(tmpsts & 1)) {
9574 set_vaxc_errno(tmpsts);
9575 switch (tmpsts) {
9576 case RMS$_PRV:
c07a80fd 9577 set_errno(EACCES); break;
4633a7c4 9578 case RMS$_DEV:
c07a80fd 9579 set_errno(ENODEV); break;
4633a7c4 9580 case RMS$_DIR:
f282b18d
CB		 9581 set_errno(ENOTDIR); break;
9582 case RMS$_FNF: case RMS$_DNF:
c07a80fd 9583 set_errno(ENOENT); break;
4633a7c4
LW		 9584 default:
9585 set_errno(EVMSERR);
9586 }
657054d4 9587 Safefree(buff);
4633a7c4
LW		 9588 return NULL;
9589 }
9590 dd->count++;
a0d0e21e 9591 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
f7ddb74a 9592 if (!decc_efs_case_preserve) {
657054d4 9593 buff[VMS_MAXRSS - 1] = '\0';
f7ddb74a 9594 for (p = buff; *p; p++) *p = _tolower(*p);
f7ddb74a
JM		 9595 }
9596 else {
9597 /* we don't want to force to lowercase, just null terminate */
9598 buff[res.dsc$w_length] = '\0';
9599 }
f675dbe5 9600 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
a0d0e21e
LW		 9601 *p = '\0';
9602
9603 /* Skip any directory component and just copy the name. */
657054d4 9604 sts = vms_split_path
360732b5 9605 (buff,
657054d4
JM		 9606 &v_spec,
9607 &v_len,
9608 &r_spec,
9609 &r_len,
9610 &d_spec,
9611 &d_len,
9612 &n_spec,
9613 &n_len,
9614 &e_spec,
9615 &e_len,
9616 &vs_spec,
9617 &vs_len);
9618
dca5a913
JM		 9619 /* Drop NULL extensions on UNIX file specification */
9620 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9621 (e_len == 1) && decc_readdir_dropdotnotype)) {
9622 e_len = 0;
9623 e_spec[0] = '\0';
9624 }
9625
657054d4
JM		 9626 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9627 dd->entry.d_name[n_len + e_len] = '\0';
9628 dd->entry.d_namlen = strlen(dd->entry.d_name);
a0d0e21e 9629
657054d4
JM		 9630 /* Convert the filename to UNIX format if needed */
9631 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9632
9633 /* Translate the encoded characters. */
38a44b82 9634 /* Fixme: Unicode handling could result in embedded 0 characters */
657054d4
JM		 9635 if (strchr(dd->entry.d_name, '^') != NULL) {
9636 char new_name[256];
9637 char * q;
657054d4
JM		 9638 p = dd->entry.d_name;
9639 q = new_name;
9640 while (*p != 0) {
f617045b
CB		 9641 int inchars_read, outchars_added;
9642 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9643 p += inchars_read;
9644 q += outchars_added;
dca5a913 9645 /* fix-me */
f617045b 9646 /* if outchars_added > 1, then this is a wide file specification */
dca5a913 9647 /* Wide file specifications need to be passed in Perl */
38a44b82 9648 /* counted strings apparently with a Unicode flag */
657054d4
JM		 9649 }
9650 *q = 0;
9651 strcpy(dd->entry.d_name, new_name);
f617045b 9652 dd->entry.d_namlen = strlen(dd->entry.d_name);
657054d4 9653 }
657054d4 9654 }
a0d0e21e 9655
a0d0e21e 9656 dd->entry.vms_verscount = 0;
657054d4
JM		 9657 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9658 Safefree(buff);
a0d0e21e
LW		 9659 return &dd->entry;
9660
9661} /* end of readdir() */
9662/*}}}*/
9663
9664/*
a9852f7c
CB		 9665 * Read the next entry from the directory -- thread-safe version.
9666 */
9667/*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9668int
ddcbaa1c 9669Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
a9852f7c
CB		 9670{
9671 int retval;
9672
9673 MUTEX_LOCK( (perl_mutex *) dd->mutex );
9674
7ded3206 9675 entry = readdir(dd);
a9852f7c
CB		 9676 *result = entry;
9677 retval = ( *result == NULL ? errno : 0 );
9678
9679 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9680
9681 return retval;
9682
9683} /* end of readdir_r() */
9684/*}}}*/
9685
9686/*
a0d0e21e
LW		 9687 * Return something that can be used in a seekdir later.
9688 */
9689/*{{{ long telldir(DIR *dd)*/
9690long
ddcbaa1c 9691Perl_telldir(DIR *dd)
a0d0e21e
LW		 9692{
9693 return dd->count;
9694}
9695/*}}}*/
9696
9697/*
9698 * Return to a spot where we used to be. Brute force.
9699 */
9700/*{{{ void seekdir(DIR *dd,long count)*/
9701void
ddcbaa1c 9702Perl_seekdir(pTHX_ DIR *dd, long count)
a0d0e21e 9703{
657054d4 9704 int old_flags;
a0d0e21e
LW		 9705
9706 /* If we haven't done anything yet... */
9707 if (dd->count == 0)
9708 return;
9709
9710 /* Remember some state, and clear it. */
657054d4
JM		 9711 old_flags = dd->flags;
9712 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
748a9306 9713 _ckvmssts(lib$find_file_end(&dd->context));
a0d0e21e
LW		 9714 dd->context = 0;
9715
9716 /* The increment is in readdir(). */
9717 for (dd->count = 0; dd->count < count; )
f7ddb74a 9718 readdir(dd);
a0d0e21e 9719
657054d4 9720 dd->flags = old_flags;
a0d0e21e
LW		 9721
9722} /* end of seekdir() */
9723/*}}}*/
9724
9725/* VMS subprocess management
9726 *
9727 * my_vfork() - just a vfork(), after setting a flag to record that
9728 * the current script is trying a Unix-style fork/exec.
9729 *
9730 * vms_do_aexec() and vms_do_exec() are called in response to the
9731 * perl 'exec' function. If this follows a vfork call, then they
a6d05634 9732 * call out the regular perl routines in doio.c which do an
a0d0e21e
LW		 9733 * execvp (for those who really want to try this under VMS).
9734 * Otherwise, they do exactly what the perl docs say exec should
9735 * do - terminate the current script and invoke a new command
9736 * (See below for notes on command syntax.)
9737 *
9738 * do_aspawn() and do_spawn() implement the VMS side of the perl
9739 * 'system' function.
9740 *
9741 * Note on command arguments to perl 'exec' and 'system': When handled
9742 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
eed5d6a1
CB		 9743 * are concatenated to form a DCL command string. If the first non-numeric
9744 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
a6d05634 9745 * the command string is handed off to DCL directly. Otherwise,
a0d0e21e
LW		 9746 * the first token of the command is taken as the filespec of an image
9747 * to run. The filespec is expanded using a default type of '.EXE' and
3eeba6fb 9748 * the process defaults for device, directory, etc., and if found, the resultant
a0d0e21e 9749 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3eeba6fb 9750 * the command string as parameters. This is perhaps a bit complicated,
a0d0e21e
LW		 9751 * but I hope it will form a happy medium between what VMS folks expect
9752 * from lib$spawn and what Unix folks expect from exec.
9753 */
9754
9755static int vfork_called;
9756
9757/*{{{int my_vfork()*/
9758int
9759my_vfork()
9760{
748a9306 9761 vfork_called++;
a0d0e21e
LW		 9762 return vfork();
9763}
9764/*}}}*/
9765
4633a7c4 9766
a0d0e21e 9767static void
218fdd94
CL		 9768vms_execfree(struct dsc$descriptor_s *vmscmd)
9769{
9770 if (vmscmd) {
9771 if (vmscmd->dsc$a_pointer) {
c5375c28 9772 PerlMem_free(vmscmd->dsc$a_pointer);
218fdd94 9773 }
c5375c28 9774 PerlMem_free(vmscmd);
4633a7c4
LW		 9775 }
9776}
9777
9778static char *
fd8cd3a3 9779setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
a0d0e21e 9780{
4633a7c4 9781 char *junk, *tmps = Nullch;
a0d0e21e
LW		 9782 register size_t cmdlen = 0;
9783 size_t rlen;
9784 register SV **idx;
2d8e6c8d 9785 STRLEN n_a;
a0d0e21e
LW		 9786
9787 idx = mark;
4633a7c4
LW		 9788 if (really) {
9789 tmps = SvPV(really,rlen);
9790 if (*tmps) {
9791 cmdlen += rlen + 1;
9792 idx++;
9793 }
a0d0e21e
LW		 9794 }
9795
9796 for (idx++; idx <= sp; idx++) {
9797 if (*idx) {
9798 junk = SvPVx(*idx,rlen);
9799 cmdlen += rlen ? rlen + 1 : 0;
9800 }
9801 }
c5375c28 9802 Newx(PL_Cmd, cmdlen+1, char);
a0d0e21e 9803
4633a7c4 9804 if (tmps && *tmps) {
6b88bc9c 9805 strcpy(PL_Cmd,tmps);
a0d0e21e
LW		 9806 mark++;
9807 }
6b88bc9c 9808 else *PL_Cmd = '\0';
a0d0e21e
LW		 9809 while (++mark <= sp) {
9810 if (*mark) {
3eeba6fb
CB		 9811 char *s = SvPVx(*mark,n_a);
9812 if (!*s) continue;
9813 if (*PL_Cmd) strcat(PL_Cmd," ");
9814 strcat(PL_Cmd,s);
a0d0e21e
LW		 9815 }
9816 }
6b88bc9c 9817 return PL_Cmd;
a0d0e21e
LW		 9818
9819} /* end of setup_argstr() */
9820
4633a7c4 9821
a0d0e21e 9822static unsigned long int
2fbb330f 9823setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
218fdd94 9824 struct dsc$descriptor_s **pvmscmd)
a0d0e21e 9825{
aa779de1 9826 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
e886094b
JM		 9827 char image_name[NAM$C_MAXRSS+1];
9828 char image_argv[NAM$C_MAXRSS+1];
a0d0e21e 9829 $DESCRIPTOR(defdsc,".EXE");
8012a33e 9830 $DESCRIPTOR(defdsc2,".");
a0d0e21e 9831 $DESCRIPTOR(resdsc,resspec);
218fdd94 9832 struct dsc$descriptor_s *vmscmd;
a0d0e21e 9833 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3eeba6fb 9834 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
aa779de1 9835 register char *s, *rest, *cp, *wordbreak;
2fbb330f
JM		 9836 char * cmd;
9837 int cmdlen;
aa779de1 9838 register int isdcl;
a0d0e21e 9839
c5375c28
JM		 9840 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9841 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
2fbb330f
JM		 9842
9843 /* Make a copy for modification */
9844 cmdlen = strlen(incmd);
c5375c28
JM		 9845 cmd = PerlMem_malloc(cmdlen+1);
9846 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
2fbb330f
JM		 9847 strncpy(cmd, incmd, cmdlen);
9848 cmd[cmdlen] = 0;
e886094b
JM		 9849 image_name[0] = 0;
9850 image_argv[0] = 0;
2fbb330f 9851
218fdd94
CL		 9852 vmscmd->dsc$a_pointer = NULL;
9853 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
9854 vmscmd->dsc$b_class = DSC$K_CLASS_S;
9855 vmscmd->dsc$w_length = 0;
9856 if (pvmscmd) *pvmscmd = vmscmd;
9857
ff7adb52
CL		 9858 if (suggest_quote) *suggest_quote = 0;
9859
2fbb330f 9860 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
c5375c28 9861 PerlMem_free(cmd);
a2669cfc 9862 return CLI$_BUFOVF; /* continuation lines currently unsupported */
2fbb330f
JM		 9863 }
9864
a0d0e21e 9865 s = cmd;
2fbb330f 9866
a0d0e21e 9867 while (*s && isspace(*s)) s++;
aa779de1
CB		 9868
9869 if (*s == '@' || *s == '$') {
9870 vmsspec[0] = *s; rest = s + 1;
9871 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9872 }
9873 else { cp = vmsspec; rest = s; }
9874 if (*rest == '.' || *rest == '/') {
9875 char *cp2;
9876 for (cp2 = resspec;
9877 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9878 rest++, cp2++) *cp2 = *rest;
9879 *cp2 = '\0';
360732b5 9880 if (do_tovmsspec(resspec,cp,0,NULL)) {
aa779de1
CB		 9881 s = vmsspec;
9882 if (*rest) {
9883 for (cp2 = vmsspec + strlen(vmsspec);
9884 *rest && cp2 - vmsspec < sizeof vmsspec;
9885 rest++, cp2++) *cp2 = *rest;
9886 *cp2 = '\0';
a0d0e21e
LW		 9887 }
9888 }
9889 }
aa779de1
CB		 9890 /* Intuit whether verb (first word of cmd) is a DCL command:
9891 * - if first nonspace char is '@', it's a DCL indirection
9892 * otherwise
9893 * - if verb contains a filespec separator, it's not a DCL command
9894 * - if it doesn't, caller tells us whether to default to a DCL
9895 * command, or to a local image unless told it's DCL (by leading '$')
9896 */
ff7adb52
CL		 9897 if (*s == '@') {
9898 isdcl = 1;
9899 if (suggest_quote) *suggest_quote = 1;
9900 } else {
aa779de1
CB		 9901 register char *filespec = strpbrk(s,":<[.;");
9902 rest = wordbreak = strpbrk(s," \"\t/");
9903 if (!wordbreak) wordbreak = s + strlen(s);
9904 if (*s == '$') check_img = 0;
9905 if (filespec && (filespec < wordbreak)) isdcl = 0;
9906 else isdcl = !check_img;
9907 }
9908
3eeba6fb 9909 if (!isdcl) {
dca5a913 9910 int rsts;
aa779de1
CB		 9911 imgdsc.dsc$a_pointer = s;
9912 imgdsc.dsc$w_length = wordbreak - s;
dca5a913 9913 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8012a33e
CB		 9914 if (!(retsts&1)) {
9915 _ckvmssts(lib$find_file_end(&cxt));
dca5a913 9916 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f
JM		 9917 if (!(retsts & 1) && *s == '$') {
9918 _ckvmssts(lib$find_file_end(&cxt));
9919 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
dca5a913 9920 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
2497a41f
JM		 9921 if (!(retsts&1)) {
9922 _ckvmssts(lib$find_file_end(&cxt));
dca5a913 9923 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f
JM		 9924 }
9925 }
aa779de1 9926 }
8012a33e
CB		 9927 _ckvmssts(lib$find_file_end(&cxt));
9928
aa779de1 9929 if (retsts & 1) {
8012a33e 9930 FILE *fp;
a0d0e21e
LW		 9931 s = resspec;
9932 while (*s && !isspace(*s)) s++;
9933 *s = '\0';
8012a33e
CB		 9934
9935 /* check that it's really not DCL with no file extension */
e886094b 9936 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8012a33e 9937 if (fp) {
2497a41f
JM		 9938 char b[256] = {0,0,0,0};
9939 read(fileno(fp), b, 256);
8012a33e 9940 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
2497a41f 9941 if (isdcl) {
e886094b
JM		 9942 int shebang_len;
9943
2497a41f 9944 /* Check for script */
e886094b
JM		 9945 shebang_len = 0;
9946 if ((b[0] == '#') && (b[1] == '!'))
9947 shebang_len = 2;
9948#ifdef ALTERNATE_SHEBANG
9949 else {
9950 shebang_len = strlen(ALTERNATE_SHEBANG);
9951 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9952 char * perlstr;
9953 perlstr = strstr("perl",b);
9954 if (perlstr == NULL)
9955 shebang_len = 0;
9956 }
9957 else
9958 shebang_len = 0;
9959 }
9960#endif
9961
9962 if (shebang_len > 0) {
9963 int i;
9964 int j;
9965 char tmpspec[NAM$C_MAXRSS + 1];
9966
9967 i = shebang_len;
9968 /* Image is following after white space */
9969 /*--------------------------------------*/
9970 while (isprint(b[i]) && isspace(b[i]))
9971 i++;
9972
9973 j = 0;
9974 while (isprint(b[i]) && !isspace(b[i])) {
9975 tmpspec[j++] = b[i++];
9976 if (j >= NAM$C_MAXRSS)
9977 break;
9978 }
9979 tmpspec[j] = '\0';
9980
9981 /* There may be some default parameters to the image */
9982 /*---------------------------------------------------*/
9983 j = 0;
9984 while (isprint(b[i])) {
9985 image_argv[j++] = b[i++];
9986 if (j >= NAM$C_MAXRSS)
9987 break;
9988 }
9989 while ((j > 0) && !isprint(image_argv[j-1]))
9990 j--;
9991 image_argv[j] = 0;
9992
2497a41f 9993 /* It will need to be converted to VMS format and validated */
e886094b
JM		 9994 if (tmpspec[0] != '\0') {
9995 char * iname;
9996
9997 /* Try to find the exact program requested to be run */
9998 /*---------------------------------------------------*/
9999 iname = do_rmsexpand
360732b5
JM		 10000 (tmpspec, image_name, 0, ".exe",
10001 PERL_RMSEXPAND_M_VMS, NULL, NULL);
e886094b 10002 if (iname != NULL) {
a1887106
JM		 10003 if (cando_by_name_int
10004 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 10005 /* MCR prefix needed */
10006 isdcl = 0;
10007 }
10008 else {
10009 /* Try again with a null type */
10010 /*----------------------------*/
10011 iname = do_rmsexpand
360732b5
JM		 10012 (tmpspec, image_name, 0, ".",
10013 PERL_RMSEXPAND_M_VMS, NULL, NULL);
e886094b 10014 if (iname != NULL) {
a1887106
JM		 10015 if (cando_by_name_int
10016 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 10017 /* MCR prefix needed */
10018 isdcl = 0;
10019 }
10020 }
10021 }
10022
10023 /* Did we find the image to run the script? */
10024 /*------------------------------------------*/
10025 if (isdcl) {
10026 char *tchr;
10027
10028 /* Assume DCL or foreign command exists */
10029 /*--------------------------------------*/
10030 tchr = strrchr(tmpspec, '/');
10031 if (tchr != NULL) {
10032 tchr++;
10033 }
10034 else {
10035 tchr = tmpspec;
10036 }
10037 strcpy(image_name, tchr);
10038 }
10039 }
10040 }
2497a41f
JM		 10041 }
10042 }
8012a33e
CB		 10043 fclose(fp);
10044 }
10045 if (check_img && isdcl) return RMS$_FNF;
10046
3eeba6fb 10047 if (cando_by_name(S_IXUSR,0,resspec)) {
c5375c28
JM		 10048 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10049 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
8012a33e 10050 if (!isdcl) {
218fdd94 10051 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
e886094b
JM		 10052 if (image_name[0] != 0) {
10053 strcat(vmscmd->dsc$a_pointer, image_name);
10054 strcat(vmscmd->dsc$a_pointer, " ");
10055 }
10056 } else if (image_name[0] != 0) {
10057 strcpy(vmscmd->dsc$a_pointer, image_name);
10058 strcat(vmscmd->dsc$a_pointer, " ");
8012a33e 10059 } else {
218fdd94 10060 strcpy(vmscmd->dsc$a_pointer,"@");
8012a33e 10061 }
e886094b
JM		 10062 if (suggest_quote) *suggest_quote = 1;
10063
10064 /* If there is an image name, use original command */
10065 if (image_name[0] == 0)
10066 strcat(vmscmd->dsc$a_pointer,resspec);
10067 else {
10068 rest = cmd;
10069 while (*rest && isspace(*rest)) rest++;
10070 }
10071
10072 if (image_argv[0] != 0) {
10073 strcat(vmscmd->dsc$a_pointer,image_argv);
10074 strcat(vmscmd->dsc$a_pointer, " ");
10075 }
10076 if (rest) {
10077 int rest_len;
10078 int vmscmd_len;
10079
10080 rest_len = strlen(rest);
10081 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10082 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10083 strcat(vmscmd->dsc$a_pointer,rest);
10084 else
10085 retsts = CLI$_BUFOVF;
10086 }
218fdd94 10087 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
c5375c28 10088 PerlMem_free(cmd);
218fdd94 10089 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
3eeba6fb 10090 }
c5375c28
JM		 10091 else
10092 retsts = RMS$_PRV;
a0d0e21e
LW		 10093 }
10094 }
3eeba6fb 10095 /* It's either a DCL command or we couldn't find a suitable image */
218fdd94 10096 vmscmd->dsc$w_length = strlen(cmd);
ff7adb52 10097
b011c7bd 10098 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
c5375c28 10099 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
b011c7bd 10100 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
c5375c28
JM		 10101
10102 PerlMem_free(cmd);
2fbb330f 10103
ff7adb52
CL		 10104 /* check if it's a symbol (for quoting purposes) */
10105 if (suggest_quote && !*suggest_quote) {
10106 int iss;
10107 char equiv[LNM$C_NAMLENGTH];
10108 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10109 eqvdsc.dsc$a_pointer = equiv;
10110
218fdd94 10111 iss = lib$get_symbol(vmscmd,&eqvdsc);
ff7adb52
CL		 10112 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10113 }
3eeba6fb
CB		 10114 if (!(retsts & 1)) {
10115 /* just hand off status values likely to be due to user error */
10116 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10117 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10118 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10119 else { _ckvmssts(retsts); }
10120 }
a0d0e21e 10121
218fdd94 10122 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
a3e9d8c9 10123
a0d0e21e
LW		 10124} /* end of setup_cmddsc() */
10125
a3e9d8c9 10126
a0d0e21e
LW		 10127/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10128bool
fd8cd3a3 10129Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
a0d0e21e 10130{
c5375c28
JM		 10131bool exec_sts;
10132char * cmd;
10133
a0d0e21e
LW		 10134 if (sp > mark) {
10135 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 10136 vfork_called--;
10137 if (vfork_called < 0) {
5c84aa53 10138 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 10139 vfork_called = 0;
10140 }
10141 else return do_aexec(really,mark,sp);
a0d0e21e 10142 }
4633a7c4 10143 /* no vfork - act VMSish */
c5375c28
JM		 10144 cmd = setup_argstr(aTHX_ really,mark,sp);
10145 exec_sts = vms_do_exec(cmd);
10146 Safefree(cmd); /* Clean up from setup_argstr() */
10147 return exec_sts;
a0d0e21e
LW		 10148 }
10149
10150 return FALSE;
10151} /* end of vms_do_aexec() */
10152/*}}}*/
10153
10154/* {{{bool vms_do_exec(char *cmd) */
10155bool
2fbb330f 10156Perl_vms_do_exec(pTHX_ const char *cmd)
a0d0e21e 10157{
218fdd94 10158 struct dsc$descriptor_s *vmscmd;
a0d0e21e
LW		 10159
10160 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 10161 vfork_called--;
10162 if (vfork_called < 0) {
5c84aa53 10163 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 10164 vfork_called = 0;
10165 }
10166 else return do_exec(cmd);
a0d0e21e 10167 }
748a9306
LW		 10168
10169 { /* no vfork - act VMSish */
748a9306 10170 unsigned long int retsts;
a0d0e21e 10171
1e422769 10172 TAINT_ENV();
10173 TAINT_PROPER("exec");
218fdd94
CL		 10174 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10175 retsts = lib$do_command(vmscmd);
a0d0e21e 10176
09b7f37c 10177 switch (retsts) {
f282b18d 10178 case RMS$_FNF: case RMS$_DNF:
09b7f37c 10179 set_errno(ENOENT); break;
f282b18d 10180 case RMS$_DIR:
09b7f37c 10181 set_errno(ENOTDIR); break;
f282b18d
CB		 10182 case RMS$_DEV:
10183 set_errno(ENODEV); break;
09b7f37c
CB		 10184 case RMS$_PRV:
10185 set_errno(EACCES); break;
10186 case RMS$_SYN:
10187 set_errno(EINVAL); break;
a2669cfc 10188 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
09b7f37c
CB		 10189 set_errno(E2BIG); break;
10190 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10191 _ckvmssts(retsts); /* fall through */
10192 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10193 set_errno(EVMSERR);
10194 }
748a9306 10195 set_vaxc_errno(retsts);
3eeba6fb 10196 if (ckWARN(WARN_EXEC)) {
f98bc0c6 10197 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
218fdd94 10198 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
3eeba6fb 10199 }
218fdd94 10200 vms_execfree(vmscmd);
a0d0e21e
LW		 10201 }
10202
10203 return FALSE;
10204
10205} /* end of vms_do_exec() */
10206/*}}}*/
10207
2fbb330f 10208unsigned long int Perl_do_spawn(pTHX_ const char *);
eed5d6a1 10209unsigned long int do_spawn2(pTHX_ const char *, int);
a0d0e21e 10210
61bb5906 10211/* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
a0d0e21e 10212unsigned long int
fd8cd3a3 10213Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
a0d0e21e 10214{
c5375c28
JM		 10215unsigned long int sts;
10216char * cmd;
eed5d6a1 10217int flags = 0;
a0d0e21e 10218
c5375c28 10219 if (sp > mark) {
eed5d6a1
CB		 10220
10221 /* We'll copy the (undocumented?) Win32 behavior and allow a
10222 * numeric first argument. But the only value we'll support
10223 * through do_aspawn is a value of 1, which means spawn without
10224 * waiting for completion -- other values are ignored.
10225 */
10226 if (SvNIOKp(*((SV**)mark+1)) && !SvPOKp(*((SV**)mark+1))) {
10227 ++mark;
10228 flags = SvIVx(*(SV**)mark);
10229 }
10230
10231 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
10232 flags = CLI$M_NOWAIT;
10233 else
10234 flags = 0;
10235
c5375c28 10236 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
eed5d6a1 10237 sts = do_spawn2(aTHX_ cmd, flags);
c5375c28
JM		 10238 /* pp_sys will clean up cmd */
10239 return sts;
10240 }
a0d0e21e
LW		 10241 return SS$_ABORT;
10242} /* end of do_aspawn() */
10243/*}}}*/
10244
eed5d6a1 10245
a0d0e21e
LW		 10246/* {{{unsigned long int do_spawn(char *cmd) */
10247unsigned long int
2fbb330f 10248Perl_do_spawn(pTHX_ const char *cmd)
a0d0e21e 10249{
eed5d6a1
CB		 10250 return do_spawn2(aTHX_ cmd, 0);
10251}
10252/*}}}*/
10253
10254/* {{{unsigned long int do_spawn2(char *cmd) */
10255unsigned long int
10256do_spawn2(pTHX_ const char *cmd, int flags)
10257{
209030df 10258 unsigned long int sts, substs;
a0d0e21e 10259
c5375c28
JM		 10260 /* The caller of this routine expects to Safefree(PL_Cmd) */
10261 Newx(PL_Cmd,10,char);
10262
1e422769 10263 TAINT_ENV();
10264 TAINT_PROPER("spawn");
748a9306 10265 if (!cmd || !*cmd) {
eed5d6a1 10266 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
c8795d8b
JH		 10267 if (!(sts & 1)) {
10268 switch (sts) {
209030df
JH		 10269 case RMS$_FNF: case RMS$_DNF:
10270 set_errno(ENOENT); break;
10271 case RMS$_DIR:
10272 set_errno(ENOTDIR); break;
10273 case RMS$_DEV:
10274 set_errno(ENODEV); break;
10275 case RMS$_PRV:
10276 set_errno(EACCES); break;
10277 case RMS$_SYN:
10278 set_errno(EINVAL); break;
10279 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10280 set_errno(E2BIG); break;
10281 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10282 _ckvmssts(sts); /* fall through */
10283 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10284 set_errno(EVMSERR);
c8795d8b
JH		 10285 }
10286 set_vaxc_errno(sts);
10287 if (ckWARN(WARN_EXEC)) {
f98bc0c6 10288 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
c8795d8b
JH		 10289 Strerror(errno));
10290 }
09b7f37c 10291 }
c8795d8b 10292 sts = substs;
48023aa8
CL		 10293 }
10294 else {
eed5d6a1 10295 char mode[3];
2fbb330f 10296 PerlIO * fp;
eed5d6a1
CB		 10297 if (flags & CLI$M_NOWAIT)
10298 strcpy(mode, "n");
10299 else
10300 strcpy(mode, "nW");
10301
10302 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
2fbb330f
JM		 10303 if (fp != NULL)
10304 my_pclose(fp);
eed5d6a1 10305 /* sts will be the pid in the nowait case */
48023aa8 10306 }
48023aa8 10307 return sts;
eed5d6a1 10308} /* end of do_spawn2() */
a0d0e21e
LW		 10309/*}}}*/
10310
bc10a425
CB		 10311
10312static unsigned int *sockflags, sockflagsize;
10313
10314/*
10315 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10316 * routines found in some versions of the CRTL can't deal with sockets.
10317 * We don't shim the other file open routines since a socket isn't
10318 * likely to be opened by a name.
10319 */
275feba9
CB		 10320/*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10321FILE *my_fdopen(int fd, const char *mode)
bc10a425 10322{
f7ddb74a 10323 FILE *fp = fdopen(fd, mode);
bc10a425
CB		 10324
10325 if (fp) {
10326 unsigned int fdoff = fd / sizeof(unsigned int);
2497a41f 10327 Stat_t sbuf; /* native stat; we don't need flex_stat */
bc10a425
CB		 10328 if (!sockflagsize || fdoff > sockflagsize) {
10329 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
a02a5408 10330 else Newx (sockflags,fdoff+2,unsigned int);
bc10a425
CB		 10331 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10332 sockflagsize = fdoff + 2;
10333 }
2497a41f 10334 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
bc10a425
CB		 10335 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10336 }
10337 return fp;
10338
10339}
10340/*}}}*/
10341
10342
10343/*
10344 * Clear the corresponding bit when the (possibly) socket stream is closed.
10345 * There still a small hole: we miss an implicit close which might occur
10346 * via freopen(). >> Todo
10347 */
10348/*{{{ int my_fclose(FILE *fp)*/
10349int my_fclose(FILE *fp) {
10350 if (fp) {
10351 unsigned int fd = fileno(fp);
10352 unsigned int fdoff = fd / sizeof(unsigned int);
10353
10354 if (sockflagsize && fdoff <= sockflagsize)
10355 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10356 }
10357 return fclose(fp);
10358}
10359/*}}}*/
10360
10361
a0d0e21e
LW		 10362/*
10363 * A simple fwrite replacement which outputs itmsz*nitm chars without
10364 * introducing record boundaries every itmsz chars.
22d4bb9c
CB		 10365 * We are using fputs, which depends on a terminating null. We may
10366 * well be writing binary data, so we need to accommodate not only
10367 * data with nulls sprinkled in the middle but also data with no null
10368 * byte at the end.
a0d0e21e 10369 */
a15cef0c 10370/*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
a0d0e21e 10371int
a15cef0c 10372my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
a0d0e21e 10373{
22d4bb9c 10374 register char *cp, *end, *cpd, *data;
bc10a425
CB		 10375 register unsigned int fd = fileno(dest);
10376 register unsigned int fdoff = fd / sizeof(unsigned int);
22d4bb9c 10377 int retval;
bc10a425
CB		 10378 int bufsize = itmsz * nitm + 1;
10379
10380 if (fdoff < sockflagsize &&
10381 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10382 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10383 return nitm;
10384 }
22d4bb9c 10385
bc10a425 10386 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
22d4bb9c
CB		 10387 memcpy( data, src, itmsz*nitm );
10388 data[itmsz*nitm] = '\0';
a0d0e21e 10389
22d4bb9c
CB		 10390 end = data + itmsz * nitm;
10391 retval = (int) nitm; /* on success return # items written */
a0d0e21e 10392
22d4bb9c
CB		 10393 cpd = data;
10394 while (cpd <= end) {
10395 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10396 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
a0d0e21e 10397 if (cp < end)
22d4bb9c
CB		 10398 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10399 cpd = cp + 1;
a0d0e21e
LW		 10400 }
10401
bc10a425 10402 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
22d4bb9c 10403 return retval;
a0d0e21e
LW		 10404
10405} /* end of my_fwrite() */
10406/*}}}*/
10407
d27fe803
JH		 10408/*{{{ int my_flush(FILE *fp)*/
10409int
fd8cd3a3 10410Perl_my_flush(pTHX_ FILE *fp)
d27fe803
JH		 10411{
10412 int res;
93948341 10413 if ((res = fflush(fp)) == 0 && fp) {
d27fe803 10414#ifdef VMS_DO_SOCKETS
61bb5906 10415 Stat_t s;
d27fe803
JH		 10416 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
10417#endif
10418 res = fsync(fileno(fp));
10419 }
22d4bb9c
CB		 10420/*
10421 * If the flush succeeded but set end-of-file, we need to clear
10422 * the error because our caller may check ferror(). BTW, this
10423 * probably means we just flushed an empty file.
10424 */
10425 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10426
d27fe803
JH		 10427 return res;
10428}
10429/*}}}*/
10430
748a9306
LW		 10431/*
10432 * Here are replacements for the following Unix routines in the VMS environment:
10433 * getpwuid Get information for a particular UIC or UID
10434 * getpwnam Get information for a named user
10435 * getpwent Get information for each user in the rights database
10436 * setpwent Reset search to the start of the rights database
10437 * endpwent Finish searching for users in the rights database
10438 *
10439 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10440 * (defined in pwd.h), which contains the following fields:-
10441 * struct passwd {
10442 * char *pw_name; Username (in lower case)
10443 * char *pw_passwd; Hashed password
10444 * unsigned int pw_uid; UIC
10445 * unsigned int pw_gid; UIC group number
10446 * char *pw_unixdir; Default device/directory (VMS-style)
10447 * char *pw_gecos; Owner name
10448 * char *pw_dir; Default device/directory (Unix-style)
10449 * char *pw_shell; Default CLI name (eg. DCL)
10450 * };
10451 * If the specified user does not exist, getpwuid and getpwnam return NULL.
10452 *
10453 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10454 * not the UIC member number (eg. what's returned by getuid()),
10455 * getpwuid() can accept either as input (if uid is specified, the caller's
10456 * UIC group is used), though it won't recognise gid=0.
10457 *
10458 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10459 * information about other users in your group or in other groups, respectively.
10460 * If the required privilege is not available, then these routines fill only
10461 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10462 * string).
10463 *
10464 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10465 */
10466
10467/* sizes of various UAF record fields */
10468#define UAI$S_USERNAME 12
10469#define UAI$S_IDENT 31
10470#define UAI$S_OWNER 31
10471#define UAI$S_DEFDEV 31
10472#define UAI$S_DEFDIR 63
10473#define UAI$S_DEFCLI 31
10474#define UAI$S_PWD 8
10475
10476#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
10477 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10478 (uic).uic$v_group != UIC$K_WILD_GROUP)
10479
4633a7c4
LW		 10480static char __empty[]= "";
10481static struct passwd __passwd_empty=
748a9306
LW		 10482 {(char *) __empty, (char *) __empty, 0, 0,
10483 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10484static int contxt= 0;
10485static struct passwd __pwdcache;
10486static char __pw_namecache[UAI$S_IDENT+1];
10487
748a9306
LW		 10488/*
10489 * This routine does most of the work extracting the user information.
10490 */
fd8cd3a3 10491static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
a0d0e21e 10492{
748a9306
LW		 10493 static struct {
10494 unsigned char length;
10495 char pw_gecos[UAI$S_OWNER+1];
10496 } owner;
10497 static union uicdef uic;
10498 static struct {
10499 unsigned char length;
10500 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10501 } defdev;
10502 static struct {
10503 unsigned char length;
10504 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10505 } defdir;
10506 static struct {
10507 unsigned char length;
10508 char pw_shell[UAI$S_DEFCLI+1];
10509 } defcli;
10510 static char pw_passwd[UAI$S_PWD+1];
10511
10512 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10513 struct dsc$descriptor_s name_desc;
c07a80fd 10514 unsigned long int sts;
748a9306 10515
4633a7c4 10516 static struct itmlst_3 itmlst[]= {
748a9306
LW		 10517 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
10518 {sizeof(uic), UAI$_UIC, &uic, &luic},
10519 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
10520 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
10521 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
10522 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
10523 {0, 0, NULL, NULL}};
10524
10525 name_desc.dsc$w_length= strlen(name);
10526 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10527 name_desc.dsc$b_class= DSC$K_CLASS_S;
f7ddb74a 10528 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
748a9306
LW		 10529
10530/* Note that sys$getuai returns many fields as counted strings. */
c07a80fd 10531 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10532 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10533 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10534 }
10535 else { _ckvmssts(sts); }
10536 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
748a9306
LW		 10537
10538 if ((int) owner.length < lowner) lowner= (int) owner.length;
10539 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10540 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10541 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10542 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10543 owner.pw_gecos[lowner]= '\0';
10544 defdev.pw_dir[ldefdev+ldefdir]= '\0';
10545 defcli.pw_shell[ldefcli]= '\0';
10546 if (valid_uic(uic)) {
10547 pwd->pw_uid= uic.uic$l_uic;
10548 pwd->pw_gid= uic.uic$v_group;
10549 }
10550 else
5c84aa53 10551 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
748a9306
LW		 10552 pwd->pw_passwd= pw_passwd;
10553 pwd->pw_gecos= owner.pw_gecos;
10554 pwd->pw_dir= defdev.pw_dir;
360732b5 10555 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
748a9306
LW		 10556 pwd->pw_shell= defcli.pw_shell;
10557 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10558 int ldir;
10559 ldir= strlen(pwd->pw_unixdir) - 1;
10560 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10561 }
10562 else
10563 strcpy(pwd->pw_unixdir, pwd->pw_dir);
f7ddb74a
JM		 10564 if (!decc_efs_case_preserve)
10565 __mystrtolower(pwd->pw_unixdir);
c07a80fd 10566 return 1;
a0d0e21e 10567}
748a9306
LW		 10568
10569/*
10570 * Get information for a named user.
10571*/
10572/*{{{struct passwd *getpwnam(char *name)*/
2fbb330f 10573struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
748a9306
LW		 10574{
10575 struct dsc$descriptor_s name_desc;
10576 union uicdef uic;
aa689395 10577 unsigned long int status, sts;
748a9306
LW		 10578
10579 __pwdcache = __passwd_empty;
fd8cd3a3 10580 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
748a9306
LW		 10581 /* We still may be able to determine pw_uid and pw_gid */
10582 name_desc.dsc$w_length= strlen(name);
10583 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10584 name_desc.dsc$b_class= DSC$K_CLASS_S;
10585 name_desc.dsc$a_pointer= (char *) name;
aa689395 10586 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
748a9306
LW		 10587 __pwdcache.pw_uid= uic.uic$l_uic;
10588 __pwdcache.pw_gid= uic.uic$v_group;
10589 }
c07a80fd 10590 else {
aa689395 10591 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10592 set_vaxc_errno(sts);
10593 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
c07a80fd 10594 return NULL;
10595 }
aa689395 10596 else { _ckvmssts(sts); }
c07a80fd 10597 }
748a9306 10598 }
748a9306
LW		 10599 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10600 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10601 __pwdcache.pw_name= __pw_namecache;
10602 return &__pwdcache;
10603} /* end of my_getpwnam() */
a0d0e21e
LW		 10604/*}}}*/
10605
748a9306
LW		 10606/*
10607 * Get information for a particular UIC or UID.
10608 * Called by my_getpwent with uid=-1 to list all users.
10609*/
10610/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
fd8cd3a3 10611struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
a0d0e21e 10612{
748a9306
LW		 10613 const $DESCRIPTOR(name_desc,__pw_namecache);
10614 unsigned short lname;
10615 union uicdef uic;
10616 unsigned long int status;
10617
10618 if (uid == (unsigned int) -1) {
10619 do {
10620 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10621 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
c07a80fd 10622 set_vaxc_errno(status);
10623 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
748a9306
LW		 10624 my_endpwent();
10625 return NULL;
10626 }
10627 else { _ckvmssts(status); }
10628 } while (!valid_uic (uic));
10629 }
10630 else {
10631 uic.uic$l_uic= uid;
c07a80fd 10632 if (!uic.uic$v_group)
76e3520e 10633 uic.uic$v_group= PerlProc_getgid();
748a9306
LW		 10634 if (valid_uic(uic))
10635 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10636 else status = SS$_IVIDENT;
c07a80fd 10637 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10638 status == RMS$_PRV) {
10639 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10640 return NULL;
10641 }
10642 else { _ckvmssts(status); }
748a9306
LW		 10643 }
10644 __pw_namecache[lname]= '\0';
01b8edb6 10645 __mystrtolower(__pw_namecache);
748a9306
LW		 10646
10647 __pwdcache = __passwd_empty;
10648 __pwdcache.pw_name = __pw_namecache;
10649
10650/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10651 The identifier's value is usually the UIC, but it doesn't have to be,
10652 so if we can, we let fillpasswd update this. */
10653 __pwdcache.pw_uid = uic.uic$l_uic;
10654 __pwdcache.pw_gid = uic.uic$v_group;
10655
fd8cd3a3 10656 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
748a9306 10657 return &__pwdcache;
a0d0e21e 10658
748a9306
LW		 10659} /* end of my_getpwuid() */
10660/*}}}*/
10661
10662/*
10663 * Get information for next user.
10664*/
10665/*{{{struct passwd *my_getpwent()*/
fd8cd3a3 10666struct passwd *Perl_my_getpwent(pTHX)
748a9306
LW		 10667{
10668 return (my_getpwuid((unsigned int) -1));
10669}
10670/*}}}*/
a0d0e21e 10671
748a9306
LW		 10672/*
10673 * Finish searching rights database for users.
10674*/
10675/*{{{void my_endpwent()*/
fd8cd3a3 10676void Perl_my_endpwent(pTHX)
748a9306
LW		 10677{
10678 if (contxt) {
10679 _ckvmssts(sys$finish_rdb(&contxt));
10680 contxt= 0;
10681 }
a0d0e21e
LW		 10682}
10683/*}}}*/
748a9306 10684
61bb5906
CB		 10685#ifdef HOMEGROWN_POSIX_SIGNALS
10686 /* Signal handling routines, pulled into the core from POSIX.xs.
10687 *
10688 * We need these for threads, so they've been rolled into the core,
10689 * rather than left in POSIX.xs.
10690 *
10691 * (DRS, Oct 23, 1997)
10692 */
5b411029 10693
61bb5906
CB		 10694 /* sigset_t is atomic under VMS, so these routines are easy */
10695/*{{{int my_sigemptyset(sigset_t *) */
5b411029 10696int my_sigemptyset(sigset_t *set) {
61bb5906
CB		 10697 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10698 *set = 0; return 0;
5b411029 10699}
61bb5906
CB		 10700/*}}}*/
10701
10702
10703/*{{{int my_sigfillset(sigset_t *)*/
5b411029 10704int my_sigfillset(sigset_t *set) {
61bb5906
CB		 10705 int i;
10706 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10707 for (i = 0; i < NSIG; i++) *set |= (1 << i);
10708 return 0;
5b411029 10709}
61bb5906
CB		 10710/*}}}*/
10711
10712
10713/*{{{int my_sigaddset(sigset_t *set, int sig)*/
5b411029 10714int my_sigaddset(sigset_t *set, int sig) {
61bb5906
CB		 10715 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10716 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10717 *set |= (1 << (sig - 1));
10718 return 0;
5b411029 10719}
61bb5906
CB		 10720/*}}}*/
10721
10722
10723/*{{{int my_sigdelset(sigset_t *set, int sig)*/
5b411029 10724int my_sigdelset(sigset_t *set, int sig) {
61bb5906
CB		 10725 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10726 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10727 *set &= ~(1 << (sig - 1));
10728 return 0;
5b411029 10729}
61bb5906
CB		 10730/*}}}*/
10731
10732
10733/*{{{int my_sigismember(sigset_t *set, int sig)*/
5b411029 10734int my_sigismember(sigset_t *set, int sig) {
61bb5906
CB		 10735 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10736 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
73e350d9 10737 return *set & (1 << (sig - 1));
5b411029 10738}
61bb5906 10739/*}}}*/
5b411029 10740
5b411029 10741
61bb5906
CB		 10742/*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10743int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10744 sigset_t tempmask;
10745
10746 /* If set and oset are both null, then things are badly wrong. Bail out. */
10747 if ((oset == NULL) && (set == NULL)) {
10748 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5b411029
MB		 10749 return -1;
10750 }
5b411029 10751
61bb5906
CB		 10752 /* If set's null, then we're just handling a fetch. */
10753 if (set == NULL) {
10754 tempmask = sigblock(0);
10755 }
10756 else {
10757 switch (how) {
10758 case SIG_SETMASK:
10759 tempmask = sigsetmask(*set);
10760 break;
10761 case SIG_BLOCK:
10762 tempmask = sigblock(*set);
10763 break;
10764 case SIG_UNBLOCK:
10765 tempmask = sigblock(0);
10766 sigsetmask(*oset & ~tempmask);
10767 break;
10768 default:
10769 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10770 return -1;
10771 }
10772 }
10773
10774 /* Did they pass us an oset? If so, stick our holding mask into it */
10775 if (oset)
10776 *oset = tempmask;
5b411029 10777
61bb5906 10778 return 0;
5b411029 10779}
61bb5906
CB		 10780/*}}}*/
10781#endif /* HOMEGROWN_POSIX_SIGNALS */
10782
5b411029 10783
ff0cee69 10784/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10785 * my_utime(), and flex_stat(), all of which operate on UTC unless
10786 * VMSISH_TIMES is true.
10787 */
10788/* method used to handle UTC conversions:
10789 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
e518068a 10790 */
ff0cee69 10791static int gmtime_emulation_type;
10792/* number of secs to add to UTC POSIX-style time to get local time */
10793static long int utc_offset_secs;
e518068a 10794
ff0cee69 10795/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10796 * in vmsish.h. #undef them here so we can call the CRTL routines
10797 * directly.
e518068a 10798 */
10799#undef gmtime
ff0cee69 10800#undef localtime
10801#undef time
10802
61bb5906 10803
a44ceb8e
CB		 10804/*
10805 * DEC C previous to 6.0 corrupts the behavior of the /prefix
10806 * qualifier with the extern prefix pragma. This provisional
10807 * hack circumvents this prefix pragma problem in previous
10808 * precompilers.
10809 */
10810#if defined(__VMS_VER) && __VMS_VER >= 70000000
10811# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10812# pragma __extern_prefix save
10813# pragma __extern_prefix "" /* set to empty to prevent prefixing */
10814# define gmtime decc$__utctz_gmtime
10815# define localtime decc$__utctz_localtime
10816# define time decc$__utc_time
10817# pragma __extern_prefix restore
10818
10819 struct tm *gmtime(), *localtime();
10820
10821# endif
10822#endif
10823
10824
61bb5906
CB		 10825static time_t toutc_dst(time_t loc) {
10826 struct tm *rsltmp;
10827
10828 if ((rsltmp = localtime(&loc)) == NULL) return -1;
10829 loc -= utc_offset_secs;
10830 if (rsltmp->tm_isdst) loc -= 3600;
10831 return loc;
10832}
32da55ab 10833#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 10834 ((gmtime_emulation_type || my_time(NULL)), \
10835 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10836 ((secs) - utc_offset_secs))))
10837
10838static time_t toloc_dst(time_t utc) {
10839 struct tm *rsltmp;
10840
10841 utc += utc_offset_secs;
10842 if ((rsltmp = localtime(&utc)) == NULL) return -1;
10843 if (rsltmp->tm_isdst) utc += 3600;
10844 return utc;
10845}
32da55ab 10846#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 10847 ((gmtime_emulation_type || my_time(NULL)), \
10848 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10849 ((secs) + utc_offset_secs))))
10850
22d4bb9c
CB		 10851#ifndef RTL_USES_UTC
10852/*
10853
10854 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
10855 DST starts on 1st sun of april at 02:00 std time
10856 ends on last sun of october at 02:00 dst time
10857 see the UCX management command reference, SET CONFIG TIMEZONE
10858 for formatting info.
10859
10860 No, it's not as general as it should be, but then again, NOTHING
10861 will handle UK times in a sensible way.
10862*/
10863
10864
10865/*
10866 parse the DST start/end info:
10867 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10868*/
10869
10870static char *
10871tz_parse_startend(char *s, struct tm *w, int *past)
10872{
10873 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10874 int ly, dozjd, d, m, n, hour, min, sec, j, k;
10875 time_t g;
10876
10877 if (!s) return 0;
10878 if (!w) return 0;
10879 if (!past) return 0;
10880
10881 ly = 0;
10882 if (w->tm_year % 4 == 0) ly = 1;
10883 if (w->tm_year % 100 == 0) ly = 0;
10884 if (w->tm_year+1900 % 400 == 0) ly = 1;
10885 if (ly) dinm[1]++;
10886
10887 dozjd = isdigit(*s);
10888 if (*s == 'J' || *s == 'j' || dozjd) {
10889 if (!dozjd && !isdigit(*++s)) return 0;
10890 d = *s++ - '0';
10891 if (isdigit(*s)) {
10892 d = d*10 + *s++ - '0';
10893 if (isdigit(*s)) {
10894 d = d*10 + *s++ - '0';
10895 }
10896 }
10897 if (d == 0) return 0;
10898 if (d > 366) return 0;
10899 d--;
10900 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
10901 g = d * 86400;
10902 dozjd = 1;
10903 } else if (*s == 'M' || *s == 'm') {
10904 if (!isdigit(*++s)) return 0;
10905 m = *s++ - '0';
10906 if (isdigit(*s)) m = 10*m + *s++ - '0';
10907 if (*s != '.') return 0;
10908 if (!isdigit(*++s)) return 0;
10909 n = *s++ - '0';
10910 if (n < 1 || n > 5) return 0;
10911 if (*s != '.') return 0;
10912 if (!isdigit(*++s)) return 0;
10913 d = *s++ - '0';
10914 if (d > 6) return 0;
10915 }
10916
10917 if (*s == '/') {
10918 if (!isdigit(*++s)) return 0;
10919 hour = *s++ - '0';
10920 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10921 if (*s == ':') {
10922 if (!isdigit(*++s)) return 0;
10923 min = *s++ - '0';
10924 if (isdigit(*s)) min = 10*min + *s++ - '0';
10925 if (*s == ':') {
10926 if (!isdigit(*++s)) return 0;
10927 sec = *s++ - '0';
10928 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10929 }
10930 }
10931 } else {
10932 hour = 2;
10933 min = 0;
10934 sec = 0;
10935 }
10936
10937 if (dozjd) {
10938 if (w->tm_yday < d) goto before;
10939 if (w->tm_yday > d) goto after;
10940 } else {
10941 if (w->tm_mon+1 < m) goto before;
10942 if (w->tm_mon+1 > m) goto after;
10943
10944 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
10945 k = d - j; /* mday of first d */
10946 if (k <= 0) k += 7;
10947 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
10948 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10949 if (w->tm_mday < k) goto before;
10950 if (w->tm_mday > k) goto after;
10951 }
10952
10953 if (w->tm_hour < hour) goto before;
10954 if (w->tm_hour > hour) goto after;
10955 if (w->tm_min < min) goto before;
10956 if (w->tm_min > min) goto after;
10957 if (w->tm_sec < sec) goto before;
10958 goto after;
10959
10960before:
10961 *past = 0;
10962 return s;
10963after:
10964 *past = 1;
10965 return s;
10966}
10967
10968
10969
10970
10971/* parse the offset: (+|-)hh[:mm[:ss]] */
10972
10973static char *
10974tz_parse_offset(char *s, int *offset)
10975{
10976 int hour = 0, min = 0, sec = 0;
10977 int neg = 0;
10978 if (!s) return 0;
10979 if (!offset) return 0;
10980
10981 if (*s == '-') {neg++; s++;}
10982 if (*s == '+') s++;
10983 if (!isdigit(*s)) return 0;
10984 hour = *s++ - '0';
10985 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10986 if (hour > 24) return 0;
10987 if (*s == ':') {
10988 if (!isdigit(*++s)) return 0;
10989 min = *s++ - '0';
10990 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10991 if (min > 59) return 0;
10992 if (*s == ':') {
10993 if (!isdigit(*++s)) return 0;
10994 sec = *s++ - '0';
10995 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10996 if (sec > 59) return 0;
10997 }
10998 }
10999
11000 *offset = (hour*60+min)*60 + sec;
11001 if (neg) *offset = -*offset;
11002 return s;
11003}
11004
11005/*
11006 input time is w, whatever type of time the CRTL localtime() uses.
11007 sets dst, the zone, and the gmtoff (seconds)
11008
11009 caches the value of TZ and UCX$TZ env variables; note that
11010 my_setenv looks for these and sets a flag if they're changed
11011 for efficiency.
11012
11013 We have to watch out for the "australian" case (dst starts in
11014 october, ends in april)...flagged by "reverse" and checked by
11015 scanning through the months of the previous year.
11016
11017*/
11018
11019static int
fd8cd3a3 11020tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
22d4bb9c
CB		 11021{
11022 time_t when;
11023 struct tm *w2;
11024 char *s,*s2;
11025 char *dstzone, *tz, *s_start, *s_end;
11026 int std_off, dst_off, isdst;
11027 int y, dststart, dstend;
11028 static char envtz[1025]; /* longer than any logical, symbol, ... */
11029 static char ucxtz[1025];
11030 static char reversed = 0;
11031
11032 if (!w) return 0;
11033
11034 if (tz_updated) {
11035 tz_updated = 0;
11036 reversed = -1; /* flag need to check */
11037 envtz[0] = ucxtz[0] = '\0';
11038 tz = my_getenv("TZ",0);
11039 if (tz) strcpy(envtz, tz);
11040 tz = my_getenv("UCX$TZ",0);
11041 if (tz) strcpy(ucxtz, tz);
11042 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
11043 }
11044 tz = envtz;
11045 if (!*tz) tz = ucxtz;
11046
11047 s = tz;
11048 while (isalpha(*s)) s++;
11049 s = tz_parse_offset(s, &std_off);
11050 if (!s) return 0;
11051 if (!*s) { /* no DST, hurray we're done! */
11052 isdst = 0;
11053 goto done;
11054 }
11055
11056 dstzone = s;
11057 while (isalpha(*s)) s++;
11058 s2 = tz_parse_offset(s, &dst_off);
11059 if (s2) {
11060 s = s2;
11061 } else {
11062 dst_off = std_off - 3600;
11063 }
11064
11065 if (!*s) { /* default dst start/end?? */
11066 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
11067 s = strchr(ucxtz,',');
11068 }
11069 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
11070 }
11071 if (*s != ',') return 0;
11072
11073 when = *w;
11074 when = _toutc(when); /* convert to utc */
11075 when = when - std_off; /* convert to pseudolocal time*/
11076
11077 w2 = localtime(&when);
11078 y = w2->tm_year;
11079 s_start = s+1;
11080 s = tz_parse_startend(s_start,w2,&dststart);
11081 if (!s) return 0;
11082 if (*s != ',') return 0;
11083
11084 when = *w;
11085 when = _toutc(when); /* convert to utc */
11086 when = when - dst_off; /* convert to pseudolocal time*/
11087 w2 = localtime(&when);
11088 if (w2->tm_year != y) { /* spans a year, just check one time */
11089 when += dst_off - std_off;
11090 w2 = localtime(&when);
11091 }
11092 s_end = s+1;
11093 s = tz_parse_startend(s_end,w2,&dstend);
11094 if (!s) return 0;
11095
11096 if (reversed == -1) { /* need to check if start later than end */
11097 int j, ds, de;
11098
11099 when = *w;
11100 if (when < 2*365*86400) {
11101 when += 2*365*86400;
11102 } else {
11103 when -= 365*86400;
11104 }
11105 w2 =localtime(&when);
11106 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
11107
11108 for (j = 0; j < 12; j++) {
11109 w2 =localtime(&when);
f7ddb74a
JM		 11110 tz_parse_startend(s_start,w2,&ds);
11111 tz_parse_startend(s_end,w2,&de);
22d4bb9c
CB		 11112 if (ds != de) break;
11113 when += 30*86400;
11114 }
11115 reversed = 0;
11116 if (de && !ds) reversed = 1;
11117 }
11118
11119 isdst = dststart && !dstend;
11120 if (reversed) isdst = dststart || !dstend;
11121
11122done:
11123 if (dst) *dst = isdst;
11124 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11125 if (isdst) tz = dstzone;
11126 if (zone) {
11127 while(isalpha(*tz)) *zone++ = *tz++;
11128 *zone = '\0';
11129 }
11130 return 1;
11131}
11132
11133#endif /* !RTL_USES_UTC */
61bb5906 11134
ff0cee69 11135/* my_time(), my_localtime(), my_gmtime()
61bb5906 11136 * By default traffic in UTC time values, using CRTL gmtime() or
ff0cee69 11137 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
61bb5906
CB		 11138 * Note: We need to use these functions even when the CRTL has working
11139 * UTC support, since they also handle C<use vmsish qw(times);>
11140 *
ff0cee69 11141 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
bd3fa61c 11142 * Modified by Charles Bailey <bailey@newman.upenn.edu>
ff0cee69 11143 */
11144
11145/*{{{time_t my_time(time_t *timep)*/
fd8cd3a3 11146time_t Perl_my_time(pTHX_ time_t *timep)
e518068a 11147{
e518068a 11148 time_t when;
61bb5906 11149 struct tm *tm_p;
e518068a 11150
11151 if (gmtime_emulation_type == 0) {
61bb5906
CB		 11152 int dstnow;
11153 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11154 /* results of calls to gmtime() and localtime() */
11155 /* for same &base */
ff0cee69 11156
e518068a 11157 gmtime_emulation_type++;
ff0cee69 11158 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
f675dbe5 11159 char off[LNM$C_NAMLENGTH+1];;
ff0cee69 11160
e518068a 11161 gmtime_emulation_type++;
f675dbe5 11162 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
e518068a 11163 gmtime_emulation_type++;
22d4bb9c 11164 utc_offset_secs = 0;
5c84aa53 11165 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
ff0cee69 11166 }
11167 else { utc_offset_secs = atol(off); }
e518068a 11168 }
ff0cee69 11169 else { /* We've got a working gmtime() */
11170 struct tm gmt, local;
e518068a 11171
ff0cee69 11172 gmt = *tm_p;
11173 tm_p = localtime(&base);
11174 local = *tm_p;
11175 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11176 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11177 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11178 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11179 }
e518068a 11180 }
ff0cee69 11181
11182 when = time(NULL);
61bb5906
CB		 11183# ifdef VMSISH_TIME
11184# ifdef RTL_USES_UTC
11185 if (VMSISH_TIME) when = _toloc(when);
11186# else
11187 if (!VMSISH_TIME) when = _toutc(when);
11188# endif
11189# endif
ff0cee69 11190 if (timep != NULL) *timep = when;
11191 return when;
11192
11193} /* end of my_time() */
11194/*}}}*/
11195
11196
11197/*{{{struct tm *my_gmtime(const time_t *timep)*/
11198struct tm *
fd8cd3a3 11199Perl_my_gmtime(pTHX_ const time_t *timep)
ff0cee69 11200{
11201 char *p;
11202 time_t when;
61bb5906 11203 struct tm *rsltmp;
ff0cee69 11204
68dc0745 11205 if (timep == NULL) {
11206 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11207 return NULL;
11208 }
11209 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
ff0cee69 11210
11211 when = *timep;
11212# ifdef VMSISH_TIME
61bb5906
CB		 11213 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11214# endif
11215# ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
11216 return gmtime(&when);
11217# else
ff0cee69 11218 /* CRTL localtime() wants local time as input, so does no tz correction */
61bb5906
CB		 11219 rsltmp = localtime(&when);
11220 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
11221 return rsltmp;
11222#endif
e518068a 11223} /* end of my_gmtime() */
e518068a 11224/*}}}*/
11225
11226
ff0cee69 11227/*{{{struct tm *my_localtime(const time_t *timep)*/
11228struct tm *
fd8cd3a3 11229Perl_my_localtime(pTHX_ const time_t *timep)
ff0cee69 11230{
22d4bb9c 11231 time_t when, whenutc;
61bb5906 11232 struct tm *rsltmp;
22d4bb9c 11233 int dst, offset;
ff0cee69 11234
68dc0745 11235 if (timep == NULL) {
11236 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11237 return NULL;
11238 }
11239 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
f7ddb74a 11240 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
ff0cee69 11241
11242 when = *timep;
61bb5906 11243# ifdef RTL_USES_UTC
ff0cee69 11244# ifdef VMSISH_TIME
61bb5906 11245 if (VMSISH_TIME) when = _toutc(when);
ff0cee69 11246# endif
61bb5906 11247 /* CRTL localtime() wants UTC as input, does tz correction itself */
ff0cee69 11248 return localtime(&when);
22d4bb9c
CB		 11249
11250# else /* !RTL_USES_UTC */
11251 whenutc = when;
61bb5906 11252# ifdef VMSISH_TIME
22d4bb9c
CB		 11253 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
11254 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
61bb5906 11255# endif
22d4bb9c
CB		 11256 dst = -1;
11257#ifndef RTL_USES_UTC
32af7c23 11258 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
22d4bb9c
CB		 11259 when = whenutc - offset; /* pseudolocal time*/
11260 }
61bb5906
CB		 11261# endif
11262 /* CRTL localtime() wants local time as input, so does no tz correction */
11263 rsltmp = localtime(&when);
22d4bb9c 11264 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
61bb5906 11265 return rsltmp;
22d4bb9c 11266# endif
ff0cee69 11267
11268} /* end of my_localtime() */
11269/*}}}*/
11270
11271/* Reset definitions for later calls */
11272#define gmtime(t) my_gmtime(t)
11273#define localtime(t) my_localtime(t)
11274#define time(t) my_time(t)
11275
11276
941b3de1
CB		 11277/* my_utime - update modification/access time of a file
11278 *
11279 * VMS 7.3 and later implementation
11280 * Only the UTC translation is home-grown. The rest is handled by the
11281 * CRTL utime(), which will take into account the relevant feature
11282 * logicals and ODS-5 volume characteristics for true access times.
11283 *
11284 * pre VMS 7.3 implementation:
11285 * The calling sequence is identical to POSIX utime(), but under
11286 * VMS with ODS-2, only the modification time is changed; ODS-2 does
11287 * not maintain access times. Restrictions differ from the POSIX
ff0cee69 11288 * definition in that the time can be changed as long as the
11289 * caller has permission to execute the necessary IO$_MODIFY $QIO;
11290 * no separate checks are made to insure that the caller is the
11291 * owner of the file or has special privs enabled.
11292 * Code here is based on Joe Meadows' FILE utility.
941b3de1 11293 *
ff0cee69 11294 */
11295
11296/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11297 * to VMS epoch (01-JAN-1858 00:00:00.00)
11298 * in 100 ns intervals.
11299 */
11300static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11301
94a11853
CB		 11302/*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11303int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
ff0cee69 11304{
941b3de1
CB		 11305#if __CRTL_VER >= 70300000
11306 struct utimbuf utc_utimes, *utc_utimesp;
11307
11308 if (utimes != NULL) {
11309 utc_utimes.actime = utimes->actime;
11310 utc_utimes.modtime = utimes->modtime;
11311# ifdef VMSISH_TIME
11312 /* If input was local; convert to UTC for sys svc */
11313 if (VMSISH_TIME) {
11314 utc_utimes.actime = _toutc(utimes->actime);
11315 utc_utimes.modtime = _toutc(utimes->modtime);
11316 }
11317# endif
11318 utc_utimesp = &utc_utimes;
11319 }
11320 else {
11321 utc_utimesp = NULL;
11322 }
11323
11324 return utime(file, utc_utimesp);
11325
11326#else /* __CRTL_VER < 70300000 */
11327
ff0cee69 11328 register int i;
f7ddb74a 11329 int sts;
ff0cee69 11330 long int bintime[2], len = 2, lowbit, unixtime,
11331 secscale = 10000000; /* seconds --> 100 ns intervals */
11332 unsigned long int chan, iosb[2], retsts;
11333 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11334 struct FAB myfab = cc$rms_fab;
11335 struct NAM mynam = cc$rms_nam;
11336#if defined (__DECC) && defined (__VAX)
11337 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11338 * at least through VMS V6.1, which causes a type-conversion warning.
11339 */
11340# pragma message save
11341# pragma message disable cvtdiftypes
11342#endif
11343 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11344 struct fibdef myfib;
11345#if defined (__DECC) && defined (__VAX)
11346 /* This should be right after the declaration of myatr, but due
11347 * to a bug in VAX DEC C, this takes effect a statement early.
11348 */
11349# pragma message restore
11350#endif
f7ddb74a 11351 /* cast ok for read only parameter */
ff0cee69 11352 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11353 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11354 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
704c2eb3 11355
ff0cee69 11356 if (file == NULL || *file == '\0') {
941b3de1 11357 SETERRNO(ENOENT, LIB$_INVARG);
ff0cee69 11358 return -1;
11359 }
704c2eb3
JM		 11360
11361 /* Convert to VMS format ensuring that it will fit in 255 characters */
360732b5 11362 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
941b3de1
CB		 11363 SETERRNO(ENOENT, LIB$_INVARG);
11364 return -1;
11365 }
ff0cee69 11366 if (utimes != NULL) {
11367 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
11368 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11369 * Since time_t is unsigned long int, and lib$emul takes a signed long int
11370 * as input, we force the sign bit to be clear by shifting unixtime right
11371 * one bit, then multiplying by an extra factor of 2 in lib$emul().
11372 */
11373 lowbit = (utimes->modtime & 1) ? secscale : 0;
11374 unixtime = (long int) utimes->modtime;
61bb5906
CB		 11375# ifdef VMSISH_TIME
11376 /* If input was UTC; convert to local for sys svc */
11377 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
ff0cee69 11378# endif
1a6334fb 11379 unixtime >>= 1; secscale <<= 1;
ff0cee69 11380 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11381 if (!(retsts & 1)) {
941b3de1 11382 SETERRNO(EVMSERR, retsts);
ff0cee69 11383 return -1;
11384 }
11385 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11386 if (!(retsts & 1)) {
941b3de1 11387 SETERRNO(EVMSERR, retsts);
ff0cee69 11388 return -1;
11389 }
11390 }
11391 else {
11392 /* Just get the current time in VMS format directly */
11393 retsts = sys$gettim(bintime);
11394 if (!(retsts & 1)) {
941b3de1 11395 SETERRNO(EVMSERR, retsts);
ff0cee69 11396 return -1;
11397 }
11398 }
11399
11400 myfab.fab$l_fna = vmsspec;
11401 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11402 myfab.fab$l_nam = &mynam;
11403 mynam.nam$l_esa = esa;
11404 mynam.nam$b_ess = (unsigned char) sizeof esa;
11405 mynam.nam$l_rsa = rsa;
11406 mynam.nam$b_rss = (unsigned char) sizeof rsa;
f7ddb74a
JM		 11407 if (decc_efs_case_preserve)
11408 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
ff0cee69 11409
11410 /* Look for the file to be affected, letting RMS parse the file
11411 * specification for us as well. I have set errno using only
11412 * values documented in the utime() man page for VMS POSIX.
11413 */
11414 retsts = sys$parse(&myfab,0,0);
11415 if (!(retsts & 1)) {
11416 set_vaxc_errno(retsts);
11417 if (retsts == RMS$_PRV) set_errno(EACCES);
11418 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11419 else set_errno(EVMSERR);
11420 return -1;
11421 }
11422 retsts = sys$search(&myfab,0,0);
11423 if (!(retsts & 1)) {
752635ea 11424 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 11425 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 11426 set_vaxc_errno(retsts);
11427 if (retsts == RMS$_PRV) set_errno(EACCES);
11428 else if (retsts == RMS$_FNF) set_errno(ENOENT);
11429 else set_errno(EVMSERR);
11430 return -1;
11431 }
11432
11433 devdsc.dsc$w_length = mynam.nam$b_dev;
f7ddb74a 11434 /* cast ok for read only parameter */
ff0cee69 11435 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11436
11437 retsts = sys$assign(&devdsc,&chan,0,0);
11438 if (!(retsts & 1)) {
752635ea 11439 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 11440 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 11441 set_vaxc_errno(retsts);
11442 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
11443 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
11444 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
11445 else set_errno(EVMSERR);
11446 return -1;
11447 }
11448
11449 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11450 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11451
11452 memset((void *) &myfib, 0, sizeof myfib);
22d4bb9c 11453#if defined(__DECC) || defined(__DECCXX)
ff0cee69 11454 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11455 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11456 /* This prevents the revision time of the file being reset to the current
11457 * time as a result of our IO$_MODIFY $QIO. */
11458 myfib.fib$l_acctl = FIB$M_NORECORD;
11459#else
11460 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11461 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11462 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11463#endif
11464 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
752635ea 11465 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 11466 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 11467 _ckvmssts(sys$dassgn(chan));
11468 if (retsts & 1) retsts = iosb[0];
11469 if (!(retsts & 1)) {
11470 set_vaxc_errno(retsts);
11471 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11472 else set_errno(EVMSERR);
11473 return -1;
11474 }
11475
11476 return 0;
941b3de1
CB		 11477
11478#endif /* #if __CRTL_VER >= 70300000 */
11479
ff0cee69 11480} /* end of my_utime() */
11481/*}}}*/
11482
748a9306 11483/*
2497a41f 11484 * flex_stat, flex_lstat, flex_fstat
748a9306
LW		 11485 * basic stat, but gets it right when asked to stat
11486 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11487 */
11488
2497a41f 11489#ifndef _USE_STD_STAT
748a9306
LW		 11490/* encode_dev packs a VMS device name string into an integer to allow
11491 * simple comparisons. This can be used, for example, to check whether two
11492 * files are located on the same device, by comparing their encoded device
11493 * names. Even a string comparison would not do, because stat() reuses the
11494 * device name buffer for each call; so without encode_dev, it would be
11495 * necessary to save the buffer and use strcmp (this would mean a number of
11496 * changes to the standard Perl code, to say nothing of what a Perl script
11497 * would have to do.
11498 *
11499 * The device lock id, if it exists, should be unique (unless perhaps compared
11500 * with lock ids transferred from other nodes). We have a lock id if the disk is
11501 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11502 * device names. Thus we use the lock id in preference, and only if that isn't
11503 * available, do we try to pack the device name into an integer (flagged by
11504 * the sign bit (LOCKID_MASK) being set).
11505 *
e518068a 11506 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
748a9306
LW		 11507 * name and its encoded form, but it seems very unlikely that we will find
11508 * two files on different disks that share the same encoded device names,
11509 * and even more remote that they will share the same file id (if the test
11510 * is to check for the same file).
11511 *
11512 * A better method might be to use sys$device_scan on the first call, and to
11513 * search for the device, returning an index into the cached array.
cb9e088c 11514 * The number returned would be more intelligible.
748a9306
LW		 11515 * This is probably not worth it, and anyway would take quite a bit longer
11516 * on the first call.
11517 */
11518#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
fd8cd3a3 11519static mydev_t encode_dev (pTHX_ const char *dev)
748a9306
LW		 11520{
11521 int i;
11522 unsigned long int f;
aa689395 11523 mydev_t enc;
748a9306
LW		 11524 char c;
11525 const char *q;
11526
11527 if (!dev || !dev[0]) return 0;
11528
11529#if LOCKID_MASK
11530 {
11531 struct dsc$descriptor_s dev_desc;
cb9e088c 11532 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
748a9306
LW		 11533
11534 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11535 can try that first. */
11536 dev_desc.dsc$w_length = strlen (dev);
11537 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11538 dev_desc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 11539 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
cb9e088c 11540 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
360732b5 11541 if (!$VMS_STATUS_SUCCESS(status)) {
cb9e088c
CB		 11542 switch (status) {
11543 case SS$_NOSUCHDEV:
11544 SETERRNO(ENODEV, status);
11545 return 0;
11546 default:
11547 _ckvmssts(status);
11548 }
11549 }
748a9306
LW		 11550 if (lockid) return (lockid & ~LOCKID_MASK);
11551 }
a0d0e21e 11552#endif
748a9306
LW		 11553
11554 /* Otherwise we try to encode the device name */
11555 enc = 0;
11556 f = 1;
11557 i = 0;
11558 for (q = dev + strlen(dev); q--; q >= dev) {
988c775c
JM		 11559 if (*q == ':')
11560 break;
748a9306
LW		 11561 if (isdigit (*q))
11562 c= (*q) - '0';
11563 else if (isalpha (toupper (*q)))
11564 c= toupper (*q) - 'A' + (char)10;
11565 else
11566 continue; /* Skip '$'s */
11567 i++;
11568 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11569 if (i>1) f *= 36;
11570 enc += f * (unsigned long int) c;
11571 }
11572 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11573
11574} /* end of encode_dev() */
cfcfe586
JM		 11575#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11576 device_no = encode_dev(aTHX_ devname)
11577#else
11578#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11579 device_no = new_dev_no
2497a41f 11580#endif
748a9306 11581
748a9306
LW		 11582static int
11583is_null_device(name)
11584 const char *name;
11585{
2497a41f 11586 if (decc_bug_devnull != 0) {
682e4b71 11587 if (strncmp("/dev/null", name, 9) == 0)
2497a41f
JM		 11588 return 1;
11589 }
748a9306
LW		 11590 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11591 The underscore prefix, controller letter, and unit number are
11592 independently optional; for our purposes, the colon punctuation
11593 is not. The colon can be trailed by optional directory and/or
11594 filename, but two consecutive colons indicates a nodename rather
11595 than a device. [pr] */
11596 if (*name == '_') ++name;
11597 if (tolower(*name++) != 'n') return 0;
11598 if (tolower(*name++) != 'l') return 0;
11599 if (tolower(*name) == 'a') ++name;
11600 if (*name == '0') ++name;
11601 return (*name++ == ':') && (*name != ':');
11602}
11603
c07a80fd 11604
a1887106
JM		 11605static I32
11606Perl_cando_by_name_int
11607 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
748a9306 11608{
e538e23f
CB		 11609 char usrname[L_cuserid];
11610 struct dsc$descriptor_s usrdsc =
748a9306 11611 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
e538e23f 11612 char *vmsname = NULL, *fileified = NULL;
597c27e2 11613 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
2d9f3838 11614 unsigned short int retlen, trnlnm_iter_count;
748a9306
LW		 11615 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11616 union prvdef curprv;
597c27e2
CB		 11617 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11618 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11619 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
ada67d10
CB		 11620 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11621 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11622 {0,0,0,0}};
11623 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
748a9306 11624 {0,0,0,0}};
ada67d10 11625 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
858aded6 11626 Stat_t st;
6151c65c 11627 static int profile_context = -1;
748a9306
LW		 11628
11629 if (!fname || !*fname) return FALSE;
a1887106 11630
e538e23f
CB		 11631 /* Make sure we expand logical names, since sys$check_access doesn't */
11632 fileified = PerlMem_malloc(VMS_MAXRSS);
11633 if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11634 if (!strpbrk(fname,"/]>:")) {
a1887106
JM		 11635 strcpy(fileified,fname);
11636 trnlnm_iter_count = 0;
e538e23f 11637 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
2d9f3838
CB		 11638 trnlnm_iter_count++;
11639 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
a1887106
JM		 11640 }
11641 fname = fileified;
e538e23f
CB		 11642 }
11643
11644 vmsname = PerlMem_malloc(VMS_MAXRSS);
11645 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11646 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11647 /* Don't know if already in VMS format, so make sure */
360732b5 11648 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
a1887106 11649 PerlMem_free(fileified);
e538e23f 11650 PerlMem_free(vmsname);
a1887106
JM		 11651 return FALSE;
11652 }
a1887106
JM		 11653 }
11654 else {
e538e23f 11655 strcpy(vmsname,fname);
a5f75d66
AD		 11656 }
11657
858aded6
CB		 11658 /* sys$check_access needs a file spec, not a directory spec.
11659 * Don't use flex_stat here, as that depends on thread context
11660 * having been initialized, and we may get here during startup.
11661 */
e538e23f
CB		 11662
11663 retlen = namdsc.dsc$w_length = strlen(vmsname);
11664 if (vmsname[retlen-1] == ']'
11665 || vmsname[retlen-1] == '>'
858aded6
CB		 11666 || vmsname[retlen-1] == ':'
11667 || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
e538e23f
CB		 11668
11669 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11670 PerlMem_free(fileified);
11671 PerlMem_free(vmsname);
11672 return FALSE;
11673 }
11674 fname = fileified;
11675 }
858aded6
CB		 11676 else {
11677 fname = vmsname;
11678 }
e538e23f
CB		 11679
11680 retlen = namdsc.dsc$w_length = strlen(fname);
11681 namdsc.dsc$a_pointer = (char *)fname;
11682
748a9306 11683 switch (bit) {
f282b18d 11684 case S_IXUSR: case S_IXGRP: case S_IXOTH:
360732b5 11685 access = ARM$M_EXECUTE;
597c27e2
CB		 11686 flags = CHP$M_READ;
11687 break;
f282b18d 11688 case S_IRUSR: case S_IRGRP: case S_IROTH:
360732b5 11689 access = ARM$M_READ;
597c27e2
CB		 11690 flags = CHP$M_READ | CHP$M_USEREADALL;
11691 break;
f282b18d 11692 case S_IWUSR: case S_IWGRP: case S_IWOTH:
360732b5 11693 access = ARM$M_WRITE;
597c27e2
CB		 11694 flags = CHP$M_READ | CHP$M_WRITE;
11695 break;
f282b18d 11696 case S_IDUSR: case S_IDGRP: case S_IDOTH:
360732b5 11697 access = ARM$M_DELETE;
597c27e2
CB		 11698 flags = CHP$M_READ | CHP$M_WRITE;
11699 break;
748a9306 11700 default:
a1887106
JM		 11701 if (fileified != NULL)
11702 PerlMem_free(fileified);
e538e23f
CB		 11703 if (vmsname != NULL)
11704 PerlMem_free(vmsname);
748a9306
LW		 11705 return FALSE;
11706 }
11707
ada67d10
CB		 11708 /* Before we call $check_access, create a user profile with the current
11709 * process privs since otherwise it just uses the default privs from the
baf3cf9c
CB		 11710 * UAF and might give false positives or negatives. This only works on
11711 * VMS versions v6.0 and later since that's when sys$create_user_profile
11712 * became available.
ada67d10
CB		 11713 */
11714
11715 /* get current process privs and username */
11716 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11717 _ckvmssts(iosb[0]);
11718
baf3cf9c
CB		 11719#if defined(__VMS_VER) && __VMS_VER >= 60000000
11720
ada67d10
CB		 11721 /* find out the space required for the profile */
11722 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6151c65c 11723 &usrprodsc.dsc$w_length,&profile_context));
ada67d10
CB		 11724
11725 /* allocate space for the profile and get it filled in */
c5375c28
JM		 11726 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11727 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
ada67d10 11728 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6151c65c 11729 &usrprodsc.dsc$w_length,&profile_context));
ada67d10
CB		 11730
11731 /* use the profile to check access to the file; free profile & analyze results */
6151c65c 11732 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
c5375c28 11733 PerlMem_free(usrprodsc.dsc$a_pointer);
ada67d10 11734 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
baf3cf9c
CB		 11735
11736#else
11737
11738 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11739
11740#endif
11741
bbce6d69 11742 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
61bb5906 11743 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
22d4bb9c 11744 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
bbce6d69 11745 set_vaxc_errno(retsts);
11746 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11747 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11748 else set_errno(ENOENT);
a1887106
JM		 11749 if (fileified != NULL)
11750 PerlMem_free(fileified);
e538e23f
CB		 11751 if (vmsname != NULL)
11752 PerlMem_free(vmsname);
a3e9d8c9 11753 return FALSE;
11754 }
ada67d10 11755 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
a1887106
JM		 11756 if (fileified != NULL)
11757 PerlMem_free(fileified);
e538e23f
CB		 11758 if (vmsname != NULL)
11759 PerlMem_free(vmsname);
3a385817
GS		 11760 return TRUE;
11761 }
748a9306
LW		 11762 _ckvmssts(retsts);
11763
a1887106
JM		 11764 if (fileified != NULL)
11765 PerlMem_free(fileified);
e538e23f
CB		 11766 if (vmsname != NULL)
11767 PerlMem_free(vmsname);
748a9306
LW		 11768 return FALSE; /* Should never get here */
11769
a1887106
JM		 11770}
11771
11772/* Do the permissions allow some operation? Assumes PL_statcache already set. */
11773/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11774 * subset of the applicable information.
11775 */
11776bool
11777Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11778{
11779 return cando_by_name_int
11780 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11781} /* end of cando() */
11782/*}}}*/
11783
11784
11785/*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11786I32
11787Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11788{
11789 return cando_by_name_int(bit, effective, fname, 0);
11790
748a9306
LW		 11791} /* end of cando_by_name() */
11792/*}}}*/
11793
11794
61bb5906 11795/*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
748a9306 11796int
fd8cd3a3 11797Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
748a9306 11798{
b7ae7a0d 11799 if (!fstat(fd,(stat_t *) statbufp)) {
75796008 11800 char *cptr;
988c775c
JM		 11801 char *vms_filename;
11802 vms_filename = PerlMem_malloc(VMS_MAXRSS);
11803 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
75796008 11804
988c775c
JM		 11805 /* Save name for cando by name in VMS format */
11806 cptr = getname(fd, vms_filename, 1);
75796008 11807
988c775c
JM		 11808 /* This should not happen, but just in case */
11809 if (cptr == NULL) {
11810 statbufp->st_devnam[0] = 0;
11811 }
11812 else {
11813 /* Make sure that the saved name fits in 255 characters */
11814 cptr = do_rmsexpand
11815 (vms_filename,
11816 statbufp->st_devnam,
11817 0,
11818 NULL,
360732b5
JM		 11819 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11820 NULL,
11821 NULL);
75796008 11822 if (cptr == NULL)
988c775c 11823 statbufp->st_devnam[0] = 0;
75796008 11824 }
988c775c 11825 PerlMem_free(vms_filename);
682e4b71
JM		 11826
11827 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 11828 VMS_DEVICE_ENCODE
11829 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
2497a41f 11830
61bb5906
CB		 11831# ifdef RTL_USES_UTC
11832# ifdef VMSISH_TIME
11833 if (VMSISH_TIME) {
11834 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11835 statbufp->st_atime = _toloc(statbufp->st_atime);
11836 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11837 }
11838# endif
11839# else
ff0cee69 11840# ifdef VMSISH_TIME
11841 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11842# else
11843 if (1) {
11844# endif
61bb5906
CB		 11845 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11846 statbufp->st_atime = _toutc(statbufp->st_atime);
11847 statbufp->st_ctime = _toutc(statbufp->st_ctime);
ff0cee69 11848 }
61bb5906 11849#endif
b7ae7a0d 11850 return 0;
11851 }
11852 return -1;
748a9306
LW		 11853
11854} /* end of flex_fstat() */
11855/*}}}*/
11856
2497a41f
JM		 11857#if !defined(__VAX) && __CRTL_VER >= 80200000
11858#ifdef lstat
11859#undef lstat
11860#endif
11861#else
11862#ifdef lstat
11863#undef lstat
11864#endif
11865#define lstat(_x, _y) stat(_x, _y)
11866#endif
11867
7ded3206
CB		 11868#define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11869
2497a41f
JM		 11870static int
11871Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
748a9306 11872{
988c775c
JM		 11873 char fileified[VMS_MAXRSS];
11874 char temp_fspec[VMS_MAXRSS];
11875 char *save_spec;
bbce6d69 11876 int retval = -1;
9543c6b6 11877 int saved_errno, saved_vaxc_errno;
748a9306 11878
e956e27a 11879 if (!fspec) return retval;
9543c6b6 11880 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
cc077a9f 11881 strcpy(temp_fspec, fspec);
988c775c 11882
2497a41f
JM		 11883 if (decc_bug_devnull != 0) {
11884 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11885 memset(statbufp,0,sizeof *statbufp);
cfcfe586 11886 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
2497a41f
JM		 11887 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11888 statbufp->st_uid = 0x00010001;
11889 statbufp->st_gid = 0x0001;
11890 time((time_t *)&statbufp->st_mtime);
11891 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11892 return 0;
11893 }
748a9306
LW		 11894 }
11895
bbce6d69 11896 /* Try for a directory name first. If fspec contains a filename without
61bb5906 11897 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
bbce6d69 11898 * and sea:[wine.dark]water. exist, we prefer the directory here.
11899 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11900 * not sea:[wine.dark]., if the latter exists. If the intended target is
11901 * the file with null type, specify this by calling flex_stat() with
11902 * a '.' at the end of fspec.
2497a41f
JM		 11903 *
11904 * If we are in Posix filespec mode, accept the filename as is.
bbce6d69 11905 */
f36b279d
CB		 11906
11907
11908#if __CRTL_VER >= 70300000 && !defined(__VAX)
11909 /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11910 * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11911 */
11912 if (!decc_efs_charset)
11913 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11914#endif
11915
2497a41f
JM		 11916#if __CRTL_VER >= 80200000 && !defined(__VAX)
11917 if (decc_posix_compliant_pathnames == 0) {
11918#endif
360732b5 11919 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
2497a41f
JM		 11920 if (lstat_flag == 0)
11921 retval = stat(fileified,(stat_t *) statbufp);
11922 else
11923 retval = lstat(fileified,(stat_t *) statbufp);
988c775c 11924 save_spec = fileified;
748a9306 11925 }
2497a41f
JM		 11926 if (retval) {
11927 if (lstat_flag == 0)
11928 retval = stat(temp_fspec,(stat_t *) statbufp);
11929 else
11930 retval = lstat(temp_fspec,(stat_t *) statbufp);
988c775c 11931 save_spec = temp_fspec;
2497a41f 11932 }
f1db9cda
JM		 11933/*
11934 * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11935 * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11936 * and lstat was working correctly for the same file.
11937 * The only syntax that was working for stat was "foo:[bar]t.dir".
11938 *
11939 * Other directories with the same syntax worked fine.
11940 * So work around the problem when it shows up here.
11941 */
11942 if (retval) {
11943 int save_errno = errno;
11944 if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
11945 if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
11946 retval = stat(fileified, (stat_t *) statbufp);
11947 save_spec = fileified;
11948 }
11949 }
11950 /* Restore the errno value if third stat does not succeed */
11951 if (retval != 0)
11952 errno = save_errno;
11953 }
2497a41f
JM		 11954#if __CRTL_VER >= 80200000 && !defined(__VAX)
11955 } else {
11956 if (lstat_flag == 0)
11957 retval = stat(temp_fspec,(stat_t *) statbufp);
11958 else
11959 retval = lstat(temp_fspec,(stat_t *) statbufp);
988c775c 11960 save_spec = temp_fspec;
2497a41f
JM		 11961 }
11962#endif
f36b279d
CB		 11963
11964#if __CRTL_VER >= 70300000 && !defined(__VAX)
11965 /* As you were... */
11966 if (!decc_efs_charset)
11967 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11968#endif
11969
ff0cee69 11970 if (!retval) {
988c775c 11971 char * cptr;
d584a1c6
JM		 11972 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
11973
11974 /* If this is an lstat, do not follow the link */
11975 if (lstat_flag)
11976 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
11977
988c775c 11978 cptr = do_rmsexpand
d584a1c6 11979 (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
988c775c
JM		 11980 if (cptr == NULL)
11981 statbufp->st_devnam[0] = 0;
11982
682e4b71 11983 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 11984 VMS_DEVICE_ENCODE
11985 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
61bb5906
CB		 11986# ifdef RTL_USES_UTC
11987# ifdef VMSISH_TIME
11988 if (VMSISH_TIME) {
11989 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11990 statbufp->st_atime = _toloc(statbufp->st_atime);
11991 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11992 }
11993# endif
11994# else
ff0cee69 11995# ifdef VMSISH_TIME
11996 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11997# else
11998 if (1) {
11999# endif
61bb5906
CB		 12000 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12001 statbufp->st_atime = _toutc(statbufp->st_atime);
12002 statbufp->st_ctime = _toutc(statbufp->st_ctime);
ff0cee69 12003 }
61bb5906 12004# endif
ff0cee69 12005 }
9543c6b6
CB		 12006 /* If we were successful, leave errno where we found it */
12007 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
748a9306
LW		 12008 return retval;
12009
2497a41f
JM		 12010} /* end of flex_stat_int() */
12011
12012
12013/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12014int
12015Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12016{
7ded3206 12017 return flex_stat_int(fspec, statbufp, 0);
2497a41f
JM		 12018}
12019/*}}}*/
12020
12021/*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12022int
12023Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12024{
7ded3206 12025 return flex_stat_int(fspec, statbufp, 1);
2497a41f 12026}
748a9306
LW		 12027/*}}}*/
12028
b7ae7a0d 12029
c07a80fd 12030/*{{{char *my_getlogin()*/
12031/* VMS cuserid == Unix getlogin, except calling sequence */
12032char *
2fbb330f 12033my_getlogin(void)
c07a80fd 12034{
12035 static char user[L_cuserid];
12036 return cuserid(user);
12037}
12038/*}}}*/
12039
12040
a5f75d66
AD		 12041/* rmscopy - copy a file using VMS RMS routines
12042 *
12043 * Copies contents and attributes of spec_in to spec_out, except owner
12044 * and protection information. Name and type of spec_in are used as
a3e9d8c9 12045 * defaults for spec_out. The third parameter specifies whether rmscopy()
12046 * should try to propagate timestamps from the input file to the output file.
12047 * If it is less than 0, no timestamps are preserved. If it is 0, then
12048 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12049 * propagated to the output file at creation iff the output file specification
12050 * did not contain an explicit name or type, and the revision date is always
12051 * updated at the end of the copy operation. If it is greater than 0, then
12052 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12053 * other than the revision date should be propagated, and bit 1 indicates
12054 * that the revision date should be propagated.
12055 *
12056 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
a5f75d66 12057 *
bd3fa61c 12058 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
a5f75d66 12059 * Incorporates, with permission, some code from EZCOPY by Tim Adye
01b8edb6 12060 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12061 * as part of the Perl standard distribution under the terms of the
12062 * GNU General Public License or the Perl Artistic License. Copies
12063 * of each may be found in the Perl standard distribution.
a480973c 12064 */ /* FIXME */
a3e9d8c9 12065/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
a480973c
JM		 12066int
12067Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12068{
d584a1c6
JM		 12069 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12070 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
a480973c 12071 unsigned long int i, sts, sts2;
a1887106 12072 int dna_len;
a480973c
JM		 12073 struct FAB fab_in, fab_out;
12074 struct RAB rab_in, rab_out;
a1887106
JM		 12075 rms_setup_nam(nam);
12076 rms_setup_nam(nam_out);
a480973c
JM		 12077 struct XABDAT xabdat;
12078 struct XABFHC xabfhc;
12079 struct XABRDT xabrdt;
12080 struct XABSUM xabsum;
12081
c5375c28
JM		 12082 vmsin = PerlMem_malloc(VMS_MAXRSS);
12083 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
12084 vmsout = PerlMem_malloc(VMS_MAXRSS);
12085 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
360732b5
JM		 12086 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
12087 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
c5375c28
JM		 12088 PerlMem_free(vmsin);
12089 PerlMem_free(vmsout);
a480973c
JM		 12090 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12091 return 0;
12092 }
12093
d584a1c6 12094 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
c5375c28 12095 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
d584a1c6
JM		 12096 esal = NULL;
12097#if !defined(__VAX) && defined(NAML$C_MAXRSS)
12098 esal = PerlMem_malloc(VMS_MAXRSS);
12099 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
12100#endif
a480973c 12101 fab_in = cc$rms_fab;
a1887106 12102 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
a480973c
JM		 12103 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12104 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12105 fab_in.fab$l_fop = FAB$M_SQO;
a1887106 12106 rms_bind_fab_nam(fab_in, nam);
a480973c
JM		 12107 fab_in.fab$l_xab = (void *) &xabdat;
12108
d584a1c6 12109 rsa = PerlMem_malloc(NAML$C_MAXRSS);
c5375c28 12110 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
d584a1c6
JM		 12111 rsal = NULL;
12112#if !defined(__VAX) && defined(NAML$C_MAXRSS)
12113 rsal = PerlMem_malloc(VMS_MAXRSS);
12114 if (rsal == NULL) _ckvmssts(SS$_INSFMEM);
12115#endif
12116 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12117 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
a1887106
JM		 12118 rms_nam_esl(nam) = 0;
12119 rms_nam_rsl(nam) = 0;
12120 rms_nam_esll(nam) = 0;
12121 rms_nam_rsll(nam) = 0;
a480973c
JM		 12122#ifdef NAM$M_NO_SHORT_UPCASE
12123 if (decc_efs_case_preserve)
a1887106 12124 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
a480973c
JM		 12125#endif
12126
12127 xabdat = cc$rms_xabdat; /* To get creation date */
12128 xabdat.xab$l_nxt = (void *) &xabfhc;
12129
12130 xabfhc = cc$rms_xabfhc; /* To get record length */
12131 xabfhc.xab$l_nxt = (void *) &xabsum;
12132
12133 xabsum = cc$rms_xabsum; /* To get key and area information */
12134
12135 if (!((sts = sys$open(&fab_in)) & 1)) {
c5375c28
JM		 12136 PerlMem_free(vmsin);
12137 PerlMem_free(vmsout);
12138 PerlMem_free(esa);
d584a1c6
JM		 12139 if (esal != NULL)
12140 PerlMem_free(esal);
c5375c28 12141 PerlMem_free(rsa);
d584a1c6
JM		 12142 if (rsal != NULL)
12143 PerlMem_free(rsal);
a480973c
JM		 12144 set_vaxc_errno(sts);
12145 switch (sts) {
12146 case RMS$_FNF: case RMS$_DNF:
12147 set_errno(ENOENT); break;
12148 case RMS$_DIR:
12149 set_errno(ENOTDIR); break;
12150 case RMS$_DEV:
12151 set_errno(ENODEV); break;
12152 case RMS$_SYN:
12153 set_errno(EINVAL); break;
12154 case RMS$_PRV:
12155 set_errno(EACCES); break;
12156 default:
12157 set_errno(EVMSERR);
12158 }
12159 return 0;
12160 }
12161
12162 nam_out = nam;
12163 fab_out = fab_in;
12164 fab_out.fab$w_ifi = 0;
12165 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12166 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12167 fab_out.fab$l_fop = FAB$M_SQO;
a1887106
JM		 12168 rms_bind_fab_nam(fab_out, nam_out);
12169 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12170 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12171 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
d584a1c6 12172 esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
c5375c28 12173 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
d584a1c6
JM		 12174 rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12175 if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
12176 esal_out = NULL;
12177 rsal_out = NULL;
12178#if !defined(__VAX) && defined(NAML$C_MAXRSS)
12179 esal_out = PerlMem_malloc(VMS_MAXRSS);
12180 if (esal_out == NULL) _ckvmssts(SS$_INSFMEM);
12181 rsal_out = PerlMem_malloc(VMS_MAXRSS);
12182 if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
12183#endif
12184 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12185 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
a480973c
JM		 12186
12187 if (preserve_dates == 0) { /* Act like DCL COPY */
a1887106 12188 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
a480973c 12189 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
a1887106 12190 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 12191 PerlMem_free(vmsin);
12192 PerlMem_free(vmsout);
12193 PerlMem_free(esa);
d584a1c6
JM		 12194 if (esal != NULL)
12195 PerlMem_free(esal);
c5375c28 12196 PerlMem_free(rsa);
d584a1c6
JM		 12197 if (rsal != NULL)
12198 PerlMem_free(rsal);
c5375c28 12199 PerlMem_free(esa_out);
d584a1c6
JM		 12200 if (esal_out != NULL)
12201 PerlMem_free(esal_out);
12202 PerlMem_free(rsa_out);
12203 if (rsal_out != NULL)
12204 PerlMem_free(rsal_out);
a480973c
JM		 12205 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12206 set_vaxc_errno(sts);
12207 return 0;
12208 }
12209 fab_out.fab$l_xab = (void *) &xabdat;
a1887106
JM		 12210 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12211 preserve_dates = 1;
a480973c
JM		 12212 }
12213 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12214 preserve_dates =0; /* bitmask from this point forward */
12215
12216 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
a1887106 12217 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 12218 PerlMem_free(vmsin);
12219 PerlMem_free(vmsout);
12220 PerlMem_free(esa);
d584a1c6
JM		 12221 if (esal != NULL)
12222 PerlMem_free(esal);
c5375c28 12223 PerlMem_free(rsa);
d584a1c6
JM		 12224 if (rsal != NULL)
12225 PerlMem_free(rsal);
c5375c28 12226 PerlMem_free(esa_out);
d584a1c6
JM		 12227 if (esal_out != NULL)
12228 PerlMem_free(esal_out);
12229 PerlMem_free(rsa_out);
12230 if (rsal_out != NULL)
12231 PerlMem_free(rsal_out);
a480973c
JM		 12232 set_vaxc_errno(sts);
12233 switch (sts) {
12234 case RMS$_DNF:
12235 set_errno(ENOENT); break;
12236 case RMS$_DIR:
12237 set_errno(ENOTDIR); break;
12238 case RMS$_DEV:
12239 set_errno(ENODEV); break;
12240 case RMS$_SYN:
12241 set_errno(EINVAL); break;
12242 case RMS$_PRV:
12243 set_errno(EACCES); break;
12244 default:
12245 set_errno(EVMSERR);
12246 }
12247 return 0;
12248 }
12249 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12250 if (preserve_dates & 2) {
12251 /* sys$close() will process xabrdt, not xabdat */
12252 xabrdt = cc$rms_xabrdt;
12253#ifndef __GNUC__
12254 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12255#else
12256 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12257 * is unsigned long[2], while DECC & VAXC use a struct */
12258 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12259#endif
12260 fab_out.fab$l_xab = (void *) &xabrdt;
12261 }
12262
c5375c28
JM		 12263 ubf = PerlMem_malloc(32256);
12264 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
a480973c
JM		 12265 rab_in = cc$rms_rab;
12266 rab_in.rab$l_fab = &fab_in;
12267 rab_in.rab$l_rop = RAB$M_BIO;
12268 rab_in.rab$l_ubf = ubf;
12269 rab_in.rab$w_usz = 32256;
12270 if (!((sts = sys$connect(&rab_in)) & 1)) {
12271 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12272 PerlMem_free(vmsin);
12273 PerlMem_free(vmsout);
c5375c28 12274 PerlMem_free(ubf);
d584a1c6
JM		 12275 PerlMem_free(esa);
12276 if (esal != NULL)
12277 PerlMem_free(esal);
c5375c28 12278 PerlMem_free(rsa);
d584a1c6
JM		 12279 if (rsal != NULL)
12280 PerlMem_free(rsal);
c5375c28 12281 PerlMem_free(esa_out);
d584a1c6
JM		 12282 if (esal_out != NULL)
12283 PerlMem_free(esal_out);
12284 PerlMem_free(rsa_out);
12285 if (rsal_out != NULL)
12286 PerlMem_free(rsal_out);
a480973c
JM		 12287 set_errno(EVMSERR); set_vaxc_errno(sts);
12288 return 0;
12289 }
12290
12291 rab_out = cc$rms_rab;
12292 rab_out.rab$l_fab = &fab_out;
12293 rab_out.rab$l_rbf = ubf;
12294 if (!((sts = sys$connect(&rab_out)) & 1)) {
12295 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12296 PerlMem_free(vmsin);
12297 PerlMem_free(vmsout);
c5375c28 12298 PerlMem_free(ubf);
d584a1c6
JM		 12299 PerlMem_free(esa);
12300 if (esal != NULL)
12301 PerlMem_free(esal);
c5375c28 12302 PerlMem_free(rsa);
d584a1c6
JM		 12303 if (rsal != NULL)
12304 PerlMem_free(rsal);
c5375c28 12305 PerlMem_free(esa_out);
d584a1c6
JM		 12306 if (esal_out != NULL)
12307 PerlMem_free(esal_out);
12308 PerlMem_free(rsa_out);
12309 if (rsal_out != NULL)
12310 PerlMem_free(rsal_out);
a480973c
JM		 12311 set_errno(EVMSERR); set_vaxc_errno(sts);
12312 return 0;
12313 }
12314
12315 while ((sts = sys$read(&rab_in))) { /* always true */
12316 if (sts == RMS$_EOF) break;
12317 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12318 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12319 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12320 PerlMem_free(vmsin);
12321 PerlMem_free(vmsout);
c5375c28 12322 PerlMem_free(ubf);
d584a1c6
JM		 12323 PerlMem_free(esa);
12324 if (esal != NULL)
12325 PerlMem_free(esal);
c5375c28 12326 PerlMem_free(rsa);
d584a1c6
JM		 12327 if (rsal != NULL)
12328 PerlMem_free(rsal);
c5375c28 12329 PerlMem_free(esa_out);
d584a1c6
JM		 12330 if (esal_out != NULL)
12331 PerlMem_free(esal_out);
12332 PerlMem_free(rsa_out);
12333 if (rsal_out != NULL)
12334 PerlMem_free(rsal_out);
a480973c
JM		 12335 set_errno(EVMSERR); set_vaxc_errno(sts);
12336 return 0;
12337 }
12338 }
12339
12340
12341 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12342 sys$close(&fab_in); sys$close(&fab_out);
12343 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
a480973c 12344
c5375c28
JM		 12345 PerlMem_free(vmsin);
12346 PerlMem_free(vmsout);
c5375c28 12347 PerlMem_free(ubf);
d584a1c6
JM		 12348 PerlMem_free(esa);
12349 if (esal != NULL)
12350 PerlMem_free(esal);
c5375c28 12351 PerlMem_free(rsa);
d584a1c6
JM		 12352 if (rsal != NULL)
12353 PerlMem_free(rsal);
c5375c28 12354 PerlMem_free(esa_out);
d584a1c6
JM		 12355 if (esal_out != NULL)
12356 PerlMem_free(esal_out);
12357 PerlMem_free(rsa_out);
12358 if (rsal_out != NULL)
12359 PerlMem_free(rsal_out);
12360
12361 if (!(sts & 1)) {
12362 set_errno(EVMSERR); set_vaxc_errno(sts);
12363 return 0;
12364 }
12365
a480973c
JM		 12366 return 1;
12367
12368} /* end of rmscopy() */
a5f75d66
AD		 12369/*}}}*/
12370
12371
748a9306
LW		 12372/*** The following glue provides 'hooks' to make some of the routines
12373 * from this file available from Perl. These routines are sufficiently
12374 * basic, and are required sufficiently early in the build process,
12375 * that's it's nice to have them available to miniperl as well as the
12376 * full Perl, so they're set up here instead of in an extension. The
12377 * Perl code which handles importation of these names into a given
12378 * package lives in [.VMS]Filespec.pm in @INC.
12379 */
12380
12381void
5c84aa53 12382rmsexpand_fromperl(pTHX_ CV *cv)
01b8edb6 12383{
12384 dXSARGS;
bbce6d69 12385 char *fspec, *defspec = NULL, *rslt;
2d8e6c8d 12386 STRLEN n_a;
360732b5 12387 int fs_utf8, dfs_utf8;
01b8edb6 12388
360732b5
JM		 12389 fs_utf8 = 0;
12390 dfs_utf8 = 0;
bbce6d69 12391 if (!items || items > 2)
5c84aa53 12392 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
2d8e6c8d 12393 fspec = SvPV(ST(0),n_a);
360732b5 12394 fs_utf8 = SvUTF8(ST(0));
bbce6d69 12395 if (!fspec || !*fspec) XSRETURN_UNDEF;
360732b5
JM		 12396 if (items == 2) {
12397 defspec = SvPV(ST(1),n_a);
12398 dfs_utf8 = SvUTF8(ST(1));
12399 }
12400 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
bbce6d69 12401 ST(0) = sv_newmortal();
360732b5
JM		 12402 if (rslt != NULL) {
12403 sv_usepvn(ST(0),rslt,strlen(rslt));
12404 if (fs_utf8) {
12405 SvUTF8_on(ST(0));
12406 }
12407 }
740ce14c 12408 XSRETURN(1);
01b8edb6 12409}
12410
12411void
5c84aa53 12412vmsify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12413{
12414 dXSARGS;
12415 char *vmsified;
2d8e6c8d 12416 STRLEN n_a;
360732b5 12417 int utf8_fl;
748a9306 12418
5c84aa53 12419 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
360732b5
JM		 12420 utf8_fl = SvUTF8(ST(0));
12421 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12422 ST(0) = sv_newmortal();
360732b5
JM		 12423 if (vmsified != NULL) {
12424 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12425 if (utf8_fl) {
12426 SvUTF8_on(ST(0));
12427 }
12428 }
748a9306
LW		 12429 XSRETURN(1);
12430}
12431
12432void
5c84aa53 12433unixify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12434{
12435 dXSARGS;
12436 char *unixified;
2d8e6c8d 12437 STRLEN n_a;
360732b5 12438 int utf8_fl;
748a9306 12439
5c84aa53 12440 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
360732b5
JM		 12441 utf8_fl = SvUTF8(ST(0));
12442 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12443 ST(0) = sv_newmortal();
360732b5
JM		 12444 if (unixified != NULL) {
12445 sv_usepvn(ST(0),unixified,strlen(unixified));
12446 if (utf8_fl) {
12447 SvUTF8_on(ST(0));
12448 }
12449 }
748a9306
LW		 12450 XSRETURN(1);
12451}
12452
12453void
5c84aa53 12454fileify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12455{
12456 dXSARGS;
12457 char *fileified;
2d8e6c8d 12458 STRLEN n_a;
360732b5 12459 int utf8_fl;
748a9306 12460
5c84aa53 12461 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
360732b5
JM		 12462 utf8_fl = SvUTF8(ST(0));
12463 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12464 ST(0) = sv_newmortal();
360732b5
JM		 12465 if (fileified != NULL) {
12466 sv_usepvn(ST(0),fileified,strlen(fileified));
12467 if (utf8_fl) {
12468 SvUTF8_on(ST(0));
12469 }
12470 }
748a9306
LW		 12471 XSRETURN(1);
12472}
12473
12474void
5c84aa53 12475pathify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12476{
12477 dXSARGS;
12478 char *pathified;
2d8e6c8d 12479 STRLEN n_a;
360732b5 12480 int utf8_fl;
748a9306 12481
5c84aa53 12482 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
360732b5
JM		 12483 utf8_fl = SvUTF8(ST(0));
12484 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12485 ST(0) = sv_newmortal();
360732b5
JM		 12486 if (pathified != NULL) {
12487 sv_usepvn(ST(0),pathified,strlen(pathified));
12488 if (utf8_fl) {
12489 SvUTF8_on(ST(0));
12490 }
12491 }
748a9306
LW		 12492 XSRETURN(1);
12493}
12494
12495void
5c84aa53 12496vmspath_fromperl(pTHX_ CV *cv)
748a9306
LW		 12497{
12498 dXSARGS;
12499 char *vmspath;
2d8e6c8d 12500 STRLEN n_a;
360732b5 12501 int utf8_fl;
748a9306 12502
5c84aa53 12503 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
360732b5
JM		 12504 utf8_fl = SvUTF8(ST(0));
12505 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12506 ST(0) = sv_newmortal();
360732b5
JM		 12507 if (vmspath != NULL) {
12508 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12509 if (utf8_fl) {
12510 SvUTF8_on(ST(0));
12511 }
12512 }
748a9306
LW		 12513 XSRETURN(1);
12514}
12515
12516void
5c84aa53 12517unixpath_fromperl(pTHX_ CV *cv)
748a9306
LW		 12518{
12519 dXSARGS;
12520 char *unixpath;
2d8e6c8d 12521 STRLEN n_a;
360732b5 12522 int utf8_fl;
748a9306 12523
5c84aa53 12524 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
360732b5
JM		 12525 utf8_fl = SvUTF8(ST(0));
12526 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12527 ST(0) = sv_newmortal();
360732b5
JM		 12528 if (unixpath != NULL) {
12529 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12530 if (utf8_fl) {
12531 SvUTF8_on(ST(0));
12532 }
12533 }
748a9306
LW		 12534 XSRETURN(1);
12535}
12536
12537void
5c84aa53 12538candelete_fromperl(pTHX_ CV *cv)
748a9306
LW		 12539{
12540 dXSARGS;
988c775c 12541 char *fspec, *fsp;
a5f75d66
AD		 12542 SV *mysv;
12543 IO *io;
2d8e6c8d 12544 STRLEN n_a;
748a9306 12545
5c84aa53 12546 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
a5f75d66
AD		 12547
12548 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
988c775c
JM		 12549 Newx(fspec, VMS_MAXRSS, char);
12550 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
a5f75d66 12551 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 12552 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
a5f75d66 12553 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12554 ST(0) = &PL_sv_no;
988c775c 12555 Safefree(fspec);
a5f75d66
AD		 12556 XSRETURN(1);
12557 }
12558 fsp = fspec;
12559 }
12560 else {
2d8e6c8d 12561 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
a5f75d66 12562 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12563 ST(0) = &PL_sv_no;
988c775c 12564 Safefree(fspec);
a5f75d66
AD		 12565 XSRETURN(1);
12566 }
12567 }
12568
54310121 12569 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
988c775c 12570 Safefree(fspec);
a5f75d66
AD		 12571 XSRETURN(1);
12572}
12573
12574void
5c84aa53 12575rmscopy_fromperl(pTHX_ CV *cv)
a5f75d66
AD		 12576{
12577 dXSARGS;
a480973c 12578 char *inspec, *outspec, *inp, *outp;
a3e9d8c9 12579 int date_flag;
a5f75d66
AD		 12580 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12581 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12582 unsigned long int sts;
12583 SV *mysv;
12584 IO *io;
2d8e6c8d 12585 STRLEN n_a;
a5f75d66 12586
a3e9d8c9 12587 if (items < 2 || items > 3)
5c84aa53 12588 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
a5f75d66
AD		 12589
12590 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
a480973c 12591 Newx(inspec, VMS_MAXRSS, char);
a5f75d66 12592 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 12593 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
a5f75d66 12594 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12595 ST(0) = &PL_sv_no;
a480973c 12596 Safefree(inspec);
a5f75d66
AD		 12597 XSRETURN(1);
12598 }
12599 inp = inspec;
12600 }
12601 else {
2d8e6c8d 12602 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
a5f75d66 12603 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12604 ST(0) = &PL_sv_no;
a480973c 12605 Safefree(inspec);
a5f75d66
AD		 12606 XSRETURN(1);
12607 }
12608 }
12609 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
a480973c 12610 Newx(outspec, VMS_MAXRSS, char);
a5f75d66 12611 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 12612 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
a5f75d66 12613 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12614 ST(0) = &PL_sv_no;
a480973c
JM		 12615 Safefree(inspec);
12616 Safefree(outspec);
a5f75d66
AD		 12617 XSRETURN(1);
12618 }
12619 outp = outspec;
12620 }
12621 else {
2d8e6c8d 12622 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
a5f75d66 12623 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12624 ST(0) = &PL_sv_no;
a480973c
JM		 12625 Safefree(inspec);
12626 Safefree(outspec);
a5f75d66
AD		 12627 XSRETURN(1);
12628 }
12629 }
a3e9d8c9 12630 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
a5f75d66 12631
54310121 12632 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
a480973c
JM		 12633 Safefree(inspec);
12634 Safefree(outspec);
748a9306
LW		 12635 XSRETURN(1);
12636}
12637
a480973c
JM		 12638/* The mod2fname is limited to shorter filenames by design, so it should
12639 * not be modified to support longer EFS pathnames
12640 */
4b19af01 12641void
fd8cd3a3 12642mod2fname(pTHX_ CV *cv)
4b19af01
CB		 12643{
12644 dXSARGS;
12645 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12646 workbuff[NAM$C_MAXRSS*1 + 1];
12647 int total_namelen = 3, counter, num_entries;
12648 /* ODS-5 ups this, but we want to be consistent, so... */
12649 int max_name_len = 39;
12650 AV *in_array = (AV *)SvRV(ST(0));
12651
12652 num_entries = av_len(in_array);
12653
12654 /* All the names start with PL_. */
12655 strcpy(ultimate_name, "PL_");
12656
12657 /* Clean up our working buffer */
12658 Zero(work_name, sizeof(work_name), char);
12659
12660 /* Run through the entries and build up a working name */
12661 for(counter = 0; counter <= num_entries; counter++) {
12662 /* If it's not the first name then tack on a __ */
12663 if (counter) {
12664 strcat(work_name, "__");
12665 }
12666 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
12667 PL_na));
12668 }
12669
12670 /* Check to see if we actually have to bother...*/
12671 if (strlen(work_name) + 3 <= max_name_len) {
12672 strcat(ultimate_name, work_name);
12673 } else {
12674 /* It's too darned big, so we need to go strip. We use the same */
12675 /* algorithm as xsubpp does. First, strip out doubled __ */
12676 char *source, *dest, last;
12677 dest = workbuff;
12678 last = 0;
12679 for (source = work_name; *source; source++) {
12680 if (last == *source && last == '_') {
12681 continue;
12682 }
12683 *dest++ = *source;
12684 last = *source;
12685 }
12686 /* Go put it back */
12687 strcpy(work_name, workbuff);
12688 /* Is it still too big? */
12689 if (strlen(work_name) + 3 > max_name_len) {
12690 /* Strip duplicate letters */
12691 last = 0;
12692 dest = workbuff;
12693 for (source = work_name; *source; source++) {
12694 if (last == toupper(*source)) {
12695 continue;
12696 }
12697 *dest++ = *source;
12698 last = toupper(*source);
12699 }
12700 strcpy(work_name, workbuff);
12701 }
12702
12703 /* Is it *still* too big? */
12704 if (strlen(work_name) + 3 > max_name_len) {
12705 /* Too bad, we truncate */
12706 work_name[max_name_len - 2] = 0;
12707 }
12708 strcat(ultimate_name, work_name);
12709 }
12710
12711 /* Okay, return it */
12712 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12713 XSRETURN(1);
12714}
12715
748a9306 12716void
96e176bf
CL		 12717hushexit_fromperl(pTHX_ CV *cv)
12718{
12719 dXSARGS;
12720
12721 if (items > 0) {
12722 VMSISH_HUSHED = SvTRUE(ST(0));
12723 }
12724 ST(0) = boolSV(VMSISH_HUSHED);
12725 XSRETURN(1);
12726}
12727
dca5a913
JM		 12728
12729PerlIO *
12730Perl_vms_start_glob
12731 (pTHX_ SV *tmpglob,
12732 IO *io)
12733{
12734 PerlIO *fp;
12735 struct vs_str_st *rslt;
12736 char *vmsspec;
12737 char *rstr;
12738 char *begin, *cp;
12739 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12740 PerlIO *tmpfp;
12741 STRLEN i;
12742 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12743 struct dsc$descriptor_vs rsdsc;
12744 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12745 unsigned long hasver = 0, isunix = 0;
12746 unsigned long int lff_flags = 0;
12747 int rms_sts;
12748
12749#ifdef VMS_LONGNAME_SUPPORT
12750 lff_flags = LIB$M_FIL_LONG_NAMES;
12751#endif
12752 /* The Newx macro will not allow me to assign a smaller array
12753 * to the rslt pointer, so we will assign it to the begin char pointer
12754 * and then copy the value into the rslt pointer.
12755 */
12756 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12757 rslt = (struct vs_str_st *)begin;
12758 rslt->length = 0;
12759 rstr = &rslt->str[0];
12760 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12761 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12762 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12763 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12764
12765 Newx(vmsspec, VMS_MAXRSS, char);
12766
12767 /* We could find out if there's an explicit dev/dir or version
12768 by peeking into lib$find_file's internal context at
12769 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12770 but that's unsupported, so I don't want to do it now and
12771 have it bite someone in the future. */
12772 /* Fix-me: vms_split_path() is the only way to do this, the
12773 existing method will fail with many legal EFS or UNIX specifications
12774 */
12775
12776 cp = SvPV(tmpglob,i);
12777
12778 for (; i; i--) {
12779 if (cp[i] == ';') hasver = 1;
12780 if (cp[i] == '.') {
12781 if (sts) hasver = 1;
12782 else sts = 1;
12783 }
12784 if (cp[i] == '/') {
12785 hasdir = isunix = 1;
12786 break;
12787 }
12788 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12789 hasdir = 1;
12790 break;
12791 }
12792 }
12793 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
990cad08 12794 int found = 0;
dca5a913
JM		 12795 Stat_t st;
12796 int stat_sts;
12797 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12798 if (!stat_sts && S_ISDIR(st.st_mode)) {
360732b5 12799 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
dca5a913 12800 ok = (wilddsc.dsc$a_pointer != NULL);
ff675744
CB		 12801 /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12802 hasdir = 1;
dca5a913
JM		 12803 }
12804 else {
360732b5 12805 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
dca5a913
JM		 12806 ok = (wilddsc.dsc$a_pointer != NULL);
12807 }
12808 if (ok)
12809 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12810
12811 /* If not extended character set, replace ? with % */
12812 /* With extended character set, ? is a wildcard single character */
12813 if (!decc_efs_case_preserve) {
12814 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12815 if (*cp == '?') *cp = '%';
12816 }
12817 sts = SS$_NORMAL;
12818 while (ok && $VMS_STATUS_SUCCESS(sts)) {
12819 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12820 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12821
12822 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12823 &dfltdsc,NULL,&rms_sts,&lff_flags);
12824 if (!$VMS_STATUS_SUCCESS(sts))
12825 break;
12826
990cad08
CB		 12827 found++;
12828
dca5a913
JM		 12829 /* with varying string, 1st word of buffer contains result length */
12830 rstr[rslt->length] = '\0';
12831
12832 /* Find where all the components are */
12833 v_sts = vms_split_path
360732b5 12834 (rstr,
dca5a913
JM		 12835 &v_spec,
12836 &v_len,
12837 &r_spec,
12838 &r_len,
12839 &d_spec,
12840 &d_len,
12841 &n_spec,
12842 &n_len,
12843 &e_spec,
12844 &e_len,
12845 &vs_spec,
12846 &vs_len);
12847
12848 /* If no version on input, truncate the version on output */
12849 if (!hasver && (vs_len > 0)) {
12850 *vs_spec = '\0';
12851 vs_len = 0;
12852
12853 /* No version & a null extension on UNIX handling */
12854 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12855 e_len = 0;
12856 *e_spec = '\0';
12857 }
12858 }
12859
12860 if (!decc_efs_case_preserve) {
12861 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12862 }
12863
12864 if (hasdir) {
12865 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12866 begin = rstr;
12867 }
12868 else {
12869 /* Start with the name */
12870 begin = n_spec;
12871 }
12872 strcat(begin,"\n");
12873 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12874 }
12875 if (cxt) (void)lib$find_file_end(&cxt);
990cad08
CB		 12876
12877 if (!found) {
12878 /* Be POSIXish: return the input pattern when no matches */
12879 begin = SvPVX(tmpglob);
12880 strcat(begin,"\n");
12881 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12882 }
12883
dca5a913
JM		 12884 if (ok && sts != RMS$_NMF &&
12885 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12886 if (!ok) {
12887 if (!(sts & 1)) {
12888 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12889 }
12890 PerlIO_close(tmpfp);
12891 fp = NULL;
12892 }
12893 else {
12894 PerlIO_rewind(tmpfp);
12895 IoTYPE(io) = IoTYPE_RDONLY;
12896 IoIFP(io) = fp = tmpfp;
12897 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
12898 }
12899 }
12900 Safefree(vmsspec);
12901 Safefree(rslt);
12902 return fp;
12903}
12904
cd1191f1 12905
2497a41f
JM		 12906#ifdef HAS_SYMLINK
12907static char *
5c4d031a 12908mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
d584a1c6 12909 int *utf8_fl);
2497a41f
JM		 12910
12911void
12912vms_realpath_fromperl(pTHX_ CV *cv)
12913{
d584a1c6
JM		 12914 dXSARGS;
12915 char *fspec, *rslt_spec, *rslt;
12916 STRLEN n_a;
2497a41f 12917
d584a1c6
JM		 12918 if (!items || items != 1)
12919 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
2497a41f 12920
d584a1c6
JM		 12921 fspec = SvPV(ST(0),n_a);
12922 if (!fspec || !*fspec) XSRETURN_UNDEF;
2497a41f 12923
d584a1c6
JM		 12924 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12925 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12926
12927 ST(0) = sv_newmortal();
12928 if (rslt != NULL)
12929 sv_usepvn(ST(0),rslt,strlen(rslt));
12930 else
12931 Safefree(rslt_spec);
12932 XSRETURN(1);
2497a41f 12933}
2ee6e19d
CB		 12934
12935/*
12936 * A thin wrapper around decc$symlink to make sure we follow the
12937 * standard and do not create a symlink with a zero-length name.
12938 */
12939/*{{{ int my_symlink(const char *path1, const char *path2)*/
12940int my_symlink(const char *path1, const char *path2) {
12941 if (!path2 || !*path2) {
12942 SETERRNO(ENOENT, SS$_NOSUCHFILE);
12943 return -1;
12944 }
12945 return symlink(path1, path2);
12946}
12947/*}}}*/
12948
12949#endif /* HAS_SYMLINK */
2497a41f
JM		 12950
12951#if __CRTL_VER >= 70301000 && !defined(__VAX)
12952int do_vms_case_tolerant(void);
12953
12954void
12955vms_case_tolerant_fromperl(pTHX_ CV *cv)
12956{
12957 dXSARGS;
12958 ST(0) = boolSV(do_vms_case_tolerant());
12959 XSRETURN(1);
12960}
12961#endif
12962
96e176bf
CL		 12963void
12964Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12965 struct interp_intern *dst)
12966{
12967 memcpy(dst,src,sizeof(struct interp_intern));
12968}
12969
12970void
12971Perl_sys_intern_clear(pTHX)
12972{
12973}
12974
12975void
12976Perl_sys_intern_init(pTHX)
12977{
3ff49832
CL		 12978 unsigned int ix = RAND_MAX;
12979 double x;
96e176bf
CL		 12980
12981 VMSISH_HUSHED = 0;
12982
7a7fd8e0
JM		 12983 /* fix me later to track running under GNV */
12984 /* this allows some limited testing */
12985 MY_POSIX_EXIT = decc_filename_unix_report;
12986
96e176bf
CL		 12987 x = (float)ix;
12988 MY_INV_RAND_MAX = 1./x;
ff7adb52 12989}
96e176bf
CL		 12990
12991void
f7ddb74a 12992init_os_extras(void)
748a9306 12993{
a69a6dba 12994 dTHX;
748a9306 12995 char* file = __FILE__;
988c775c 12996 if (decc_disable_to_vms_logname_translation) {
93948341
CB		 12997 no_translate_barewords = TRUE;
12998 } else {
12999 no_translate_barewords = FALSE;
13000 }
748a9306 13001
740ce14c 13002 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
a5f75d66
AD		 13003 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13004 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13005 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13006 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13007 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13008 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13009 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4b19af01 13010 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
a5f75d66 13011 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
96e176bf 13012 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
f7ddb74a
JM		 13013#ifdef HAS_SYMLINK
13014 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
13015#endif
f7ddb74a 13016#if __CRTL_VER >= 70301000 && !defined(__VAX)
d584a1c6
JM		 13017 newXSproto("VMS::Filepec::vms_case_tolerant",
13018 vms_case_tolerant_fromperl, file, "$");
f7ddb74a 13019#endif
17f28c40 13020
afd8f436 13021 store_pipelocs(aTHX); /* will redo any earlier attempts */
22d4bb9c 13022
748a9306
LW		 13023 return;
13024}
13025
f7ddb74a
JM		 13026#ifdef HAS_SYMLINK
13027
13028#if __CRTL_VER == 80200000
13029/* This missed getting in to the DECC SDK for 8.2 */
13030char *realpath(const char *file_name, char * resolved_name, ...);
13031#endif
13032
13033/*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13034/* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13035 * The perl fallback routine to provide realpath() is not as efficient
13036 * on OpenVMS.
13037 */
d584a1c6
JM		 13038
13039/* Hack, use old stat() as fastest way of getting ino_t and device */
13040int decc$stat(const char *name, void * statbuf);
13041
13042
13043/* Realpath is fragile. In 8.3 it does not work if the feature
13044 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13045 * links are implemented in RMS, not the CRTL. It also can fail if the
13046 * user does not have read/execute access to some of the directories.
13047 * So in order for Do What I Mean mode to work, if realpath() fails,
13048 * fall back to looking up the filename by the device name and FID.
13049 */
13050
13051int vms_fid_to_name(char * outname, int outlen, const char * name)
13052{
13053struct statbuf_t {
13054 char * st_dev;
13055 __ino16_t st_ino[3];
13056 unsigned short padw;
13057 unsigned long padl[30]; /* plenty of room */
13058} statbuf;
13059int sts;
13060struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13061struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13062
13063 sts = decc$stat(name, &statbuf);
13064 if (sts == 0) {
13065
13066 dvidsc.dsc$a_pointer=statbuf.st_dev;
13067 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13068
13069 specdsc.dsc$a_pointer = outname;
13070 specdsc.dsc$w_length = outlen-1;
13071
13072 sts = lib$fid_to_name
13073 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13074 if ($VMS_STATUS_SUCCESS(sts)) {
13075 outname[specdsc.dsc$w_length] = 0;
13076 return 0;
13077 }
13078 }
13079 return sts;
13080}
13081
13082
13083
f7ddb74a 13084static char *
5c4d031a 13085mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
d584a1c6 13086 int *utf8_fl)
f7ddb74a 13087{
d584a1c6
JM		 13088 char * rslt = NULL;
13089
13090 if (decc_posix_compliant_pathnames)
13091 rslt = realpath(filespec, outbuf);
13092
13093 if (rslt == NULL) {
13094 char * vms_spec;
13095 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13096 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13097 int file_len;
13098
13099 /* Fall back to fid_to_name */
13100
13101 Newx(vms_spec, VMS_MAXRSS + 1, char);
13102
13103 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13104 if (sts == 0) {
13105
13106
13107 /* Now need to trim the version off */
13108 sts = vms_split_path
13109 (vms_spec,
13110 &v_spec,
13111 &v_len,
13112 &r_spec,
13113 &r_len,
13114 &d_spec,
13115 &d_len,
13116 &n_spec,
13117 &n_len,
13118 &e_spec,
13119 &e_len,
13120 &vs_spec,
13121 &vs_len);
13122
13123
13124 if (sts == 0) {
13125 int file_len;
13126
13127 /* Trim off the version */
13128 file_len = v_len + r_len + d_len + n_len + e_len;
13129 vms_spec[file_len] = 0;
13130
13131 /* The result is expected to be in UNIX format */
13132 rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13133 }
13134 }
13135
13136 Safefree(vms_spec);
13137 }
13138 return rslt;
f7ddb74a
JM		 13139}
13140
13141/*}}}*/
13142/* External entry points */
360732b5
JM		 13143char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13144{ return do_vms_realpath(filespec, outbuf, utf8_fl); }
f7ddb74a 13145#else
360732b5 13146char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
f7ddb74a
JM		 13147{ return NULL; }
13148#endif
13149
13150
13151#if __CRTL_VER >= 70301000 && !defined(__VAX)
13152/* case_tolerant */
13153
13154/*{{{int do_vms_case_tolerant(void)*/
13155/* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13156 * controlled by a process setting.
13157 */
13158int do_vms_case_tolerant(void)
13159{
13160 return vms_process_case_tolerant;
13161}
13162/*}}}*/
13163/* External entry points */
13164int Perl_vms_case_tolerant(void)
13165{ return do_vms_case_tolerant(); }
13166#else
13167int Perl_vms_case_tolerant(void)
13168{ return vms_process_case_tolerant; }
13169#endif
13170
13171
13172 /* Start of DECC RTL Feature handling */
13173
13174static int sys_trnlnm
13175 (const char * logname,
13176 char * value,
13177 int value_len)
13178{
13179 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13180 const unsigned long attr = LNM$M_CASE_BLIND;
13181 struct dsc$descriptor_s name_dsc;
13182 int status;
13183 unsigned short result;
13184 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13185 {0, 0, 0, 0}};
13186
13187 name_dsc.dsc$w_length = strlen(logname);
13188 name_dsc.dsc$a_pointer = (char *)logname;
13189 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13190 name_dsc.dsc$b_class = DSC$K_CLASS_S;
13191
13192 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13193
13194 if ($VMS_STATUS_SUCCESS(status)) {
13195
13196 /* Null terminate and return the string */
13197 /*--------------------------------------*/
13198 value[result] = 0;
13199 }
13200
13201 return status;
13202}
13203
13204static int sys_crelnm
13205 (const char * logname,
13206 const char * value)
13207{
13208 int ret_val;
13209 const char * proc_table = "LNM$PROCESS_TABLE";
13210 struct dsc$descriptor_s proc_table_dsc;
13211 struct dsc$descriptor_s logname_dsc;
13212 struct itmlst_3 item_list[2];
13213
13214 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13215 proc_table_dsc.dsc$w_length = strlen(proc_table);
13216 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13217 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13218
13219 logname_dsc.dsc$a_pointer = (char *) logname;
13220 logname_dsc.dsc$w_length = strlen(logname);
13221 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13222 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13223
13224 item_list[0].buflen = strlen(value);
13225 item_list[0].itmcode = LNM$_STRING;
13226 item_list[0].bufadr = (char *)value;
13227 item_list[0].retlen = NULL;
13228
13229 item_list[1].buflen = 0;
13230 item_list[1].itmcode = 0;
13231
13232 ret_val = sys$crelnm
13233 (NULL,
13234 (const struct dsc$descriptor_s *)&proc_table_dsc,
13235 (const struct dsc$descriptor_s *)&logname_dsc,
13236 NULL,
13237 (const struct item_list_3 *) item_list);
13238
13239 return ret_val;
13240}
13241
f7ddb74a
JM		 13242/* C RTL Feature settings */
13243
13244static int set_features
13245 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
13246 int (* cli_routine)(void), /* Not documented */
13247 void *image_info) /* Not documented */
13248{
13249 int status;
13250 int s;
13251 int dflt;
13252 char* str;
13253 char val_str[10];
3c841f20 13254#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
f7ddb74a
JM		 13255 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13256 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13257 unsigned long case_perm;
13258 unsigned long case_image;
3c841f20 13259#endif
f7ddb74a 13260
9c1171d1
JM		 13261 /* Allow an exception to bring Perl into the VMS debugger */
13262 vms_debug_on_exception = 0;
13263 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13264 if ($VMS_STATUS_SUCCESS(status)) {
13265 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13266 vms_debug_on_exception = 1;
13267 else
13268 vms_debug_on_exception = 0;
13269 }
13270
38a44b82 13271 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
360732b5
JM		 13272 vms_vtf7_filenames = 0;
13273 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13274 if ($VMS_STATUS_SUCCESS(status)) {
13275 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13276 vms_vtf7_filenames = 1;
13277 else
13278 vms_vtf7_filenames = 0;
13279 }
13280
e0e5e8d6
JM		 13281
13282 /* unlink all versions on unlink() or rename() */
d584a1c6 13283 vms_unlink_all_versions = 0;
e0e5e8d6
JM		 13284 status = sys_trnlnm
13285 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13286 if ($VMS_STATUS_SUCCESS(status)) {
13287 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13288 vms_unlink_all_versions = 1;
13289 else
13290 vms_unlink_all_versions = 0;
13291 }
13292
360732b5
JM		 13293 /* Dectect running under GNV Bash or other UNIX like shell */
13294#if __CRTL_VER >= 70300000 && !defined(__VAX)
13295 gnv_unix_shell = 0;
13296 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13297 if ($VMS_STATUS_SUCCESS(status)) {
13298 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13299 gnv_unix_shell = 1;
13300 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13301 set_feature_default("DECC$EFS_CHARSET", 1);
13302 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13303 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13304 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13305 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
e0e5e8d6 13306 vms_unlink_all_versions = 1;
360732b5
JM		 13307 }
13308 else
13309 gnv_unix_shell = 0;
13310 }
13311#endif
9c1171d1 13312
2497a41f
JM		 13313 /* hacks to see if known bugs are still present for testing */
13314
13315 /* Readdir is returning filenames in VMS syntax always */
13316 decc_bug_readdir_efs1 = 1;
13317 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13318 if ($VMS_STATUS_SUCCESS(status)) {
13319 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13320 decc_bug_readdir_efs1 = 1;
13321 else
13322 decc_bug_readdir_efs1 = 0;
13323 }
13324
13325 /* PCP mode requires creating /dev/null special device file */
2623a4a6 13326 decc_bug_devnull = 0;
2497a41f
JM		 13327 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13328 if ($VMS_STATUS_SUCCESS(status)) {
13329 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13330 decc_bug_devnull = 1;
682e4b71
JM		 13331 else
13332 decc_bug_devnull = 0;
2497a41f
JM		 13333 }
13334
13335 /* fgetname returning a VMS name in UNIX mode */
13336 decc_bug_fgetname = 1;
13337 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13338 if ($VMS_STATUS_SUCCESS(status)) {
13339 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13340 decc_bug_fgetname = 1;
13341 else
13342 decc_bug_fgetname = 0;
13343 }
13344
13345 /* UNIX directory names with no paths are broken in a lot of places */
13346 decc_dir_barename = 1;
13347 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13348 if ($VMS_STATUS_SUCCESS(status)) {
13349 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13350 decc_dir_barename = 1;
13351 else
13352 decc_dir_barename = 0;
13353 }
13354
f7ddb74a
JM		 13355#if __CRTL_VER >= 70300000 && !defined(__VAX)
13356 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13357 if (s >= 0) {
13358 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13359 if (decc_disable_to_vms_logname_translation < 0)
13360 decc_disable_to_vms_logname_translation = 0;
13361 }
13362
13363 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13364 if (s >= 0) {
13365 decc_efs_case_preserve = decc$feature_get_value(s, 1);
13366 if (decc_efs_case_preserve < 0)
13367 decc_efs_case_preserve = 0;
13368 }
13369
13370 s = decc$feature_get_index("DECC$EFS_CHARSET");
13371 if (s >= 0) {
13372 decc_efs_charset = decc$feature_get_value(s, 1);
13373 if (decc_efs_charset < 0)
13374 decc_efs_charset = 0;
13375 }
13376
13377 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13378 if (s >= 0) {
13379 decc_filename_unix_report = decc$feature_get_value(s, 1);
13380 if (decc_filename_unix_report > 0)
13381 decc_filename_unix_report = 1;
13382 else
13383 decc_filename_unix_report = 0;
13384 }
13385
13386 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13387 if (s >= 0) {
13388 decc_filename_unix_only = decc$feature_get_value(s, 1);
13389 if (decc_filename_unix_only > 0) {
13390 decc_filename_unix_only = 1;
13391 }
13392 else {
13393 decc_filename_unix_only = 0;
13394 }
13395 }
13396
13397 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13398 if (s >= 0) {
13399 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13400 if (decc_filename_unix_no_version < 0)
13401 decc_filename_unix_no_version = 0;
13402 }
13403
13404 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13405 if (s >= 0) {
13406 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13407 if (decc_readdir_dropdotnotype < 0)
13408 decc_readdir_dropdotnotype = 0;
13409 }
13410
13411 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13412 if ($VMS_STATUS_SUCCESS(status)) {
13413 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13414 if (s >= 0) {
13415 dflt = decc$feature_get_value(s, 4);
13416 if (dflt > 0) {
13417 decc_disable_posix_root = decc$feature_get_value(s, 1);
13418 if (decc_disable_posix_root <= 0) {
13419 decc$feature_set_value(s, 1, 1);
13420 decc_disable_posix_root = 1;
13421 }
13422 }
13423 else {
13424 /* Traditionally Perl assumes this is off */
13425 decc_disable_posix_root = 1;
13426 decc$feature_set_value(s, 1, 1);
13427 }
13428 }
13429 }
13430
13431#if __CRTL_VER >= 80200000
13432 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13433 if (s >= 0) {
13434 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13435 if (decc_posix_compliant_pathnames < 0)
13436 decc_posix_compliant_pathnames = 0;
13437 if (decc_posix_compliant_pathnames > 4)
13438 decc_posix_compliant_pathnames = 0;
13439 }
13440
13441#endif
13442#else
13443 status = sys_trnlnm
13444 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13445 if ($VMS_STATUS_SUCCESS(status)) {
13446 val_str[0] = _toupper(val_str[0]);
13447 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13448 decc_disable_to_vms_logname_translation = 1;
13449 }
13450 }
13451
13452#ifndef __VAX
13453 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13454 if ($VMS_STATUS_SUCCESS(status)) {
13455 val_str[0] = _toupper(val_str[0]);
13456 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13457 decc_efs_case_preserve = 1;
13458 }
13459 }
13460#endif
13461
13462 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13463 if ($VMS_STATUS_SUCCESS(status)) {
13464 val_str[0] = _toupper(val_str[0]);
13465 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13466 decc_filename_unix_report = 1;
13467 }
13468 }
13469 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13470 if ($VMS_STATUS_SUCCESS(status)) {
13471 val_str[0] = _toupper(val_str[0]);
13472 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13473 decc_filename_unix_only = 1;
13474 decc_filename_unix_report = 1;
13475 }
13476 }
13477 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13478 if ($VMS_STATUS_SUCCESS(status)) {
13479 val_str[0] = _toupper(val_str[0]);
13480 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13481 decc_filename_unix_no_version = 1;
13482 }
13483 }
13484 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13485 if ($VMS_STATUS_SUCCESS(status)) {
13486 val_str[0] = _toupper(val_str[0]);
13487 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13488 decc_readdir_dropdotnotype = 1;
13489 }
13490 }
13491#endif
13492
3c841f20 13493#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
f7ddb74a
JM		 13494
13495 /* Report true case tolerance */
13496 /*----------------------------*/
13497 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13498 if (!$VMS_STATUS_SUCCESS(status))
13499 case_perm = PPROP$K_CASE_BLIND;
13500 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13501 if (!$VMS_STATUS_SUCCESS(status))
13502 case_image = PPROP$K_CASE_BLIND;
13503 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13504 (case_image == PPROP$K_CASE_SENSITIVE))
13505 vms_process_case_tolerant = 0;
13506
13507#endif
13508
13509
13510 /* CRTL can be initialized past this point, but not before. */
13511/* DECC$CRTL_INIT(); */
13512
13513 return SS$_NORMAL;
13514}
13515
13516#ifdef __DECC
f7ddb74a
JM		 13517#pragma nostandard
13518#pragma extern_model save
13519#pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
f7ddb74a 13520 const __align (LONGWORD) int spare[8] = {0};
dfffea70
CB		 13521
13522/* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13523#if __DECC_VER >= 60560002
13524#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13525#else
13526#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
f7ddb74a 13527#endif
dfffea70
CB		 13528#endif /* __DECC */
13529
f7ddb74a
JM		 13530const long vms_cc_features = (const long)set_features;
13531
13532/*
13533** Force a reference to LIB$INITIALIZE to ensure it
13534** exists in the image.
13535*/
13536int lib$initialize(void);
13537#ifdef __DECC
13538#pragma extern_model strict_refdef
13539#endif
13540 int lib_init_ref = (int) lib$initialize;
13541
13542#ifdef __DECC
13543#pragma extern_model restore
13544#pragma standard
13545#endif
13546
748a9306 13547/* End of vms.c */
Unnamed repository; edit this file 'description' to name the repository.