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
Trim directory extension in pathify under EFS.
[perl5.git] / vms / vms.c
CommitLineData
b429d381 1/* vms.c
a0d0e21e 2 *
82dd182c 3 * VMS-specific routines for perl5
748a9306 4 *
82dd182c
CB		 5 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
6 * 2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
7 *
8 * You may distribute under the terms of either the GNU General Public
9 * License or the Artistic License, as specified in the README file.
10 *
11 * Please see Changes*.* or the Perl Repository Browser for revision history.
a0d0e21e
LW		 12 */
13
7c884029 14/*
4ac71550
TC		 15 * Yet small as was their hunted band
16 * still fell and fearless was each hand,
17 * and strong deeds they wrought yet oft,
18 * and loved the woods, whose ways more soft
19 * them seemed than thralls of that black throne
20 * to live and languish in halls of stone.
21 * "The Lay of Leithian", Canto II, lines 135-40
7c884029 22 *
4ac71550 23 * [p.162 of _The Lays of Beleriand_]
7c884029
CB		 24 */
25
a0d0e21e
LW		 26#include <acedef.h>
27#include <acldef.h>
28#include <armdef.h>
3ce52d1b
CB		 29#if __CRTL_VER < 70300000
30/* needed for home-rolled utime() */
748a9306 31#include <atrdef.h>
3ce52d1b
CB		 32#include <fibdef.h>
33#endif
a0d0e21e 34#include <chpdef.h>
8fde5078 35#include <clidef.h>
a3e9d8c9 36#include <climsgdef.h>
cd1191f1 37#include <dcdef.h>
a0d0e21e 38#include <descrip.h>
22d4bb9c 39#include <devdef.h>
a0d0e21e
LW		 40#include <dvidef.h>
41#include <float.h>
42#include <fscndef.h>
43#include <iodef.h>
44#include <jpidef.h>
61bb5906 45#include <kgbdef.h>
f675dbe5 46#include <libclidef.h>
a0d0e21e
LW		 47#include <libdef.h>
48#include <lib$routines.h>
49#include <lnmdef.h>
4fdf8f88 50#include <ossdef.h>
f7ddb74a
JM		 51#if __CRTL_VER >= 70301000 && !defined(__VAX)
52#include <ppropdef.h>
53#endif
748a9306 54#include <prvdef.h>
a0d0e21e
LW		 55#include <psldef.h>
56#include <rms.h>
57#include <shrdef.h>
58#include <ssdef.h>
59#include <starlet.h>
f86702cc 60#include <strdef.h>
61#include <str$routines.h>
a0d0e21e 62#include <syidef.h>
748a9306
LW		 63#include <uaidef.h>
64#include <uicdef.h>
2fbb330f 65#include <stsdef.h>
cfcfe586
JM		 66#include <efndef.h>
67#define NO_EFN EFN$C_ENF
a0d0e21e 68
f7ddb74a
JM		 69#if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
70int decc$feature_get_index(const char *name);
71char* decc$feature_get_name(int index);
72int decc$feature_get_value(int index, int mode);
73int decc$feature_set_value(int index, int mode, int value);
74#else
75#include <unixlib.h>
76#endif
77
cfcfe586
JM		 78#pragma member_alignment save
79#pragma nomember_alignment longword
80struct item_list_3 {
81 unsigned short len;
82 unsigned short code;
83 void * bufadr;
84 unsigned short * retadr;
85};
86#pragma member_alignment restore
87
7a7fd8e0 88#if __CRTL_VER >= 70300000 && !defined(__VAX)
f7ddb74a
JM		 89
90static int set_feature_default(const char *name, int value)
91{
92 int status;
93 int index;
94
95 index = decc$feature_get_index(name);
96
97 status = decc$feature_set_value(index, 1, value);
98 if (index == -1 || (status == -1)) {
99 return -1;
100 }
101
102 status = decc$feature_get_value(index, 1);
103 if (status != value) {
104 return -1;
105 }
106
107return 0;
108}
109#endif
f7ddb74a 110
740ce14c 111/* Older versions of ssdef.h don't have these */
112#ifndef SS$_INVFILFOROP
113# define SS$_INVFILFOROP 3930
114#endif
115#ifndef SS$_NOSUCHOBJECT
b7ae7a0d 116# define SS$_NOSUCHOBJECT 2696
117#endif
118
a15cef0c
CB		 119/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
120#define PERLIO_NOT_STDIO 0
121
2497a41f 122/* Don't replace system definitions of vfork, getenv, lstat, and stat,
aa689395 123 * code below needs to get to the underlying CRTL routines. */
124#define DONT_MASK_RTL_CALLS
a0d0e21e
LW		 125#include "EXTERN.h"
126#include "perl.h"
748a9306 127#include "XSUB.h"
3eeba6fb
CB		 128/* Anticipating future expansion in lexical warnings . . . */
129#ifndef WARN_INTERNAL
130# define WARN_INTERNAL WARN_MISC
131#endif
a0d0e21e 132
988c775c
JM		 133#ifdef VMS_LONGNAME_SUPPORT
134#include <libfildef.h>
135#endif
136
58472d87
CB		 137#if !defined(__VAX) && __CRTL_VER >= 80200000
138#ifdef lstat
139#undef lstat
140#endif
141#else
142#ifdef lstat
143#undef lstat
144#endif
145#define lstat(_x, _y) stat(_x, _y)
146#endif
147
5f1992ed
CB		 148/* Routine to create a decterm for use with the Perl debugger */
149/* No headers, this information was found in the Programming Concepts Manual */
150
8cb5d3d5 151static int (*decw_term_port)
5f1992ed
CB		 152 (const struct dsc$descriptor_s * display,
153 const struct dsc$descriptor_s * setup_file,
154 const struct dsc$descriptor_s * customization,
155 struct dsc$descriptor_s * result_device_name,
156 unsigned short * result_device_name_length,
157 void * controller,
158 void * char_buffer,
8cb5d3d5 159 void * char_change_buffer) = 0;
22d4bb9c 160
c07a80fd 161/* gcc's header files don't #define direct access macros
162 * corresponding to VAXC's variant structs */
163#ifdef __GNUC__
482b294c 164# define uic$v_format uic$r_uic_form.uic$v_format
165# define uic$v_group uic$r_uic_form.uic$v_group
166# define uic$v_member uic$r_uic_form.uic$v_member
c07a80fd 167# define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
168# define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
169# define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
170# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
171#endif
172
c645ec3f
GS		 173#if defined(NEED_AN_H_ERRNO)
174dEXT int h_errno;
175#endif
c07a80fd 176
f7ddb74a
JM		 177#ifdef __DECC
178#pragma message disable pragma
179#pragma member_alignment save
180#pragma nomember_alignment longword
181#pragma message save
182#pragma message disable misalgndmem
183#endif
a0d0e21e
LW		 184struct itmlst_3 {
185 unsigned short int buflen;
186 unsigned short int itmcode;
187 void *bufadr;
748a9306 188 unsigned short int *retlen;
a0d0e21e 189};
657054d4
JM		 190
191struct filescan_itmlst_2 {
192 unsigned short length;
193 unsigned short itmcode;
194 char * component;
195};
196
dca5a913
JM		 197struct vs_str_st {
198 unsigned short length;
199 char str[65536];
200};
201
f7ddb74a
JM		 202#ifdef __DECC
203#pragma message restore
204#pragma member_alignment restore
205#endif
a0d0e21e 206
360732b5
JM		 207#define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
208#define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
209#define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
210#define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
211#define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
212#define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
b1a8dcd7 213#define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
360732b5
JM		 214#define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
215#define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
f7ddb74a 216#define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
4b19af01
CB		 217#define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
218#define getredirection(a,b) mp_getredirection(aTHX_ a,b)
219
360732b5
JM		 220static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
221static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
222static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
223static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
f7ddb74a 224
6fb6c614
JM		 225static char * int_rmsexpand_vms(
226 const char * filespec, char * outbuf, unsigned opts);
227static char * int_rmsexpand_tovms(
228 const char * filespec, char * outbuf, unsigned opts);
df278665
JM		 229static char *int_tovmsspec
230 (const char *path, char *buf, int dir_flag, int * utf8_flag);
a979ce91 231static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
0e5ce2c7 232static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
4846f1d7 233static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
df278665 234
0e06870b
CB		 235/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
236#define PERL_LNM_MAX_ALLOWED_INDEX 127
237
2d9f3838
CB		 238/* OpenVMS User's Guide says at least 9 iterative translations will be performed,
239 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
240 * the Perl facility.
241 */
242#define PERL_LNM_MAX_ITER 10
243
2497a41f
JM		 244 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
245#if __CRTL_VER >= 70302000 && !defined(__VAX)
246#define MAX_DCL_SYMBOL (8192)
247#define MAX_DCL_LINE_LENGTH (4096 - 4)
248#else
249#define MAX_DCL_SYMBOL (1024)
250#define MAX_DCL_LINE_LENGTH (1024 - 4)
251#endif
ff7adb52 252
01b8edb6 253static char *__mystrtolower(char *str)
254{
255 if (str) for (; *str; ++str) *str= tolower(*str);
256 return str;
257}
258
f675dbe5
CB		 259static struct dsc$descriptor_s fildevdsc =
260 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
261static struct dsc$descriptor_s crtlenvdsc =
262 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
263static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
264static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
265static struct dsc$descriptor_s **env_tables = defenv;
266static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
267
93948341
CB		 268/* True if we shouldn't treat barewords as logicals during directory */
269/* munching */
270static int no_translate_barewords;
271
f7ddb74a
JM		 272/* DECC Features that may need to affect how Perl interprets
273 * displays filename information
274 */
275static int decc_disable_to_vms_logname_translation = 1;
276static int decc_disable_posix_root = 1;
277int decc_efs_case_preserve = 0;
278static int decc_efs_charset = 0;
b53f3677 279static int decc_efs_charset_index = -1;
f7ddb74a
JM		 280static int decc_filename_unix_no_version = 0;
281static int decc_filename_unix_only = 0;
282int decc_filename_unix_report = 0;
283int decc_posix_compliant_pathnames = 0;
284int decc_readdir_dropdotnotype = 0;
285static int vms_process_case_tolerant = 1;
360732b5
JM		 286int vms_vtf7_filenames = 0;
287int gnv_unix_shell = 0;
e0e5e8d6 288static int vms_unlink_all_versions = 0;
1a3aec58 289static int vms_posix_exit = 0;
f7ddb74a 290
2497a41f 291/* bug workarounds if needed */
682e4b71 292int decc_bug_devnull = 1;
2497a41f 293int decc_dir_barename = 0;
b53f3677 294int vms_bug_stat_filename = 0;
2497a41f 295
9c1171d1 296static int vms_debug_on_exception = 0;
b53f3677
JM		 297static int vms_debug_fileify = 0;
298
299/* Simple logical name translation */
300static int simple_trnlnm
301 (const char * logname,
302 char * value,
303 int value_len)
304{
305 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
306 const unsigned long attr = LNM$M_CASE_BLIND;
307 struct dsc$descriptor_s name_dsc;
308 int status;
309 unsigned short result;
310 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
311 {0, 0, 0, 0}};
312
313 name_dsc.dsc$w_length = strlen(logname);
314 name_dsc.dsc$a_pointer = (char *)logname;
315 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
316 name_dsc.dsc$b_class = DSC$K_CLASS_S;
317
318 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
319
320 if ($VMS_STATUS_SUCCESS(status)) {
321
322 /* Null terminate and return the string */
323 /*--------------------------------------*/
324 value[result] = 0;
325 return result;
326 }
327
328 return 0;
329}
330
9c1171d1 331
f7ddb74a
JM		 332/* Is this a UNIX file specification?
333 * No longer a simple check with EFS file specs
334 * For now, not a full check, but need to
335 * handle POSIX ^UP^ specifications
336 * Fixing to handle ^/ cases would require
337 * changes to many other conversion routines.
338 */
339
657054d4 340static int is_unix_filespec(const char *path)
f7ddb74a
JM		 341{
342int ret_val;
343const char * pch1;
344
345 ret_val = 0;
346 if (strncmp(path,"\"^UP^",5) != 0) {
347 pch1 = strchr(path, '/');
348 if (pch1 != NULL)
349 ret_val = 1;
350 else {
351
352 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
353 if (decc_filename_unix_report || decc_filename_unix_only) {
354 if (strcmp(path,".") == 0)
355 ret_val = 1;
356 }
357 }
358 }
359 return ret_val;
360}
361
360732b5
JM		 362/* This routine converts a UCS-2 character to be VTF-7 encoded.
363 */
364
365static void ucs2_to_vtf7
366 (char *outspec,
367 unsigned long ucs2_char,
368 int * output_cnt)
369{
370unsigned char * ucs_ptr;
371int hex;
372
373 ucs_ptr = (unsigned char *)&ucs2_char;
374
375 outspec[0] = '^';
376 outspec[1] = 'U';
377 hex = (ucs_ptr[1] >> 4) & 0xf;
378 if (hex < 0xA)
379 outspec[2] = hex + '0';
380 else
381 outspec[2] = (hex - 9) + 'A';
382 hex = ucs_ptr[1] & 0xF;
383 if (hex < 0xA)
384 outspec[3] = hex + '0';
385 else {
386 outspec[3] = (hex - 9) + 'A';
387 }
388 hex = (ucs_ptr[0] >> 4) & 0xf;
389 if (hex < 0xA)
390 outspec[4] = hex + '0';
391 else
392 outspec[4] = (hex - 9) + 'A';
393 hex = ucs_ptr[1] & 0xF;
394 if (hex < 0xA)
395 outspec[5] = hex + '0';
396 else {
397 outspec[5] = (hex - 9) + 'A';
398 }
399 *output_cnt = 6;
400}
401
402
403/* This handles the conversion of a UNIX extended character set to a ^
404 * escaped VMS character.
405 * in a UNIX file specification.
406 *
407 * The output count variable contains the number of characters added
408 * to the output string.
409 *
410 * The return value is the number of characters read from the input string
411 */
412static int copy_expand_unix_filename_escape
413 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
414{
415int count;
360732b5
JM		 416int utf8_flag;
417
418 utf8_flag = 0;
419 if (utf8_fl)
420 utf8_flag = *utf8_fl;
421
422 count = 0;
423 *output_cnt = 0;
424 if (*inspec >= 0x80) {
425 if (utf8_fl && vms_vtf7_filenames) {
426 unsigned long ucs_char;
427
428 ucs_char = 0;
429
430 if ((*inspec & 0xE0) == 0xC0) {
431 /* 2 byte Unicode */
432 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
433 if (ucs_char >= 0x80) {
434 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
435 return 2;
436 }
437 } else if ((*inspec & 0xF0) == 0xE0) {
438 /* 3 byte Unicode */
439 ucs_char = ((inspec[0] & 0xF) << 12) +
440 ((inspec[1] & 0x3f) << 6) +
441 (inspec[2] & 0x3f);
442 if (ucs_char >= 0x800) {
443 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
444 return 3;
445 }
446
447#if 0 /* I do not see longer sequences supported by OpenVMS */
448 /* Maybe some one can fix this later */
449 } else if ((*inspec & 0xF8) == 0xF0) {
450 /* 4 byte Unicode */
451 /* UCS-4 to UCS-2 */
452 } else if ((*inspec & 0xFC) == 0xF8) {
453 /* 5 byte Unicode */
454 /* UCS-4 to UCS-2 */
455 } else if ((*inspec & 0xFE) == 0xFC) {
456 /* 6 byte Unicode */
457 /* UCS-4 to UCS-2 */
458#endif
459 }
460 }
461
38a44b82 462 /* High bit set, but not a Unicode character! */
360732b5
JM		 463
464 /* Non printing DECMCS or ISO Latin-1 character? */
b931d62c
CB		 465 if ((unsigned char)*inspec <= 0x9F) {
466 int hex;
360732b5
JM		 467 outspec[0] = '^';
468 outspec++;
469 hex = (*inspec >> 4) & 0xF;
470 if (hex < 0xA)
471 outspec[1] = hex + '0';
472 else {
473 outspec[1] = (hex - 9) + 'A';
474 }
475 hex = *inspec & 0xF;
476 if (hex < 0xA)
477 outspec[2] = hex + '0';
478 else {
479 outspec[2] = (hex - 9) + 'A';
480 }
481 *output_cnt = 3;
482 return 1;
b931d62c 483 } else if ((unsigned char)*inspec == 0xA0) {
360732b5
JM		 484 outspec[0] = '^';
485 outspec[1] = 'A';
486 outspec[2] = '0';
487 *output_cnt = 3;
488 return 1;
b931d62c 489 } else if ((unsigned char)*inspec == 0xFF) {
360732b5
JM		 490 outspec[0] = '^';
491 outspec[1] = 'F';
492 outspec[2] = 'F';
493 *output_cnt = 3;
494 return 1;
495 }
496 *outspec = *inspec;
497 *output_cnt = 1;
498 return 1;
499 }
500
501 /* Is this a macro that needs to be passed through?
502 * Macros start with $( and an alpha character, followed
503 * by a string of alpha numeric characters ending with a )
504 * If this does not match, then encode it as ODS-5.
505 */
506 if ((inspec[0] == '$') && (inspec[1] == '(')) {
507 int tcnt;
508
509 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
510 tcnt = 3;
511 outspec[0] = inspec[0];
512 outspec[1] = inspec[1];
513 outspec[2] = inspec[2];
514
515 while(isalnum(inspec[tcnt]) ||
516 (inspec[2] == '.') || (inspec[2] == '_')) {
517 outspec[tcnt] = inspec[tcnt];
518 tcnt++;
519 }
520 if (inspec[tcnt] == ')') {
521 outspec[tcnt] = inspec[tcnt];
522 tcnt++;
523 *output_cnt = tcnt;
524 return tcnt;
525 }
526 }
527 }
528
529 switch (*inspec) {
530 case 0x7f:
531 outspec[0] = '^';
532 outspec[1] = '7';
533 outspec[2] = 'F';
534 *output_cnt = 3;
535 return 1;
536 break;
537 case '?':
538 if (decc_efs_charset == 0)
539 outspec[0] = '%';
540 else
541 outspec[0] = '?';
542 *output_cnt = 1;
543 return 1;
544 break;
545 case '.':
546 case '~':
547 case '!':
548 case '#':
549 case '&':
550 case '\'':
551 case '`':
552 case '(':
553 case ')':
554 case '+':
555 case '@':
556 case '{':
557 case '}':
558 case ',':
559 case ';':
560 case '[':
561 case ']':
562 case '%':
563 case '^':
449de3c2 564 case '\\':
adc11f0b
CB		 565 /* Don't escape again if following character is
566 * already something we escape.
567 */
449de3c2 568 if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
adc11f0b
CB		 569 *outspec = *inspec;
570 *output_cnt = 1;
571 return 1;
572 break;
573 }
574 /* But otherwise fall through and escape it. */
360732b5
JM		 575 case '=':
576 /* Assume that this is to be escaped */
577 outspec[0] = '^';
578 outspec[1] = *inspec;
579 *output_cnt = 2;
580 return 1;
581 break;
582 case ' ': /* space */
583 /* Assume that this is to be escaped */
584 outspec[0] = '^';
585 outspec[1] = '_';
586 *output_cnt = 2;
587 return 1;
588 break;
589 default:
590 *outspec = *inspec;
591 *output_cnt = 1;
592 return 1;
593 break;
594 }
595}
596
597
657054d4
JM		 598/* This handles the expansion of a '^' prefix to the proper character
599 * in a UNIX file specification.
600 *
601 * The output count variable contains the number of characters added
602 * to the output string.
603 *
604 * The return value is the number of characters read from the input
605 * string
606 */
607static int copy_expand_vms_filename_escape
608 (char *outspec, const char *inspec, int *output_cnt)
609{
610int count;
611int scnt;
612
613 count = 0;
614 *output_cnt = 0;
615 if (*inspec == '^') {
616 inspec++;
617 switch (*inspec) {
adc11f0b
CB		 618 /* Spaces and non-trailing dots should just be passed through,
619 * but eat the escape character.
620 */
657054d4 621 case '.':
657054d4 622 *outspec = *inspec;
adc11f0b
CB		 623 count += 2;
624 (*output_cnt)++;
657054d4
JM		 625 break;
626 case '_': /* space */
627 *outspec = ' ';
adc11f0b 628 count += 2;
657054d4
JM		 629 (*output_cnt)++;
630 break;
adc11f0b
CB		 631 case '^':
632 /* Hmm. Better leave the escape escaped. */
633 outspec[0] = '^';
634 outspec[1] = '^';
635 count += 2;
636 (*output_cnt) += 2;
637 break;
360732b5 638 case 'U': /* Unicode - FIX-ME this is wrong. */
657054d4
JM		 639 inspec++;
640 count++;
641 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
642 if (scnt == 4) {
2f4077ca
JM		 643 unsigned int c1, c2;
644 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
9960802c
NK		 645 outspec[0] = c1 & 0xff;
646 outspec[1] = c2 & 0xff;
657054d4
JM		 647 if (scnt > 1) {
648 (*output_cnt) += 2;
649 count += 4;
650 }
651 }
652 else {
653 /* Error - do best we can to continue */
654 *outspec = 'U';
655 outspec++;
656 (*output_cnt++);
657 *outspec = *inspec;
658 count++;
659 (*output_cnt++);
660 }
661 break;
662 default:
663 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
664 if (scnt == 2) {
665 /* Hex encoded */
2f4077ca
JM		 666 unsigned int c1;
667 scnt = sscanf(inspec, "%2x", &c1);
668 outspec[0] = c1 & 0xff;
657054d4
JM		 669 if (scnt > 0) {
670 (*output_cnt++);
671 count += 2;
672 }
673 }
674 else {
675 *outspec = *inspec;
676 count++;
677 (*output_cnt++);
678 }
679 }
680 }
681 else {
682 *outspec = *inspec;
683 count++;
684 (*output_cnt)++;
685 }
686 return count;
687}
688
657054d4
JM		 689/* vms_split_path - Verify that the input file specification is a
690 * VMS format file specification, and provide pointers to the components of
691 * it. With EFS format filenames, this is virtually the only way to
692 * parse a VMS path specification into components.
693 *
694 * If the sum of the components do not add up to the length of the
695 * string, then the passed file specification is probably a UNIX style
696 * path.
697 */
698static int vms_split_path
360732b5 699 (const char * path,
dca5a913 700 char * * volume,
657054d4 701 int * vol_len,
dca5a913 702 char * * root,
657054d4 703 int * root_len,
dca5a913 704 char * * dir,
657054d4 705 int * dir_len,
dca5a913 706 char * * name,
657054d4 707 int * name_len,
dca5a913 708 char * * ext,
657054d4 709 int * ext_len,
dca5a913 710 char * * version,
657054d4
JM		 711 int * ver_len)
712{
713struct dsc$descriptor path_desc;
714int status;
715unsigned long flags;
716int ret_stat;
717struct filescan_itmlst_2 item_list[9];
718const int filespec = 0;
719const int nodespec = 1;
720const int devspec = 2;
721const int rootspec = 3;
722const int dirspec = 4;
723const int namespec = 5;
724const int typespec = 6;
725const int verspec = 7;
726
727 /* Assume the worst for an easy exit */
728 ret_stat = -1;
729 *volume = NULL;
730 *vol_len = 0;
731 *root = NULL;
732 *root_len = 0;
733 *dir = NULL;
657054d4
JM		 734 *name = NULL;
735 *name_len = 0;
736 *ext = NULL;
737 *ext_len = 0;
738 *version = NULL;
739 *ver_len = 0;
740
741 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
742 path_desc.dsc$w_length = strlen(path);
743 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
744 path_desc.dsc$b_class = DSC$K_CLASS_S;
745
746 /* Get the total length, if it is shorter than the string passed
747 * then this was probably not a VMS formatted file specification
748 */
749 item_list[filespec].itmcode = FSCN$_FILESPEC;
750 item_list[filespec].length = 0;
751 item_list[filespec].component = NULL;
752
753 /* If the node is present, then it gets considered as part of the
754 * volume name to hopefully make things simple.
755 */
756 item_list[nodespec].itmcode = FSCN$_NODE;
757 item_list[nodespec].length = 0;
758 item_list[nodespec].component = NULL;
759
760 item_list[devspec].itmcode = FSCN$_DEVICE;
761 item_list[devspec].length = 0;
762 item_list[devspec].component = NULL;
763
764 /* root is a special case, adding it to either the directory or
94ae10c0 765 * the device components will probably complicate things for the
657054d4
JM		 766 * callers of this routine, so leave it separate.
767 */
768 item_list[rootspec].itmcode = FSCN$_ROOT;
769 item_list[rootspec].length = 0;
770 item_list[rootspec].component = NULL;
771
772 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
773 item_list[dirspec].length = 0;
774 item_list[dirspec].component = NULL;
775
776 item_list[namespec].itmcode = FSCN$_NAME;
777 item_list[namespec].length = 0;
778 item_list[namespec].component = NULL;
779
780 item_list[typespec].itmcode = FSCN$_TYPE;
781 item_list[typespec].length = 0;
782 item_list[typespec].component = NULL;
783
784 item_list[verspec].itmcode = FSCN$_VERSION;
785 item_list[verspec].length = 0;
786 item_list[verspec].component = NULL;
787
788 item_list[8].itmcode = 0;
789 item_list[8].length = 0;
790 item_list[8].component = NULL;
791
7566800d 792 status = sys$filescan
657054d4
JM		 793 ((const struct dsc$descriptor_s *)&path_desc, item_list,
794 &flags, NULL, NULL);
360732b5 795 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
657054d4
JM		 796
797 /* If we parsed it successfully these two lengths should be the same */
798 if (path_desc.dsc$w_length != item_list[filespec].length)
799 return ret_stat;
800
801 /* If we got here, then it is a VMS file specification */
802 ret_stat = 0;
803
804 /* set the volume name */
805 if (item_list[nodespec].length > 0) {
806 *volume = item_list[nodespec].component;
807 *vol_len = item_list[nodespec].length + item_list[devspec].length;
808 }
809 else {
810 *volume = item_list[devspec].component;
811 *vol_len = item_list[devspec].length;
812 }
813
814 *root = item_list[rootspec].component;
815 *root_len = item_list[rootspec].length;
816
817 *dir = item_list[dirspec].component;
818 *dir_len = item_list[dirspec].length;
819
820 /* Now fun with versions and EFS file specifications
821 * The parser can not tell the difference when a "." is a version
822 * delimiter or a part of the file specification.
823 */
824 if ((decc_efs_charset) &&
825 (item_list[verspec].length > 0) &&
826 (item_list[verspec].component[0] == '.')) {
827 *name = item_list[namespec].component;
828 *name_len = item_list[namespec].length + item_list[typespec].length;
829 *ext = item_list[verspec].component;
830 *ext_len = item_list[verspec].length;
831 *version = NULL;
832 *ver_len = 0;
833 }
834 else {
835 *name = item_list[namespec].component;
836 *name_len = item_list[namespec].length;
837 *ext = item_list[typespec].component;
838 *ext_len = item_list[typespec].length;
839 *version = item_list[verspec].component;
840 *ver_len = item_list[verspec].length;
841 }
842 return ret_stat;
843}
844
df278665
JM		 845/* Routine to determine if the file specification ends with .dir */
846static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
847
848 /* e_len must be 4, and version must be <= 2 characters */
849 if (e_len != 4 || vs_len > 2)
850 return 0;
851
852 /* If a version number is present, it needs to be one */
853 if ((vs_len == 2) && (vs_spec[1] != '1'))
854 return 0;
855
856 /* Look for the DIR on the extension */
857 if (vms_process_case_tolerant) {
858 if ((toupper(e_spec[1]) == 'D') &&
859 (toupper(e_spec[2]) == 'I') &&
860 (toupper(e_spec[3]) == 'R')) {
861 return 1;
862 }
863 } else {
864 /* Directory extensions are supposed to be in upper case only */
865 /* I would not be surprised if this rule can not be enforced */
866 /* if and when someone fully debugs the case sensitive mode */
867 if ((e_spec[1] == 'D') &&
868 (e_spec[2] == 'I') &&
869 (e_spec[3] == 'R')) {
870 return 1;
871 }
872 }
873 return 0;
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) {
4e0c9737 953 char *eq;
f675dbe5
CB		 954 int i;
955 if (!environ) {
956 ivenv = 1;
ebd4d70b
JM		 957#if defined(PERL_IMPLICIT_CONTEXT)
958 if (aTHX == NULL) {
959 fprintf(stderr,
873f5ddf 960 "Can't read CRTL environ\n");
ebd4d70b
JM		 961 } else
962#endif
963 Perl_warn(aTHX_ "Can't read CRTL environ\n");
f675dbe5
CB		 964 continue;
965 }
966 retsts = SS$_NOLOGNAM;
967 for (i = 0; environ[i]; i++) {
968 if ((eq = strchr(environ[i],'=')) &&
299d126a 969 lnmdsc.dsc$w_length == (eq - environ[i]) &&
f675dbe5
CB		 970 !strncmp(environ[i],uplnm,eq - environ[i])) {
971 eq++;
972 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
973 if (!eqvlen) continue;
974 retsts = SS$_NORMAL;
975 break;
976 }
977 }
978 if (retsts != SS$_NOLOGNAM) break;
979 }
980 }
981 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
982 !str$case_blind_compare(&tmpdsc,&clisym)) {
983 if (!ivsym && !secure) {
984 unsigned short int deflen = LNM$C_NAMLENGTH;
985 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
94ae10c0 986 /* dynamic dsc to accommodate possible long value */
ebd4d70b 987 _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
f675dbe5
CB		 988 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
989 if (retsts & 1) {
2497a41f 990 if (eqvlen > MAX_DCL_SYMBOL) {
f675dbe5 991 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
2497a41f 992 eqvlen = MAX_DCL_SYMBOL;
cc077a9f
HM		 993 /* Special hack--we might be called before the interpreter's */
994 /* fully initialized, in which case either thr or PL_curcop */
995 /* might be bogus. We have to check, since ckWARN needs them */
996 /* both to be valid if running threaded */
8a646e0b
JM		 997#if defined(PERL_IMPLICIT_CONTEXT)
998 if (aTHX == NULL) {
999 fprintf(stderr,
873f5ddf 1000 "Value of CLI symbol \"%s\" too long",lnm);
8a646e0b
JM		 1001 } else
1002#endif
cc077a9f 1003 if (ckWARN(WARN_MISC)) {
f98bc0c6 1004 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
cc077a9f 1005 }
f675dbe5
CB		 1006 }
1007 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1008 }
ebd4d70b 1009 _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
f675dbe5
CB		 1010 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1011 if (retsts == LIB$_NOSUCHSYM) continue;
1012 break;
1013 }
1014 }
1015 else if (!ivlnm) {
843027b0 1016 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
f7ddb74a
JM		 1017 midx = my_maxidx(lnm);
1018 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1019 lnmlst[1].bufadr = cp2;
fa537f88
CB		 1020 eqvlen = 0;
1021 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1022 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1023 if (retsts == SS$_NOLOGNAM) break;
1024 /* PPFs have a prefix */
1025 if (
fd7385b9 1026#if INTSIZE == 4
fa537f88 1027 *((int *)uplnm) == *((int *)"SYS$") &&
fd7385b9 1028#endif
fa537f88
CB		 1029 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1030 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1031 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1032 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1033 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
18a3d61e 1034 memmove(eqv,eqv+4,eqvlen-4);
fa537f88
CB		 1035 eqvlen -= 4;
1036 }
f7ddb74a
JM		 1037 cp2 += eqvlen;
1038 *cp2 = '\0';
fa537f88
CB		 1039 }
1040 if ((retsts == SS$_IVLOGNAM) ||
1041 (retsts == SS$_NOLOGNAM)) { continue; }
fd7385b9 1042 }
fa537f88 1043 else {
fa537f88
CB		 1044 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1045 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1046 if (retsts == SS$_NOLOGNAM) continue;
1047 eqv[eqvlen] = '\0';
1048 }
1049 eqvlen = strlen(eqv);
f675dbe5
CB		 1050 break;
1051 }
c07a80fd 1052 }
f675dbe5
CB		 1053 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1054 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1055 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1056 retsts == SS$_NOLOGNAM) {
1057 set_errno(EINVAL); set_vaxc_errno(retsts);
748a9306 1058 }
ebd4d70b 1059 else _ckvmssts_noperl(retsts);
f675dbe5
CB		 1060 return 0;
1061} /* end of vmstrnenv */
1062/*}}}*/
c07a80fd 1063
f675dbe5
CB		 1064/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1065/* Define as a function so we can access statics. */
4b19af01 1066int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
f675dbe5 1067{
8a646e0b
JM		 1068 int flags = 0;
1069
1070#if defined(PERL_IMPLICIT_CONTEXT)
1071 if (aTHX != NULL)
1072#endif
f675dbe5 1073#ifdef SECURE_INTERNAL_GETENV
8a646e0b
JM		 1074 flags = (PL_curinterp ? PL_tainting : will_taint) ?
1075 PERL__TRNENV_SECURE : 0;
f675dbe5 1076#endif
8a646e0b
JM		 1077
1078 return vmstrnenv(lnm, eqv, idx, fildev, flags);
f675dbe5
CB		 1079}
1080/*}}}*/
a0d0e21e
LW		 1081
1082/* my_getenv
61bb5906
CB		 1083 * Note: Uses Perl temp to store result so char * can be returned to
1084 * caller; this pointer will be invalidated at next Perl statement
1085 * transition.
a6c40364 1086 * We define this as a function rather than a macro in terms of my_getenv_len()
f675dbe5
CB		 1087 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1088 * allocate SVs).
a0d0e21e 1089 */
f675dbe5 1090/*{{{ char *my_getenv(const char *lnm, bool sys)*/
a0d0e21e 1091char *
5c84aa53 1092Perl_my_getenv(pTHX_ const char *lnm, bool sys)
a0d0e21e 1093{
f7ddb74a 1094 const char *cp1;
fa537f88 1095 static char *__my_getenv_eqv = NULL;
f7ddb74a 1096 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
c07a80fd 1097 unsigned long int idx = 0;
4e0c9737 1098 int success, secure, saverr, savvmserr;
843027b0 1099 int midx, flags;
61bb5906 1100 SV *tmpsv;
a0d0e21e 1101
f7ddb74a 1102 midx = my_maxidx(lnm) + 1;
fa537f88 1103
6b88bc9c 1104 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
61bb5906
CB		 1105 /* Set up a temporary buffer for the return value; Perl will
1106 * clean it up at the next statement transition */
fa537f88 1107 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
61bb5906
CB		 1108 if (!tmpsv) return NULL;
1109 eqv = SvPVX(tmpsv);
1110 }
fa537f88
CB		 1111 else {
1112 /* Assume no interpreter ==> single thread */
1113 if (__my_getenv_eqv != NULL) {
1114 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1115 }
1116 else {
a02a5408 1117 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1118 }
1119 eqv = __my_getenv_eqv;
1120 }
1121
f7ddb74a 1122 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1123 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
2497a41f 1124 int len;
61bb5906 1125 getcwd(eqv,LNM$C_NAMLENGTH);
2497a41f
JM		 1126
1127 len = strlen(eqv);
1128
1129 /* Get rid of "000000/ in rooted filespecs */
1130 if (len > 7) {
1131 char * zeros;
1132 zeros = strstr(eqv, "/000000/");
1133 if (zeros != NULL) {
1134 int mlen;
1135 mlen = len - (zeros - eqv) - 7;
1136 memmove(zeros, &zeros[7], mlen);
1137 len = len - 7;
1138 eqv[len] = '\0';
1139 }
1140 }
61bb5906 1141 return eqv;
748a9306 1142 }
a0d0e21e 1143 else {
2512681b 1144 /* Impose security constraints only if tainting */
bc10a425
CB		 1145 if (sys) {
1146 /* Impose security constraints only if tainting */
1147 secure = PL_curinterp ? PL_tainting : will_taint;
1148 saverr = errno; savvmserr = vaxc$errno;
1149 }
843027b0
CB		 1150 else {
1151 secure = 0;
1152 }
1153
1154 flags =
f675dbe5 1155#ifdef SECURE_INTERNAL_GETENV
843027b0 1156 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1157#else
843027b0 1158 0
f675dbe5 1159#endif
843027b0
CB		 1160 ;
1161
1162 /* For the getenv interface we combine all the equivalence names
1163 * of a search list logical into one value to acquire a maximum
1164 * value length of 255*128 (assuming %ENV is using logicals).
1165 */
1166 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1167
1168 /* If the name contains a semicolon-delimited index, parse it
1169 * off and make sure we only retrieve the equivalence name for
1170 * that index. */
1171 if ((cp2 = strchr(lnm,';')) != NULL) {
a35dcc95 1172 my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
843027b0
CB		 1173 idx = strtoul(cp2+1,NULL,0);
1174 lnm = uplnm;
1175 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1176 }
1177
1178 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1179
bc10a425
CB		 1180 /* Discard NOLOGNAM on internal calls since we're often looking
1181 * for an optional name, and this "error" often shows up as the
1182 * (bogus) exit status for a die() call later on. */
1183 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
4e205ed6 1184 return success ? eqv : NULL;
a0d0e21e 1185 }
a0d0e21e
LW		 1186
1187} /* end of my_getenv() */
1188/*}}}*/
1189
f675dbe5 1190
a6c40364
GS		 1191/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1192char *
fd8cd3a3 1193Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
f675dbe5 1194{
f7ddb74a
JM		 1195 const char *cp1;
1196 char *buf, *cp2;
a6c40364 1197 unsigned long idx = 0;
843027b0 1198 int midx, flags;
fa537f88 1199 static char *__my_getenv_len_eqv = NULL;
bc10a425 1200 int secure, saverr, savvmserr;
cc077a9f
HM		 1201 SV *tmpsv;
1202
f7ddb74a 1203 midx = my_maxidx(lnm) + 1;
fa537f88 1204
cc077a9f
HM		 1205 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1206 /* Set up a temporary buffer for the return value; Perl will
1207 * clean it up at the next statement transition */
fa537f88 1208 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
cc077a9f
HM		 1209 if (!tmpsv) return NULL;
1210 buf = SvPVX(tmpsv);
1211 }
fa537f88
CB		 1212 else {
1213 /* Assume no interpreter ==> single thread */
1214 if (__my_getenv_len_eqv != NULL) {
1215 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1216 }
1217 else {
a02a5408 1218 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1219 }
1220 buf = __my_getenv_len_eqv;
1221 }
1222
f7ddb74a 1223 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1224 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
f7ddb74a
JM		 1225 char * zeros;
1226
f675dbe5 1227 getcwd(buf,LNM$C_NAMLENGTH);
a6c40364 1228 *len = strlen(buf);
f7ddb74a
JM		 1229
1230 /* Get rid of "000000/ in rooted filespecs */
1231 if (*len > 7) {
1232 zeros = strstr(buf, "/000000/");
1233 if (zeros != NULL) {
1234 int mlen;
1235 mlen = *len - (zeros - buf) - 7;
1236 memmove(zeros, &zeros[7], mlen);
1237 *len = *len - 7;
1238 buf[*len] = '\0';
1239 }
1240 }
a6c40364 1241 return buf;
f675dbe5
CB		 1242 }
1243 else {
bc10a425
CB		 1244 if (sys) {
1245 /* Impose security constraints only if tainting */
1246 secure = PL_curinterp ? PL_tainting : will_taint;
1247 saverr = errno; savvmserr = vaxc$errno;
1248 }
843027b0
CB		 1249 else {
1250 secure = 0;
1251 }
1252
1253 flags =
f675dbe5 1254#ifdef SECURE_INTERNAL_GETENV
843027b0 1255 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1256#else
843027b0 1257 0
f675dbe5 1258#endif
843027b0
CB		 1259 ;
1260
1261 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1262
1263 if ((cp2 = strchr(lnm,';')) != NULL) {
a35dcc95 1264 my_strlcpy(buf, lnm, cp2 - lnm + 1);
843027b0
CB		 1265 idx = strtoul(cp2+1,NULL,0);
1266 lnm = buf;
1267 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1268 }
1269
1270 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1271
f7ddb74a
JM		 1272 /* Get rid of "000000/ in rooted filespecs */
1273 if (*len > 7) {
1274 char * zeros;
1275 zeros = strstr(buf, "/000000/");
1276 if (zeros != NULL) {
1277 int mlen;
1278 mlen = *len - (zeros - buf) - 7;
1279 memmove(zeros, &zeros[7], mlen);
1280 *len = *len - 7;
1281 buf[*len] = '\0';
1282 }
1283 }
1284
bc10a425
CB		 1285 /* Discard NOLOGNAM on internal calls since we're often looking
1286 * for an optional name, and this "error" often shows up as the
1287 * (bogus) exit status for a die() call later on. */
1288 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
4e205ed6 1289 return *len ? buf : NULL;
f675dbe5
CB		 1290 }
1291
a6c40364 1292} /* end of my_getenv_len() */
f675dbe5
CB		 1293/*}}}*/
1294
8a646e0b 1295static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
8fde5078
CB		 1296
1297static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1e422769 1298
740ce14c 1299/*{{{ void prime_env_iter() */
1300void
1301prime_env_iter(void)
1302/* Fill the %ENV associative array with all logical names we can
1303 * find, in preparation for iterating over it.
1304 */
1305{
17f28c40 1306 static int primed = 0;
3eeba6fb 1307 HV *seenhv = NULL, *envhv;
22be8b3c 1308 SV *sv = NULL;
4e205ed6 1309 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
8fde5078
CB		 1310 unsigned short int chan;
1311#ifndef CLI$M_TRUSTED
1312# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1313#endif
f675dbe5 1314 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
4e0c9737 1315 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
f675dbe5
CB		 1316 long int i;
1317 bool have_sym = FALSE, have_lnm = FALSE;
1318 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1319 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1320 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1321 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1322 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
fd8cd3a3
DS		 1323#if defined(PERL_IMPLICIT_CONTEXT)
1324 pTHX;
1325#endif
3db8f154 1326#if defined(USE_ITHREADS)
b2b3adea
HM		 1327 static perl_mutex primenv_mutex;
1328 MUTEX_INIT(&primenv_mutex);
61bb5906 1329#endif
740ce14c 1330
fd8cd3a3
DS		 1331#if defined(PERL_IMPLICIT_CONTEXT)
1332 /* We jump through these hoops because we can be called at */
1333 /* platform-specific initialization time, which is before anything is */
1334 /* set up--we can't even do a plain dTHX since that relies on the */
1335 /* interpreter structure to be initialized */
fd8cd3a3
DS		 1336 if (PL_curinterp) {
1337 aTHX = PERL_GET_INTERP;
1338 } else {
ebd4d70b
JM		 1339 /* we never get here because the NULL pointer will cause the */
1340 /* several of the routines called by this routine to access violate */
1341
1342 /* This routine is only called by hv.c/hv_iterinit which has a */
1343 /* context, so the real fix may be to pass it through instead of */
1344 /* the hoops above */
fd8cd3a3
DS		 1345 aTHX = NULL;
1346 }
1347#endif
fd8cd3a3 1348
3eeba6fb 1349 if (primed || !PL_envgv) return;
61bb5906
CB		 1350 MUTEX_LOCK(&primenv_mutex);
1351 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
3eeba6fb 1352 envhv = GvHVn(PL_envgv);
740ce14c 1353 /* Perform a dummy fetch as an lval to insure that the hash table is
8fde5078 1354 * set up. Otherwise, the hv_store() will turn into a nullop. */
740ce14c 1355 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
740ce14c 1356
f675dbe5
CB		 1357 for (i = 0; env_tables[i]; i++) {
1358 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1359 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
f02a1854 1360 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
8fde5078 1361 }
f675dbe5
CB		 1362 if (have_sym || have_lnm) {
1363 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1364 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1365 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1366 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
61bb5906 1367 }
f675dbe5
CB		 1368
1369 for (i--; i >= 0; i--) {
1370 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1371 char *start;
1372 int j;
1373 for (j = 0; environ[j]; j++) {
1374 if (!(start = strchr(environ[j],'='))) {
3eeba6fb 1375 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1376 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
f675dbe5
CB		 1377 }
1378 else {
1379 start++;
22be8b3c
CB		 1380 sv = newSVpv(start,0);
1381 SvTAINTED_on(sv);
1382 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
f675dbe5
CB		 1383 }
1384 }
1385 continue;
740ce14c 1386 }
f675dbe5
CB		 1387 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1388 !str$case_blind_compare(&tmpdsc,&clisym)) {
a35dcc95 1389 my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
f675dbe5
CB		 1390 cmddsc.dsc$w_length = 20;
1391 if (env_tables[i]->dsc$w_length == 12 &&
1392 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
a35dcc95 1393 !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local *", sizeof(cmd)-12);
f675dbe5
CB		 1394 flags = defflags | CLI$M_NOLOGNAM;
1395 }
1396 else {
a35dcc95 1397 my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
f675dbe5 1398 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
a35dcc95
CB		 1399 my_strlcat(cmd," /Table=", sizeof(cmd));
1400 cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, env_tables[i]->dsc$w_length + 1);
f675dbe5
CB		 1401 }
1402 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1403 flags = defflags | CLI$M_NOCLISYM;
1404 }
1405
1406 /* Create a new subprocess to execute each command, to exclude the
1407 * remote possibility that someone could subvert a mbx or file used
1408 * to write multiple commands to a single subprocess.
1409 */
1410 do {
1411 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1412 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1413 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1414 defflags &= ~CLI$M_TRUSTED;
1415 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1416 _ckvmssts(retsts);
a02a5408 1417 if (!buf) Newx(buf,mbxbufsiz + 1,char);
f675dbe5
CB		 1418 if (seenhv) SvREFCNT_dec(seenhv);
1419 seenhv = newHV();
1420 while (1) {
1421 char *cp1, *cp2, *key;
1422 unsigned long int sts, iosb[2], retlen, keylen;
1423 register U32 hash;
1424
1425 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1426 if (sts & 1) sts = iosb[0] & 0xffff;
1427 if (sts == SS$_ENDOFFILE) {
1428 int wakect = 0;
1429 while (substs == 0) { sys$hiber(); wakect++;}
1430 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1431 _ckvmssts(substs);
1432 break;
1433 }
1434 _ckvmssts(sts);
1435 retlen = iosb[0] >> 16;
1436 if (!retlen) continue; /* blank line */
1437 buf[retlen] = '\0';
1438 if (iosb[1] != subpid) {
1439 if (iosb[1]) {
5c84aa53 1440 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
f675dbe5
CB		 1441 }
1442 continue;
1443 }
3eeba6fb 1444 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
f98bc0c6 1445 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
f675dbe5
CB		 1446
1447 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1448 if (*cp1 == '(' || /* Logical name table name */
1449 *cp1 == '=' /* Next eqv of searchlist */) continue;
1450 if (*cp1 == '"') cp1++;
1451 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1452 key = cp1; keylen = cp2 - cp1;
1453 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1454 while (*cp2 && *cp2 != '=') cp2++;
1f47e8e2
CB		 1455 while (*cp2 && *cp2 == '=') cp2++;
1456 while (*cp2 && *cp2 == ' ') cp2++;
1457 if (*cp2 == '"') { /* String translation; may embed "" */
1458 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1459 cp2++; cp1--; /* Skip "" surrounding translation */
1460 }
1461 else { /* Numeric translation */
1462 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1463 cp1--; /* stop on last non-space char */
1464 }
1465 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
f98bc0c6 1466 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
edc7bc49
CB		 1467 continue;
1468 }
5afd6d42 1469 PERL_HASH(hash,key,keylen);
ff79d39d
CB		 1470
1471 if (cp1 == cp2 && *cp2 == '.') {
1472 /* A single dot usually means an unprintable character, such as a null
1473 * to indicate a zero-length value. Get the actual value to make sure.
1474 */
1475 char lnm[LNM$C_NAMLENGTH+1];
2497a41f 1476 char eqv[MAX_DCL_SYMBOL+1];
0faef845 1477 int trnlen;
ff79d39d 1478 strncpy(lnm, key, keylen);
0faef845 1479 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
ff79d39d
CB		 1480 sv = newSVpvn(eqv, strlen(eqv));
1481 }
1482 else {
1483 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1484 }
1485
22be8b3c
CB		 1486 SvTAINTED_on(sv);
1487 hv_store(envhv,key,keylen,sv,hash);
f675dbe5 1488 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
edc7bc49 1489 }
f675dbe5
CB		 1490 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1491 /* get the PPFs for this process, not the subprocess */
f7ddb74a 1492 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
f675dbe5
CB		 1493 char eqv[LNM$C_NAMLENGTH+1];
1494 int trnlen, i;
1495 for (i = 0; ppfs[i]; i++) {
1496 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
22be8b3c
CB		 1497 sv = newSVpv(eqv,trnlen);
1498 SvTAINTED_on(sv);
1499 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
f675dbe5 1500 }
740ce14c 1501 }
1502 }
f675dbe5
CB		 1503 primed = 1;
1504 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1505 if (buf) Safefree(buf);
1506 if (seenhv) SvREFCNT_dec(seenhv);
1507 MUTEX_UNLOCK(&primenv_mutex);
1508 return;
1509
740ce14c 1510} /* end of prime_env_iter */
1511/*}}}*/
740ce14c 1512
f675dbe5 1513
2c590a56 1514/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1515/* Define or delete an element in the same "environment" as
1516 * vmstrnenv(). If an element is to be deleted, it's removed from
1517 * the first place it's found. If it's to be set, it's set in the
1518 * place designated by the first element of the table vector.
3eeba6fb 1519 * Like setenv() returns 0 for success, non-zero on error.
a0d0e21e 1520 */
f675dbe5 1521int
2c590a56 1522Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
a0d0e21e 1523{
f7ddb74a
JM		 1524 const char *cp1;
1525 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
f675dbe5 1526 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
fa537f88 1527 int nseg = 0, j;
a0d0e21e 1528 unsigned long int retsts, usermode = PSL$C_USER;
fa537f88 1529 struct itmlst_3 *ile, *ilist;
a0d0e21e 1530 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
f675dbe5
CB		 1531 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1532 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1533 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1534 $DESCRIPTOR(local,"_LOCAL");
1535
ed253963
CB		 1536 if (!lnm) {
1537 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1538 return SS$_IVLOGNAM;
1539 }
1540
f7ddb74a 1541 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 1542 *cp2 = _toupper(*cp1);
1543 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1544 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1545 return SS$_IVLOGNAM;
1546 }
1547 }
a0d0e21e 1548 lnmdsc.dsc$w_length = cp1 - lnm;
f675dbe5
CB		 1549 if (!tabvec || !*tabvec) tabvec = env_tables;
1550
3eeba6fb 1551 if (!eqv) { /* we're deleting n element */
f675dbe5
CB		 1552 for (curtab = 0; tabvec[curtab]; curtab++) {
1553 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1554 int i;
299d126a 1555 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
f675dbe5 1556 if ((cp1 = strchr(environ[i],'=')) &&
299d126a 1557 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
f675dbe5 1558 !strncmp(environ[i],lnm,cp1 - environ[i])) {
3eeba6fb 1559#ifdef HAS_SETENV
0e06870b 1560 return setenv(lnm,"",1) ? vaxc$errno : 0;
f675dbe5
CB		 1561 }
1562 }
1563 ivenv = 1; retsts = SS$_NOLOGNAM;
1564#else
3eeba6fb 1565 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1566 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
3eeba6fb
CB		 1567 ivenv = 1; retsts = SS$_NOSUCHPGM;
1568 break;
1569 }
1570 }
f675dbe5
CB		 1571#endif
1572 }
1573 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1574 !str$case_blind_compare(&tmpdsc,&clisym)) {
1575 unsigned int symtype;
1576 if (tabvec[curtab]->dsc$w_length == 12 &&
1577 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1578 !str$case_blind_compare(&tmpdsc,&local))
1579 symtype = LIB$K_CLI_LOCAL_SYM;
1580 else symtype = LIB$K_CLI_GLOBAL_SYM;
1581 retsts = lib$delete_symbol(&lnmdsc,&symtype);
3eeba6fb
CB		 1582 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1583 if (retsts == LIB$_NOSUCHSYM) continue;
f675dbe5
CB		 1584 break;
1585 }
1586 else if (!ivlnm) {
1587 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1588 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1589 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1590 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1591 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1592 }
a0d0e21e
LW		 1593 }
1594 }
f675dbe5
CB		 1595 else { /* we're defining a value */
1596 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1597#ifdef HAS_SETENV
3eeba6fb 1598 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
f675dbe5 1599#else
3eeba6fb 1600 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1601 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
f675dbe5
CB		 1602 retsts = SS$_NOSUCHPGM;
1603#endif
1604 }
1605 else {
f7ddb74a 1606 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
f675dbe5
CB		 1607 eqvdsc.dsc$w_length = strlen(eqv);
1608 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1609 !str$case_blind_compare(&tmpdsc,&clisym)) {
1610 unsigned int symtype;
1611 if (tabvec[0]->dsc$w_length == 12 &&
1612 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1613 !str$case_blind_compare(&tmpdsc,&local))
1614 symtype = LIB$K_CLI_LOCAL_SYM;
1615 else symtype = LIB$K_CLI_GLOBAL_SYM;
1616 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1617 }
3eeba6fb
CB		 1618 else {
1619 if (!*eqv) eqvdsc.dsc$w_length = 1;
a1dfe751 1620 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
fa537f88
CB		 1621
1622 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1623 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1624 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1625 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1626 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1627 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1628 }
1629
a02a5408 1630 Newx(ilist,nseg+1,struct itmlst_3);
fa537f88
CB		 1631 ile = ilist;
1632 if (!ile) {
1633 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1634 return SS$_INSFMEM;
a1dfe751 1635 }
fa537f88
CB		 1636 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1637
1638 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1639 ile->itmcode = LNM$_STRING;
1640 ile->bufadr = c;
1641 if ((j+1) == nseg) {
1642 ile->buflen = strlen(c);
1643 /* in case we are truncating one that's too long */
1644 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1645 }
1646 else {
1647 ile->buflen = LNM$C_NAMLENGTH;
1648 }
1649 }
1650
1651 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1652 Safefree (ilist);
1653 }
1654 else {
1655 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
a1dfe751 1656 }
3eeba6fb 1657 }
f675dbe5
CB		 1658 }
1659 }
1660 if (!(retsts & 1)) {
1661 switch (retsts) {
1662 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1663 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1664 set_errno(EVMSERR); break;
1665 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1666 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1667 set_errno(EINVAL); break;
1668 case SS$_NOPRIV:
7d2497bf 1669 set_errno(EACCES); break;
f675dbe5
CB		 1670 default:
1671 _ckvmssts(retsts);
1672 set_errno(EVMSERR);
1673 }
1674 set_vaxc_errno(retsts);
1675 return (int) retsts || 44; /* retsts should never be 0, but just in case */
a0d0e21e 1676 }
3eeba6fb
CB		 1677 else {
1678 /* We reset error values on success because Perl does an hv_fetch()
1679 * before each hv_store(), and if the thing we're setting didn't
1680 * previously exist, we've got a leftover error message. (Of course,
1681 * this fails in the face of
1682 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1683 * in that the error reported in $! isn't spurious,
1684 * but it's right more often than not.)
1685 */
f675dbe5
CB		 1686 set_errno(0); set_vaxc_errno(retsts);
1687 return 0;
1688 }
1689
1690} /* end of vmssetenv() */
1691/*}}}*/
a0d0e21e 1692
2c590a56 1693/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1694/* This has to be a function since there's a prototype for it in proto.h */
1695void
2c590a56 1696Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
f675dbe5 1697{
bc10a425
CB		 1698 if (lnm && *lnm) {
1699 int len = strlen(lnm);
1700 if (len == 7) {
1701 char uplnm[8];
22d4bb9c
CB		 1702 int i;
1703 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
bc10a425 1704 if (!strcmp(uplnm,"DEFAULT")) {
7ded3206 1705 if (eqv && *eqv) my_chdir(eqv);
bc10a425
CB		 1706 return;
1707 }
1708 }
22d4bb9c 1709 }
f675dbe5
CB		 1710 (void) vmssetenv(lnm,eqv,NULL);
1711}
a0d0e21e
LW		 1712/*}}}*/
1713
27c67b75 1714/*{{{static void vmssetuserlnm(char *name, char *eqv); */
0e06870b
CB		 1715/* vmssetuserlnm
1716 * sets a user-mode logical in the process logical name table
1717 * used for redirection of sys$error
4d9538c1
JM		 1718 *
1719 * Fix-me: The pTHX is not needed for this routine, however doio.c
1720 * is calling it with one instead of using a macro.
1721 * A macro needs to be added to vmsish.h and doio.c updated to use it.
1722 *
0e06870b
CB		 1723 */
1724void
2fbb330f 1725Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
0e06870b
CB		 1726{
1727 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1728 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
2d5e9e5d 1729 unsigned long int iss, attr = LNM$M_CONFINE;
0e06870b
CB		 1730 unsigned char acmode = PSL$C_USER;
1731 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1732 {0, 0, 0, 0}};
2fbb330f 1733 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
0e06870b
CB		 1734 d_name.dsc$w_length = strlen(name);
1735
1736 lnmlst[0].buflen = strlen(eqv);
2fbb330f 1737 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
0e06870b
CB		 1738
1739 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1740 if (!(iss&1)) lib$signal(iss);
1741}
1742/*}}}*/
c07a80fd 1743
f675dbe5 1744
c07a80fd 1745/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1746/* my_crypt - VMS password hashing
1747 * my_crypt() provides an interface compatible with the Unix crypt()
1748 * C library function, and uses sys$hash_password() to perform VMS
1749 * password hashing. The quadword hashed password value is returned
1750 * as a NUL-terminated 8 character string. my_crypt() does not change
1751 * the case of its string arguments; in order to match the behavior
1752 * of LOGINOUT et al., alphabetic characters in both arguments must
1753 * be upcased by the caller.
2497a41f
JM		 1754 *
1755 * - fix me to call ACM services when available
c07a80fd 1756 */
1757char *
fd8cd3a3 1758Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd 1759{
1760# ifndef UAI$C_PREFERRED_ALGORITHM
1761# define UAI$C_PREFERRED_ALGORITHM 127
1762# endif
1763 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1764 unsigned short int salt = 0;
1765 unsigned long int sts;
1766 struct const_dsc {
1767 unsigned short int dsc$w_length;
1768 unsigned char dsc$b_type;
1769 unsigned char dsc$b_class;
1770 const char * dsc$a_pointer;
1771 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1772 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1773 struct itmlst_3 uailst[3] = {
1774 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1775 { sizeof salt, UAI$_SALT, &salt, 0},
1776 { 0, 0, NULL, NULL}};
1777 static char hash[9];
1778
1779 usrdsc.dsc$w_length = strlen(usrname);
1780 usrdsc.dsc$a_pointer = usrname;
1781 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1782 switch (sts) {
f282b18d 1783 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
c07a80fd 1784 set_errno(EACCES);
1785 break;
1786 case RMS$_RNF:
1787 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1788 break;
1789 default:
1790 set_errno(EVMSERR);
1791 }
1792 set_vaxc_errno(sts);
1793 if (sts != RMS$_RNF) return NULL;
1794 }
1795
1796 txtdsc.dsc$w_length = strlen(textpasswd);
1797 txtdsc.dsc$a_pointer = textpasswd;
1798 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1799 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1800 }
1801
1802 return (char *) hash;
1803
1804} /* end of my_crypt() */
1805/*}}}*/
1806
1807
360732b5
JM		 1808static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1809static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1810static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
a0d0e21e 1811
2497a41f
JM		 1812/* fixup barenames that are directories for internal use.
1813 * There have been problems with the consistent handling of UNIX
1814 * style directory names when routines are presented with a name that
94ae10c0 1815 * has no directory delimiters at all. So this routine will eventually
2497a41f
JM		 1816 * fix the issue.
1817 */
1818static char * fixup_bare_dirnames(const char * name)
1819{
1820 if (decc_disable_to_vms_logname_translation) {
1821/* fix me */
1822 }
1823 return NULL;
1824}
1825
e0e5e8d6
JM		 1826/* 8.3, remove() is now broken on symbolic links */
1827static int rms_erase(const char * vmsname);
1828
1829
2497a41f 1830/* mp_do_kill_file
94ae10c0 1831 * A little hack to get around a bug in some implementation of remove()
2497a41f
JM		 1832 * that do not know how to delete a directory
1833 *
1834 * Delete any file to which user has control access, regardless of whether
1835 * delete access is explicitly allowed.
1836 * Limitations: User must have write access to parent directory.
1837 * Does not block signals or ASTs; if interrupted in midstream
1838 * may leave file with an altered ACL.
1839 * HANDLE WITH CARE!
1840 */
1841/*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1842static int
1843mp_do_kill_file(pTHX_ const char *name, int dirflag)
1844{
e0e5e8d6
JM		 1845 char *vmsname;
1846 char *rslt;
2497a41f
JM		 1847 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1848 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1849 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1850 struct myacedef {
1851 unsigned char myace$b_length;
1852 unsigned char myace$b_type;
1853 unsigned short int myace$w_flags;
1854 unsigned long int myace$l_access;
1855 unsigned long int myace$l_ident;
1856 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1857 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1858 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1859 struct itmlst_3
1860 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1861 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1862 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1863 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1864 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1865 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1866
1867 /* Expand the input spec using RMS, since the CRTL remove() and
1868 * system services won't do this by themselves, so we may miss
1869 * a file "hiding" behind a logical name or search list. */
c5375c28 1870 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
ebd4d70b 1871 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 1872
6fb6c614 1873 rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
e0e5e8d6 1874 if (rslt == NULL) {
c5375c28 1875 PerlMem_free(vmsname);
2497a41f
JM		 1876 return -1;
1877 }
c5375c28 1878
e0e5e8d6
JM		 1879 /* Erase the file */
1880 rmsts = rms_erase(vmsname);
2497a41f 1881
e0e5e8d6
JM		 1882 /* Did it succeed */
1883 if ($VMS_STATUS_SUCCESS(rmsts)) {
1884 PerlMem_free(vmsname);
1885 return 0;
2497a41f
JM		 1886 }
1887
1888 /* If not, can changing protections help? */
e0e5e8d6
JM		 1889 if (rmsts != RMS$_PRV) {
1890 set_vaxc_errno(rmsts);
1891 PerlMem_free(vmsname);
2497a41f
JM		 1892 return -1;
1893 }
1894
1895 /* No, so we get our own UIC to use as a rights identifier,
1896 * and the insert an ACE at the head of the ACL which allows us
1897 * to delete the file.
1898 */
ebd4d70b 1899 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
e0e5e8d6
JM		 1900 fildsc.dsc$w_length = strlen(vmsname);
1901 fildsc.dsc$a_pointer = vmsname;
2497a41f
JM		 1902 cxt = 0;
1903 newace.myace$l_ident = oldace.myace$l_ident;
e0e5e8d6 1904 rmsts = -1;
2497a41f
JM		 1905 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1906 switch (aclsts) {
1907 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1908 set_errno(ENOENT); break;
1909 case RMS$_DIR:
1910 set_errno(ENOTDIR); break;
1911 case RMS$_DEV:
1912 set_errno(ENODEV); break;
1913 case RMS$_SYN: case SS$_INVFILFOROP:
1914 set_errno(EINVAL); break;
1915 case RMS$_PRV:
1916 set_errno(EACCES); break;
1917 default:
ebd4d70b 1918 _ckvmssts_noperl(aclsts);
2497a41f
JM		 1919 }
1920 set_vaxc_errno(aclsts);
e0e5e8d6 1921 PerlMem_free(vmsname);
2497a41f
JM		 1922 return -1;
1923 }
1924 /* Grab any existing ACEs with this identifier in case we fail */
1925 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1926 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1927 || fndsts == SS$_NOMOREACE ) {
1928 /* Add the new ACE . . . */
1929 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1930 goto yourroom;
1931
e0e5e8d6
JM		 1932 rmsts = rms_erase(vmsname);
1933 if ($VMS_STATUS_SUCCESS(rmsts)) {
1934 rmsts = 0;
2497a41f
JM		 1935 }
1936 else {
e0e5e8d6 1937 rmsts = -1;
2497a41f
JM		 1938 /* We blew it - dir with files in it, no write priv for
1939 * parent directory, etc. Put things back the way they were. */
1940 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1941 goto yourroom;
1942 if (fndsts & 1) {
1943 addlst[0].bufadr = &oldace;
1944 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1945 goto yourroom;
1946 }
1947 }
1948 }
1949
1950 yourroom:
1951 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1952 /* We just deleted it, so of course it's not there. Some versions of
1953 * VMS seem to return success on the unlock operation anyhow (after all
1954 * the unlock is successful), but others don't.
1955 */
1956 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1957 if (aclsts & 1) aclsts = fndsts;
1958 if (!(aclsts & 1)) {
1959 set_errno(EVMSERR);
1960 set_vaxc_errno(aclsts);
2497a41f
JM		 1961 }
1962
e0e5e8d6 1963 PerlMem_free(vmsname);
2497a41f
JM		 1964 return rmsts;
1965
1966} /* end of kill_file() */
1967/*}}}*/
1968
1969
a0d0e21e
LW		 1970/*{{{int do_rmdir(char *name)*/
1971int
b8ffc8df 1972Perl_do_rmdir(pTHX_ const char *name)
a0d0e21e 1973{
e0e5e8d6 1974 char * dirfile;
a0d0e21e 1975 int retval;
61bb5906 1976 Stat_t st;
a0d0e21e 1977
d94c5a78
JM		 1978 /* lstat returns a VMS fileified specification of the name */
1979 /* that is looked up, and also lets verifies that this is a directory */
e0e5e8d6 1980
46c05374 1981 retval = flex_lstat(name, &st);
d94c5a78
JM		 1982 if (retval != 0) {
1983 char * ret_spec;
1984
1985 /* Due to a historical feature, flex_stat/lstat can not see some */
1986 /* Unix format file names that the rest of the CRTL can see */
1987 /* Fixing that feature will cause some perl tests to fail */
1988 /* So try this one more time. */
1989
1990 retval = lstat(name, &st.crtl_stat);
1991 if (retval != 0)
1992 return -1;
1993
1994 /* force it to a file spec for the kill file to work. */
1995 ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1996 if (ret_spec == NULL) {
1997 errno = EIO;
1998 return -1;
1999 }
e0e5e8d6 2000 }
d94c5a78
JM		 2001
2002 if (!S_ISDIR(st.st_mode)) {
e0e5e8d6
JM		 2003 errno = ENOTDIR;
2004 retval = -1;
2005 }
d94c5a78
JM		 2006 else {
2007 dirfile = st.st_devnam;
2008
2009 /* It may be possible for flex_stat to find a file and vmsify() to */
2010 /* fail with ODS-2 specifications. mp_do_kill_file can not deal */
2011 /* with that case, so fail it */
2012 if (dirfile[0] == 0) {
2013 errno = EIO;
2014 return -1;
2015 }
2016
e0e5e8d6 2017 retval = mp_do_kill_file(aTHX_ dirfile, 1);
d94c5a78 2018 }
e0e5e8d6 2019
a0d0e21e
LW		 2020 return retval;
2021
2022} /* end of do_rmdir */
2023/*}}}*/
2024
2025/* kill_file
2026 * Delete any file to which user has control access, regardless of whether
2027 * delete access is explicitly allowed.
2028 * Limitations: User must have write access to parent directory.
2029 * Does not block signals or ASTs; if interrupted in midstream
2030 * may leave file with an altered ACL.
2031 * HANDLE WITH CARE!
2032 */
2033/*{{{int kill_file(char *name)*/
2034int
b8ffc8df 2035Perl_kill_file(pTHX_ const char *name)
a0d0e21e 2036{
d94c5a78 2037 char * vmsfile;
e0e5e8d6
JM		 2038 Stat_t st;
2039 int rmsts;
a0d0e21e 2040
d94c5a78
JM		 2041 /* Convert the filename to VMS format and see if it is a directory */
2042 /* flex_lstat returns a vmsified file specification */
46c05374 2043 rmsts = flex_lstat(name, &st);
d94c5a78
JM		 2044 if (rmsts != 0) {
2045
2046 /* Due to a historical feature, flex_stat/lstat can not see some */
2047 /* Unix format file names that the rest of the CRTL can see when */
2048 /* ODS-2 file specifications are in use. */
2049 /* Fixing that feature will cause some perl tests to fail */
2050 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2051 st.st_mode = 0;
2052 vmsfile = (char *) name; /* cast ok */
2053
2054 } else {
2055 vmsfile = st.st_devnam;
2056 if (vmsfile[0] == 0) {
2057 /* It may be possible for flex_stat to find a file and vmsify() */
2058 /* to fail with ODS-2 specifications. mp_do_kill_file can not */
2059 /* deal with that case, so fail it */
2060 errno = EIO;
2061 return -1;
2062 }
2063 }
2064
2065 /* Remove() is allowed to delete directories, according to the X/Open
2066 * specifications.
2067 * This may need special handling to work with the ACL hacks.
a0d0e21e 2068 */
d94c5a78
JM		 2069 if (S_ISDIR(st.st_mode)) {
2070 rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2071 return rmsts;
a0d0e21e
LW		 2072 }
2073
d94c5a78
JM		 2074 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2075
2076 /* Need to delete all versions ? */
2077 if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2078 int i = 0;
2079
2080 /* Just use lstat() here as do not need st_dev */
2081 /* and we know that the file is in VMS format or that */
2082 /* because of a historical bug, flex_stat can not see the file */
2083 while (lstat(vmsfile, (stat_t *)&st) == 0) {
2084 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2085 if (rmsts != 0)
2086 break;
2087 i++;
2088
2089 /* Make sure that we do not loop forever */
2090 if (i > 32767) {
2091 errno = EIO;
2092 rmsts = -1;
2093 break;
2094 }
2095 }
2096 }
a0d0e21e
LW		 2097
2098 return rmsts;
2099
2100} /* end of kill_file() */
2101/*}}}*/
2102
8cc95fdb 2103
84902520 2104/*{{{int my_mkdir(char *,Mode_t)*/
8cc95fdb 2105int
b8ffc8df 2106Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
8cc95fdb 2107{
2108 STRLEN dirlen = strlen(dir);
2109
a2a90019
CB		 2110 /* zero length string sometimes gives ACCVIO */
2111 if (dirlen == 0) return -1;
2112
8cc95fdb 2113 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2114 * null file name/type. However, it's commonplace under Unix,
2115 * so we'll allow it for a gain in portability.
2116 */
2117 if (dir[dirlen-1] == '/') {
2118 char *newdir = savepvn(dir,dirlen-1);
2119 int ret = mkdir(newdir,mode);
2120 Safefree(newdir);
2121 return ret;
2122 }
2123 else return mkdir(dir,mode);
2124} /* end of my_mkdir */
2125/*}}}*/
2126
ee8c7f54
CB		 2127/*{{{int my_chdir(char *)*/
2128int
b8ffc8df 2129Perl_my_chdir(pTHX_ const char *dir)
ee8c7f54
CB		 2130{
2131 STRLEN dirlen = strlen(dir);
ee8c7f54
CB		 2132
2133 /* zero length string sometimes gives ACCVIO */
2134 if (dirlen == 0) return -1;
f7ddb74a
JM		 2135 const char *dir1;
2136
2137 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2138 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2139 * so that existing scripts do not need to be changed.
2140 */
2141 dir1 = dir;
2142 while ((dirlen > 0) && (*dir1 == ' ')) {
2143 dir1++;
2144 dirlen--;
2145 }
ee8c7f54
CB		 2146
2147 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2148 * that implies
2149 * null file name/type. However, it's commonplace under Unix,
2150 * so we'll allow it for a gain in portability.
f7ddb74a 2151 *
4d9538c1 2152 * '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
ee8c7f54 2153 */
f7ddb74a 2154 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
4d9538c1
JM		 2155 char *newdir;
2156 int ret;
2157 newdir = PerlMem_malloc(dirlen);
2158 if (newdir ==NULL)
2159 _ckvmssts_noperl(SS$_INSFMEM);
a35dcc95 2160 memcpy(newdir, dir1, dirlen-1);
4d9538c1
JM		 2161 newdir[dirlen-1] = '\0';
2162 ret = chdir(newdir);
2163 PerlMem_free(newdir);
2164 return ret;
ee8c7f54 2165 }
dca5a913 2166 else return chdir(dir1);
ee8c7f54
CB		 2167} /* end of my_chdir */
2168/*}}}*/
8cc95fdb 2169
674d6c38 2170
f1db9cda
JM		 2171/*{{{int my_chmod(char *, mode_t)*/
2172int
2173Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2174{
4d9538c1
JM		 2175 Stat_t st;
2176 int ret = -1;
2177 char * changefile;
f1db9cda
JM		 2178 STRLEN speclen = strlen(file_spec);
2179
2180 /* zero length string sometimes gives ACCVIO */
2181 if (speclen == 0) return -1;
2182
2183 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2184 * that implies null file name/type. However, it's commonplace under Unix,
2185 * so we'll allow it for a gain in portability.
2186 *
2187 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2188 * in VMS file.dir notation.
2189 */
4d9538c1
JM		 2190 changefile = (char *) file_spec; /* cast ok */
2191 ret = flex_lstat(file_spec, &st);
2192 if (ret != 0) {
f1db9cda 2193
4d9538c1
JM		 2194 /* Due to a historical feature, flex_stat/lstat can not see some */
2195 /* Unix format file names that the rest of the CRTL can see when */
2196 /* ODS-2 file specifications are in use. */
2197 /* Fixing that feature will cause some perl tests to fail */
2198 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2199 st.st_mode = 0;
f1db9cda 2200
4d9538c1
JM		 2201 } else {
2202 /* It may be possible to get here with nothing in st_devname */
2203 /* chmod still may work though */
2204 if (st.st_devnam[0] != 0) {
2205 changefile = st.st_devnam;
2206 }
f1db9cda 2207 }
4d9538c1
JM		 2208 ret = chmod(changefile, mode);
2209 return ret;
f1db9cda
JM		 2210} /* end of my_chmod */
2211/*}}}*/
2212
2213
674d6c38
CB		 2214/*{{{FILE *my_tmpfile()*/
2215FILE *
2216my_tmpfile(void)
2217{
2218 FILE *fp;
2219 char *cp;
674d6c38
CB		 2220
2221 if ((fp = tmpfile())) return fp;
2222
c5375c28
JM		 2223 cp = PerlMem_malloc(L_tmpnam+24);
2224 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2225
2497a41f
JM		 2226 if (decc_filename_unix_only == 0)
2227 strcpy(cp,"Sys$Scratch:");
2228 else
2229 strcpy(cp,"/tmp/");
674d6c38
CB		 2230 tmpnam(cp+strlen(cp));
2231 strcat(cp,".Perltmp");
2232 fp = fopen(cp,"w+","fop=dlt");
c5375c28 2233 PerlMem_free(cp);
674d6c38
CB		 2234 return fp;
2235}
2236/*}}}*/
2237
5c2d7af2 2238
5c2d7af2
CB		 2239/*
2240 * The C RTL's sigaction fails to check for invalid signal numbers so we
2241 * help it out a bit. The docs are correct, but the actual routine doesn't
2242 * do what the docs say it will.
2243 */
2244/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2245int
2246Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2247 struct sigaction* oact)
2248{
2249 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2250 SETERRNO(EINVAL, SS$_INVARG);
2251 return -1;
2252 }
2253 return sigaction(sig, act, oact);
2254}
2255/*}}}*/
5c2d7af2 2256
f2610a60
CL		 2257#ifdef KILL_BY_SIGPRC
2258#include <errnodef.h>
2259
05c058bc
CB		 2260/* We implement our own kill() using the undocumented system service
2261 sys$sigprc for one of two reasons:
2262
2263 1.) If the kill() in an older CRTL uses sys$forcex, causing the
f2610a60
CL		 2264 target process to do a sys$exit, which usually can't be handled
2265 gracefully...certainly not by Perl and the %SIG{} mechanism.
2266
05c058bc
CB		 2267 2.) If the kill() in the CRTL can't be called from a signal
2268 handler without disappearing into the ether, i.e., the signal
2269 it purportedly sends is never trapped. Still true as of VMS 7.3.
2270
2271 sys$sigprc has the same parameters as sys$forcex, but throws an exception
f2610a60
CL		 2272 in the target process rather than calling sys$exit.
2273
2274 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2275 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2276 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2277 with condition codes C$_SIG0+nsig*8, catching the exception on the
2278 target process and resignaling with appropriate arguments.
2279
2280 But we don't have that VMS 7.0+ exception handler, so if you
2281 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2282
2283 Also note that SIGTERM is listed in the docs as being "unimplemented",
2284 yet always seems to be signaled with a VMS condition code of 4 (and
2285 correctly handled for that code). So we hardwire it in.
2286
2287 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2288 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2289 than signalling with an unrecognized (and unhandled by CRTL) code.
2290*/
2291
fe1de8ce 2292#define _MY_SIG_MAX 28
f2610a60 2293
9c1171d1
JM		 2294static unsigned int
2295Perl_sig_to_vmscondition_int(int sig)
f2610a60 2296{
2e34cc90 2297 static unsigned int sig_code[_MY_SIG_MAX+1] =
f2610a60
CL		 2298 {
2299 0, /* 0 ZERO */
2300 SS$_HANGUP, /* 1 SIGHUP */
2301 SS$_CONTROLC, /* 2 SIGINT */
2302 SS$_CONTROLY, /* 3 SIGQUIT */
2303 SS$_RADRMOD, /* 4 SIGILL */
2304 SS$_BREAK, /* 5 SIGTRAP */
2305 SS$_OPCCUS, /* 6 SIGABRT */
2306 SS$_COMPAT, /* 7 SIGEMT */
2307#ifdef __VAX
2308 SS$_FLTOVF, /* 8 SIGFPE VAX */
2309#else
2310 SS$_HPARITH, /* 8 SIGFPE AXP */
2311#endif
2312 SS$_ABORT, /* 9 SIGKILL */
2313 SS$_ACCVIO, /* 10 SIGBUS */
2314 SS$_ACCVIO, /* 11 SIGSEGV */
2315 SS$_BADPARAM, /* 12 SIGSYS */
2316 SS$_NOMBX, /* 13 SIGPIPE */
2317 SS$_ASTFLT, /* 14 SIGALRM */
2318 4, /* 15 SIGTERM */
2319 0, /* 16 SIGUSR1 */
fe1de8ce
CB		 2320 0, /* 17 SIGUSR2 */
2321 0, /* 18 */
2322 0, /* 19 */
2323 0, /* 20 SIGCHLD */
2324 0, /* 21 SIGCONT */
2325 0, /* 22 SIGSTOP */
2326 0, /* 23 SIGTSTP */
2327 0, /* 24 SIGTTIN */
2328 0, /* 25 SIGTTOU */
2329 0, /* 26 */
2330 0, /* 27 */
2331 0 /* 28 SIGWINCH */
f2610a60
CL		 2332 };
2333
f2610a60
CL		 2334 static int initted = 0;
2335 if (!initted) {
2336 initted = 1;
2337 sig_code[16] = C$_SIGUSR1;
2338 sig_code[17] = C$_SIGUSR2;
fe1de8ce 2339 sig_code[20] = C$_SIGCHLD;
fe1de8ce
CB		 2340#if __CRTL_VER >= 70300000
2341 sig_code[28] = C$_SIGWINCH;
2342#endif
f2610a60 2343 }
f2610a60 2344
2e34cc90
CL		 2345 if (sig < _SIG_MIN) return 0;
2346 if (sig > _MY_SIG_MAX) return 0;
2347 return sig_code[sig];
2348}
2349
9c1171d1
JM		 2350unsigned int
2351Perl_sig_to_vmscondition(int sig)
2352{
2353#ifdef SS$_DEBUG
2354 if (vms_debug_on_exception != 0)
2355 lib$signal(SS$_DEBUG);
2356#endif
2357 return Perl_sig_to_vmscondition_int(sig);
2358}
2359
2360
2e34cc90
CL		 2361int
2362Perl_my_kill(int pid, int sig)
2363{
2364 int iss;
2365 unsigned int code;
17072196 2366#define sys$sigprc SYS$SIGPRC
2e34cc90
CL		 2367 int sys$sigprc(unsigned int *pidadr,
2368 struct dsc$descriptor_s *prcname,
2369 unsigned int code);
2370
7a7fd8e0
JM		 2371 /* sig 0 means validate the PID */
2372 /*------------------------------*/
2373 if (sig == 0) {
2374 const unsigned long int jpicode = JPI$_PID;
2375 pid_t ret_pid;
2376 int status;
2377 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2378 if ($VMS_STATUS_SUCCESS(status))
2379 return 0;
2380 switch (status) {
2381 case SS$_NOSUCHNODE:
2382 case SS$_UNREACHABLE:
2383 case SS$_NONEXPR:
2384 errno = ESRCH;
2385 break;
2386 case SS$_NOPRIV:
2387 errno = EPERM;
2388 break;
2389 default:
2390 errno = EVMSERR;
2391 }
2392 vaxc$errno=status;
2393 return -1;
2394 }
2395
9c1171d1 2396 code = Perl_sig_to_vmscondition_int(sig);
2e34cc90 2397
7a7fd8e0
JM		 2398 if (!code) {
2399 SETERRNO(EINVAL, SS$_BADPARAM);
2400 return -1;
2401 }
2402
2403 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2404 * signals are to be sent to multiple processes.
2405 * pid = 0 - all processes in group except ones that the system exempts
2406 * pid = -1 - all processes except ones that the system exempts
2407 * pid = -n - all processes in group (abs(n)) except ...
2408 * For now, just report as not supported.
2409 */
2410
2411 if (pid <= 0) {
2412 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
f2610a60
CL		 2413 return -1;
2414 }
2415
2e34cc90 2416 iss = sys$sigprc((unsigned int *)&pid,0,code);
f2610a60
CL		 2417 if (iss&1) return 0;
2418
2419 switch (iss) {
2420 case SS$_NOPRIV:
2421 set_errno(EPERM); break;
2422 case SS$_NONEXPR:
2423 case SS$_NOSUCHNODE:
2424 case SS$_UNREACHABLE:
2425 set_errno(ESRCH); break;
2426 case SS$_INSFMEM:
2427 set_errno(ENOMEM); break;
2428 default:
ebd4d70b 2429 _ckvmssts_noperl(iss);
f2610a60
CL		 2430 set_errno(EVMSERR);
2431 }
2432 set_vaxc_errno(iss);
2433
2434 return -1;
2435}
2436#endif
2437
2fbb330f
JM		 2438/* Routine to convert a VMS status code to a UNIX status code.
2439** More tricky than it appears because of conflicting conventions with
2440** existing code.
2441**
2442** VMS status codes are a bit mask, with the least significant bit set for
2443** success.
2444**
2445** Special UNIX status of EVMSERR indicates that no translation is currently
2446** available, and programs should check the VMS status code.
2447**
2448** Programs compiled with _POSIX_EXIT have a special encoding that requires
2449** decoding.
2450*/
2451
2452#ifndef C_FACILITY_NO
2453#define C_FACILITY_NO 0x350000
2454#endif
2455#ifndef DCL_IVVERB
2456#define DCL_IVVERB 0x38090
2457#endif
2458
7a7fd8e0 2459int Perl_vms_status_to_unix(int vms_status, int child_flag)
2fbb330f
JM		 2460{
2461int facility;
2462int fac_sp;
2463int msg_no;
2464int msg_status;
2465int unix_status;
2466
2467 /* Assume the best or the worst */
2468 if (vms_status & STS$M_SUCCESS)
2469 unix_status = 0;
2470 else
2471 unix_status = EVMSERR;
2472
2473 msg_status = vms_status & ~STS$M_CONTROL;
2474
2475 facility = vms_status & STS$M_FAC_NO;
2476 fac_sp = vms_status & STS$M_FAC_SP;
2477 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2478
0968cdad 2479 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2fbb330f
JM		 2480 switch(msg_no) {
2481 case SS$_NORMAL:
2482 unix_status = 0;
2483 break;
2484 case SS$_ACCVIO:
2485 unix_status = EFAULT;
2486 break;
7a7fd8e0
JM		 2487 case SS$_DEVOFFLINE:
2488 unix_status = EBUSY;
2489 break;
2490 case SS$_CLEARED:
2491 unix_status = ENOTCONN;
2492 break;
2493 case SS$_IVCHAN:
2fbb330f
JM		 2494 case SS$_IVLOGNAM:
2495 case SS$_BADPARAM:
2496 case SS$_IVLOGTAB:
2497 case SS$_NOLOGNAM:
2498 case SS$_NOLOGTAB:
2499 case SS$_INVFILFOROP:
2500 case SS$_INVARG:
2501 case SS$_NOSUCHID:
2502 case SS$_IVIDENT:
2503 unix_status = EINVAL;
2504 break;
7a7fd8e0
JM		 2505 case SS$_UNSUPPORTED:
2506 unix_status = ENOTSUP;
2507 break;
2fbb330f
JM		 2508 case SS$_FILACCERR:
2509 case SS$_NOGRPPRV:
2510 case SS$_NOSYSPRV:
2511 unix_status = EACCES;
2512 break;
2513 case SS$_DEVICEFULL:
2514 unix_status = ENOSPC;
2515 break;
2516 case SS$_NOSUCHDEV:
2517 unix_status = ENODEV;
2518 break;
2519 case SS$_NOSUCHFILE:
2520 case SS$_NOSUCHOBJECT:
2521 unix_status = ENOENT;
2522 break;
fb38d079
JM		 2523 case SS$_ABORT: /* Fatal case */
2524 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2525 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2fbb330f
JM		 2526 unix_status = EINTR;
2527 break;
2528 case SS$_BUFFEROVF:
2529 unix_status = E2BIG;
2530 break;
2531 case SS$_INSFMEM:
2532 unix_status = ENOMEM;
2533 break;
2534 case SS$_NOPRIV:
2535 unix_status = EPERM;
2536 break;
2537 case SS$_NOSUCHNODE:
2538 case SS$_UNREACHABLE:
2539 unix_status = ESRCH;
2540 break;
2541 case SS$_NONEXPR:
2542 unix_status = ECHILD;
2543 break;
2544 default:
2545 if ((facility == 0) && (msg_no < 8)) {
2546 /* These are not real VMS status codes so assume that they are
2547 ** already UNIX status codes
2548 */
2549 unix_status = msg_no;
2550 break;
2551 }
2552 }
2553 }
2554 else {
2555 /* Translate a POSIX exit code to a UNIX exit code */
2556 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
7a7fd8e0 2557 unix_status = (msg_no & 0x07F8) >> 3;
2fbb330f
JM		 2558 }
2559 else {
7a7fd8e0
JM		 2560
2561 /* Documented traditional behavior for handling VMS child exits */
2562 /*--------------------------------------------------------------*/
2563 if (child_flag != 0) {
2564
2565 /* Success / Informational return 0 */
2566 /*----------------------------------*/
2567 if (msg_no & STS$K_SUCCESS)
2568 return 0;
2569
2570 /* Warning returns 1 */
2571 /*-------------------*/
2572 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2573 return 1;
2574
2575 /* Everything else pass through the severity bits */
2576 /*------------------------------------------------*/
2577 return (msg_no & STS$M_SEVERITY);
2578 }
2579
2580 /* Normal VMS status to ERRNO mapping attempt */
2581 /*--------------------------------------------*/
2fbb330f
JM		 2582 switch(msg_status) {
2583 /* case RMS$_EOF: */ /* End of File */
2584 case RMS$_FNF: /* File Not Found */
2585 case RMS$_DNF: /* Dir Not Found */
2586 unix_status = ENOENT;
2587 break;
2588 case RMS$_RNF: /* Record Not Found */
2589 unix_status = ESRCH;
2590 break;
2591 case RMS$_DIR:
2592 unix_status = ENOTDIR;
2593 break;
2594 case RMS$_DEV:
2595 unix_status = ENODEV;
2596 break;
7a7fd8e0
JM		 2597 case RMS$_IFI:
2598 case RMS$_FAC:
2599 case RMS$_ISI:
2600 unix_status = EBADF;
2601 break;
2602 case RMS$_FEX:
2603 unix_status = EEXIST;
2604 break;
2fbb330f
JM		 2605 case RMS$_SYN:
2606 case RMS$_FNM:
2607 case LIB$_INVSTRDES:
2608 case LIB$_INVARG:
2609 case LIB$_NOSUCHSYM:
2610 case LIB$_INVSYMNAM:
2611 case DCL_IVVERB:
2612 unix_status = EINVAL;
2613 break;
2614 case CLI$_BUFOVF:
2615 case RMS$_RTB:
2616 case CLI$_TKNOVF:
2617 case CLI$_RSLOVF:
2618 unix_status = E2BIG;
2619 break;
2620 case RMS$_PRV: /* No privilege */
2621 case RMS$_ACC: /* ACP file access failed */
2622 case RMS$_WLK: /* Device write locked */
2623 unix_status = EACCES;
2624 break;
ed1b9de0
JM		 2625 case RMS$_MKD: /* Failed to mark for delete */
2626 unix_status = EPERM;
2627 break;
2fbb330f
JM		 2628 /* case RMS$_NMF: */ /* No more files */
2629 }
2630 }
2631 }
2632
2633 return unix_status;
2634}
2635
7a7fd8e0
JM		 2636/* Try to guess at what VMS error status should go with a UNIX errno
2637 * value. This is hard to do as there could be many possible VMS
2638 * error statuses that caused the errno value to be set.
2639 */
2640
2641int Perl_unix_status_to_vms(int unix_status)
2642{
2643int test_unix_status;
2644
2645 /* Trivial cases first */
2646 /*---------------------*/
2647 if (unix_status == EVMSERR)
2648 return vaxc$errno;
2649
2650 /* Is vaxc$errno sane? */
2651 /*---------------------*/
2652 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2653 if (test_unix_status == unix_status)
2654 return vaxc$errno;
2655
2656 /* If way out of range, must be VMS code already */
2657 /*-----------------------------------------------*/
2658 if (unix_status > EVMSERR)
2659 return unix_status;
2660
2661 /* If out of range, punt */
2662 /*-----------------------*/
2663 if (unix_status > __ERRNO_MAX)
2664 return SS$_ABORT;
2665
2666
2667 /* Ok, now we have to do it the hard way. */
2668 /*----------------------------------------*/
2669 switch(unix_status) {
2670 case 0: return SS$_NORMAL;
2671 case EPERM: return SS$_NOPRIV;
2672 case ENOENT: return SS$_NOSUCHOBJECT;
2673 case ESRCH: return SS$_UNREACHABLE;
2674 case EINTR: return SS$_ABORT;
2675 /* case EIO: */
2676 /* case ENXIO: */
2677 case E2BIG: return SS$_BUFFEROVF;
2678 /* case ENOEXEC */
2679 case EBADF: return RMS$_IFI;
2680 case ECHILD: return SS$_NONEXPR;
2681 /* case EAGAIN */
2682 case ENOMEM: return SS$_INSFMEM;
2683 case EACCES: return SS$_FILACCERR;
2684 case EFAULT: return SS$_ACCVIO;
2685 /* case ENOTBLK */
0968cdad 2686 case EBUSY: return SS$_DEVOFFLINE;
7a7fd8e0
JM		 2687 case EEXIST: return RMS$_FEX;
2688 /* case EXDEV */
2689 case ENODEV: return SS$_NOSUCHDEV;
2690 case ENOTDIR: return RMS$_DIR;
2691 /* case EISDIR */
2692 case EINVAL: return SS$_INVARG;
2693 /* case ENFILE */
2694 /* case EMFILE */
2695 /* case ENOTTY */
2696 /* case ETXTBSY */
2697 /* case EFBIG */
2698 case ENOSPC: return SS$_DEVICEFULL;
2699 case ESPIPE: return LIB$_INVARG;
2700 /* case EROFS: */
2701 /* case EMLINK: */
2702 /* case EPIPE: */
2703 /* case EDOM */
2704 case ERANGE: return LIB$_INVARG;
2705 /* case EWOULDBLOCK */
2706 /* case EINPROGRESS */
2707 /* case EALREADY */
2708 /* case ENOTSOCK */
2709 /* case EDESTADDRREQ */
2710 /* case EMSGSIZE */
2711 /* case EPROTOTYPE */
2712 /* case ENOPROTOOPT */
2713 /* case EPROTONOSUPPORT */
2714 /* case ESOCKTNOSUPPORT */
2715 /* case EOPNOTSUPP */
2716 /* case EPFNOSUPPORT */
2717 /* case EAFNOSUPPORT */
2718 /* case EADDRINUSE */
2719 /* case EADDRNOTAVAIL */
2720 /* case ENETDOWN */
2721 /* case ENETUNREACH */
2722 /* case ENETRESET */
2723 /* case ECONNABORTED */
2724 /* case ECONNRESET */
2725 /* case ENOBUFS */
2726 /* case EISCONN */
2727 case ENOTCONN: return SS$_CLEARED;
2728 /* case ESHUTDOWN */
2729 /* case ETOOMANYREFS */
2730 /* case ETIMEDOUT */
2731 /* case ECONNREFUSED */
2732 /* case ELOOP */
2733 /* case ENAMETOOLONG */
2734 /* case EHOSTDOWN */
2735 /* case EHOSTUNREACH */
2736 /* case ENOTEMPTY */
2737 /* case EPROCLIM */
2738 /* case EUSERS */
2739 /* case EDQUOT */
2740 /* case ENOMSG */
2741 /* case EIDRM */
2742 /* case EALIGN */
2743 /* case ESTALE */
2744 /* case EREMOTE */
2745 /* case ENOLCK */
2746 /* case ENOSYS */
2747 /* case EFTYPE */
2748 /* case ECANCELED */
2749 /* case EFAIL */
2750 /* case EINPROG */
2751 case ENOTSUP:
2752 return SS$_UNSUPPORTED;
2753 /* case EDEADLK */
2754 /* case ENWAIT */
2755 /* case EILSEQ */
2756 /* case EBADCAT */
2757 /* case EBADMSG */
2758 /* case EABANDONED */
2759 default:
2760 return SS$_ABORT; /* punt */
2761 }
7a7fd8e0 2762}
2fbb330f
JM		 2763
2764
22d4bb9c 2765/* default piping mailbox size */
df17c887
CB		 2766#ifdef __VAX
2767# define PERL_BUFSIZ 512
2768#else
2769# define PERL_BUFSIZ 8192
2770#endif
22d4bb9c 2771
674d6c38 2772
a0d0e21e 2773static void
8a646e0b 2774create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 2775{
22d4bb9c
CB		 2776 unsigned long int mbxbufsiz;
2777 static unsigned long int syssize = 0;
2778 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 2779 char csize[LNM$C_NAMLENGTH+1];
f7ddb74a
JM		 2780 int sts;
2781
22d4bb9c
CB		 2782 if (!syssize) {
2783 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 2784 /*
22d4bb9c
CB		 2785 * Get the SYSGEN parameter MAXBUF
2786 *
2787 * If the logical 'PERL_MBX_SIZE' is defined
2788 * use the value of the logical instead of PERL_BUFSIZ, but
2789 * keep the size between 128 and MAXBUF.
2790 *
a0d0e21e 2791 */
ebd4d70b 2792 _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
22d4bb9c
CB		 2793 }
2794
2795 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2796 mbxbufsiz = atoi(csize);
2797 } else {
2798 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 2799 }
22d4bb9c
CB		 2800 if (mbxbufsiz < 128) mbxbufsiz = 128;
2801 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2802
ebd4d70b 2803 _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 2804
ebd4d70b
JM		 2805 sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2806 _ckvmssts_noperl(sts);
a0d0e21e
LW		 2807 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2808
2809} /* end of create_mbx() */
2810
22d4bb9c 2811
a0d0e21e 2812/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 2813
2814typedef struct _iosb IOSB;
2815typedef struct _iosb* pIOSB;
2816typedef struct _pipe Pipe;
2817typedef struct _pipe* pPipe;
2818typedef struct pipe_details Info;
2819typedef struct pipe_details* pInfo;
2820typedef struct _srqp RQE;
2821typedef struct _srqp* pRQE;
2822typedef struct _tochildbuf CBuf;
2823typedef struct _tochildbuf* pCBuf;
2824
2825struct _iosb {
2826 unsigned short status;
2827 unsigned short count;
2828 unsigned long dvispec;
2829};
2830
2831#pragma member_alignment save
2832#pragma nomember_alignment quadword
2833struct _srqp { /* VMS self-relative queue entry */
2834 unsigned long qptr[2];
2835};
2836#pragma member_alignment restore
2837static RQE RQE_ZERO = {0,0};
2838
2839struct _tochildbuf {
2840 RQE q;
2841 int eof;
2842 unsigned short size;
2843 char *buf;
2844};
2845
2846struct _pipe {
2847 RQE free;
2848 RQE wait;
2849 int fd_out;
2850 unsigned short chan_in;
2851 unsigned short chan_out;
2852 char *buf;
2853 unsigned int bufsize;
2854 IOSB iosb;
2855 IOSB iosb2;
2856 int *pipe_done;
2857 int retry;
2858 int type;
2859 int shut_on_empty;
2860 int need_wake;
2861 pPipe *home;
2862 pInfo info;
2863 pCBuf curr;
2864 pCBuf curr2;
fd8cd3a3
DS		 2865#if defined(PERL_IMPLICIT_CONTEXT)
2866 void *thx; /* Either a thread or an interpreter */
2867 /* pointer, depending on how we're built */
2868#endif
22d4bb9c
CB		 2869};
2870
2871
a0d0e21e
LW		 2872struct pipe_details
2873{
22d4bb9c 2874 pInfo next;
ff7adb52
CL		 2875 PerlIO *fp; /* file pointer to pipe mailbox */
2876 int useFILE; /* using stdio, not perlio */
748a9306
LW		 2877 int pid; /* PID of subprocess */
2878 int mode; /* == 'r' if pipe open for reading */
2879 int done; /* subprocess has completed */
ff7adb52 2880 int waiting; /* waiting for completion/closure */
22d4bb9c
CB		 2881 int closing; /* my_pclose is closing this pipe */
2882 unsigned long completion; /* termination status of subprocess */
2883 pPipe in; /* pipe in to sub */
2884 pPipe out; /* pipe out of sub */
2885 pPipe err; /* pipe of sub's sys$error */
2886 int in_done; /* true when in pipe finished */
2887 int out_done;
2888 int err_done;
cd1191f1
CB		 2889 unsigned short xchan; /* channel to debug xterm */
2890 unsigned short xchan_valid; /* channel is assigned */
a0d0e21e
LW		 2891};
2892
748a9306
LW		 2893struct exit_control_block
2894{
2895 struct exit_control_block *flink;
f7c699a0 2896 unsigned long int (*exit_routine)(void);
748a9306
LW		 2897 unsigned long int arg_count;
2898 unsigned long int *status_address;
2899 unsigned long int exit_status;
2900};
2901
d85f548a
JH		 2902typedef struct _closed_pipes Xpipe;
2903typedef struct _closed_pipes* pXpipe;
2904
2905struct _closed_pipes {
2906 int pid; /* PID of subprocess */
2907 unsigned long completion; /* termination status of subprocess */
2908};
2909#define NKEEPCLOSED 50
2910static Xpipe closed_list[NKEEPCLOSED];
2911static int closed_index = 0;
2912static int closed_num = 0;
2913
22d4bb9c
CB		 2914#define RETRY_DELAY "0 ::0.20"
2915#define MAX_RETRY 50
a0d0e21e 2916
22d4bb9c
CB		 2917static int pipe_ef = 0; /* first call to safe_popen inits these*/
2918static unsigned long mypid;
2919static unsigned long delaytime[2];
2920
2921static pInfo open_pipes = NULL;
2922static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 2923
ff7adb52
CL		 2924#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2925
2926
3eeba6fb 2927
748a9306 2928static unsigned long int
f7c699a0 2929pipe_exit_routine(void)
748a9306 2930{
22d4bb9c 2931 pInfo info;
1e422769 2932 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
4e0c9737 2933 int sts, did_stuff, j;
ff7adb52 2934
5ce486e0
CB		 2935 /*
2936 * Flush any pending i/o, but since we are in process run-down, be
2937 * careful about referencing PerlIO structures that may already have
2938 * been deallocated. We may not even have an interpreter anymore.
ff7adb52
CL		 2939 */
2940 info = open_pipes;
2941 while (info) {
2942 if (info->fp) {
ebd4d70b
JM		 2943#if defined(PERL_IMPLICIT_CONTEXT)
2944 /* We need to use the Perl context of the thread that created */
2945 /* the pipe. */
2946 pTHX;
2947 if (info->err)
2948 aTHX = info->err->thx;
2949 else if (info->out)
2950 aTHX = info->out->thx;
2951 else if (info->in)
2952 aTHX = info->in->thx;
2953#endif
5ce486e0
CB		 2954 if (!info->useFILE
2955#if defined(USE_ITHREADS)
2956 && my_perl
2957#endif
a24c654f
CB		 2958#ifdef USE_PERLIO
2959 && PL_perlio_fd_refcnt
2960#endif
2961 )
5ce486e0 2962 PerlIO_flush(info->fp);
ff7adb52
CL		 2963 else
2964 fflush((FILE *)info->fp);
2965 }
2966 info = info->next;
2967 }
3eeba6fb
CB		 2968
2969 /*
ff7adb52 2970 next we try sending an EOF...ignore if doesn't work, make sure we
3eeba6fb
CB		 2971 don't hang
2972 */
2973 did_stuff = 0;
2974 info = open_pipes;
748a9306 2975
3eeba6fb 2976 while (info) {
d4c83939 2977 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 2978 if (info->in && !info->in->shut_on_empty) {
d4c83939 2979 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
ebd4d70b 2980 0, 0, 0, 0, 0, 0));
ff7adb52 2981 info->waiting = 1;
22d4bb9c 2982 did_stuff = 1;
748a9306 2983 }
d4c83939 2984 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2985 info = info->next;
2986 }
ff7adb52
CL		 2987
2988 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2989
2990 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2991 int nwait = 0;
2992
2993 info = open_pipes;
2994 while (info) {
d4c83939 2995 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 2996 if (info->waiting && info->done)
2997 info->waiting = 0;
2998 nwait += info->waiting;
d4c83939 2999 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 3000 info = info->next;
3001 }
3002 if (!nwait) break;
3003 sleep(1);
3004 }
3eeba6fb
CB		 3005
3006 did_stuff = 0;
3007 info = open_pipes;
3008 while (info) {
d4c83939 3009 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 3010 if (!info->done) { /* Tap them gently on the shoulder . . .*/
3011 sts = sys$forcex(&info->pid,0,&abort);
d4c83939 3012 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3eeba6fb
CB		 3013 did_stuff = 1;
3014 }
d4c83939 3015 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3016 info = info->next;
3017 }
ff7adb52
CL		 3018
3019 /* again, wait for effect */
3020
3021 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3022 int nwait = 0;
3023
3024 info = open_pipes;
3025 while (info) {
d4c83939 3026 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 3027 if (info->waiting && info->done)
3028 info->waiting = 0;
3029 nwait += info->waiting;
d4c83939 3030 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 3031 info = info->next;
3032 }
3033 if (!nwait) break;
3034 sleep(1);
3035 }
3eeba6fb
CB		 3036
3037 info = open_pipes;
3038 while (info) {
d4c83939 3039 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 3040 if (!info->done) { /* We tried to be nice . . . */
3041 sts = sys$delprc(&info->pid,0);
d4c83939 3042 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2f1dcba4 3043 info->done = 1; /* sys$delprc is as done as we're going to get. */
3eeba6fb 3044 }
d4c83939 3045 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3046 info = info->next;
3047 }
3048
3049 while(open_pipes) {
ebd4d70b
JM		 3050
3051#if defined(PERL_IMPLICIT_CONTEXT)
3052 /* We need to use the Perl context of the thread that created */
3053 /* the pipe. */
3054 pTHX;
36b6faa8
CB		 3055 if (open_pipes->err)
3056 aTHX = open_pipes->err->thx;
3057 else if (open_pipes->out)
3058 aTHX = open_pipes->out->thx;
3059 else if (open_pipes->in)
3060 aTHX = open_pipes->in->thx;
ebd4d70b 3061#endif
1e422769 3062 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3063 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 3064 }
3065 return retsts;
3066}
3067
3068static struct exit_control_block pipe_exitblock =
3069 {(struct exit_control_block *) 0,
3070 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3071
22d4bb9c
CB		 3072static void pipe_mbxtofd_ast(pPipe p);
3073static void pipe_tochild1_ast(pPipe p);
3074static void pipe_tochild2_ast(pPipe p);
748a9306 3075
a0d0e21e 3076static void
22d4bb9c 3077popen_completion_ast(pInfo info)
a0d0e21e 3078{
22d4bb9c
CB		 3079 pInfo i = open_pipes;
3080 int iss;
d85f548a
JH		 3081
3082 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3083 closed_list[closed_index].pid = info->pid;
3084 closed_list[closed_index].completion = info->completion;
3085 closed_index++;
3086 if (closed_index == NKEEPCLOSED)
3087 closed_index = 0;
3088 closed_num++;
22d4bb9c
CB		 3089
3090 while (i) {
3091 if (i == info) break;
3092 i = i->next;
3093 }
3094 if (!i) return; /* unlinked, probably freed too */
3095
22d4bb9c
CB		 3096 info->done = TRUE;
3097
3098/*
3099 Writing to subprocess ...
3100 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3101
3102 chan_out may be waiting for "done" flag, or hung waiting
3103 for i/o completion to child...cancel the i/o. This will
3104 put it into "snarf mode" (done but no EOF yet) that discards
3105 input.
3106
3107 Output from subprocess (stdout, stderr) needs to be flushed and
3108 shut down. We try sending an EOF, but if the mbx is full the pipe
3109 routine should still catch the "shut_on_empty" flag, telling it to
3110 use immediate-style reads so that "mbx empty" -> EOF.
3111
3112
3113*/
3114 if (info->in && !info->in_done) { /* only for mode=w */
3115 if (info->in->shut_on_empty && info->in->need_wake) {
3116 info->in->need_wake = FALSE;
fd8cd3a3 3117 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 3118 } else {
fd8cd3a3 3119 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 3120 }
3121 }
3122
3123 if (info->out && !info->out_done) { /* were we also piping output? */
3124 info->out->shut_on_empty = TRUE;
3125 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3126 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3127 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3128 }
3129
3130 if (info->err && !info->err_done) { /* we were piping stderr */
3131 info->err->shut_on_empty = TRUE;
3132 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3133 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3134 _ckvmssts_noperl(iss);
a0d0e21e 3135 }
fd8cd3a3 3136 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3137
a0d0e21e
LW		 3138}
3139
2fbb330f 3140static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
218fdd94 3141static void vms_execfree(struct dsc$descriptor_s *vmscmd);
22d4bb9c
CB		 3142static void pipe_infromchild_ast(pPipe p);
3143
3144/*
3145 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3146 inside an AST routine without worrying about reentrancy and which Perl
3147 memory allocator is being used.
3148
3149 We read data and queue up the buffers, then spit them out one at a
3150 time to the output mailbox when the output mailbox is ready for one.
3151
3152*/
3153#define INITIAL_TOCHILDQUEUE 2
3154
3155static pPipe
fd8cd3a3 3156pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3157{
22d4bb9c
CB		 3158 pPipe p;
3159 pCBuf b;
3160 char mbx1[64], mbx2[64];
3161 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3162 DSC$K_CLASS_S, mbx1},
3163 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3164 DSC$K_CLASS_S, mbx2};
3165 unsigned int dviitm = DVI$_DEVBUFSIZ;
3166 int j, n;
3167
d4c83939 3168 n = sizeof(Pipe);
ebd4d70b 3169 _ckvmssts_noperl(lib$get_vm(&n, &p));
22d4bb9c 3170
8a646e0b
JM		 3171 create_mbx(&p->chan_in , &d_mbx1);
3172 create_mbx(&p->chan_out, &d_mbx2);
ebd4d70b 3173 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
22d4bb9c
CB		 3174
3175 p->buf = 0;
3176 p->shut_on_empty = FALSE;
3177 p->need_wake = FALSE;
3178 p->type = 0;
3179 p->retry = 0;
3180 p->iosb.status = SS$_NORMAL;
3181 p->iosb2.status = SS$_NORMAL;
3182 p->free = RQE_ZERO;
3183 p->wait = RQE_ZERO;
3184 p->curr = 0;
3185 p->curr2 = 0;
3186 p->info = 0;
fd8cd3a3
DS		 3187#ifdef PERL_IMPLICIT_CONTEXT
3188 p->thx = aTHX;
3189#endif
22d4bb9c
CB		 3190
3191 n = sizeof(CBuf) + p->bufsize;
3192
3193 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
ebd4d70b 3194 _ckvmssts_noperl(lib$get_vm(&n, &b));
22d4bb9c 3195 b->buf = (char *) b + sizeof(CBuf);
ebd4d70b 3196 _ckvmssts_noperl(lib$insqhi(b, &p->free));
22d4bb9c
CB		 3197 }
3198
3199 pipe_tochild2_ast(p);
3200 pipe_tochild1_ast(p);
3201 strcpy(wmbx, mbx1);
3202 strcpy(rmbx, mbx2);
3203 return p;
3204}
3205
3206/* reads the MBX Perl is writing, and queues */
3207
3208static void
3209pipe_tochild1_ast(pPipe p)
3210{
22d4bb9c
CB		 3211 pCBuf b = p->curr;
3212 int iss = p->iosb.status;
3213 int eof = (iss == SS$_ENDOFFILE);
f7ddb74a 3214 int sts;
fd8cd3a3
DS		 3215#ifdef PERL_IMPLICIT_CONTEXT
3216 pTHX = p->thx;
3217#endif
22d4bb9c
CB		 3218
3219 if (p->retry) {
3220 if (eof) {
3221 p->shut_on_empty = TRUE;
3222 b->eof = TRUE;
ebd4d70b 3223 _ckvmssts_noperl(sys$dassgn(p->chan_in));
22d4bb9c 3224 } else {
ebd4d70b 3225 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3226 }
3227
3228 b->eof = eof;
3229 b->size = p->iosb.count;
ebd4d70b 3230 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
22d4bb9c
CB		 3231 if (p->need_wake) {
3232 p->need_wake = FALSE;
ebd4d70b 3233 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
22d4bb9c
CB		 3234 }
3235 } else {
3236 p->retry = 1; /* initial call */
3237 }
3238
3239 if (eof) { /* flush the free queue, return when done */
3240 int n = sizeof(CBuf) + p->bufsize;
3241 while (1) {
3242 iss = lib$remqti(&p->free, &b);
3243 if (iss == LIB$_QUEWASEMP) return;
ebd4d70b
JM		 3244 _ckvmssts_noperl(iss);
3245 _ckvmssts_noperl(lib$free_vm(&n, &b));
22d4bb9c
CB		 3246 }
3247 }
3248
3249 iss = lib$remqti(&p->free, &b);
3250 if (iss == LIB$_QUEWASEMP) {
3251 int n = sizeof(CBuf) + p->bufsize;
ebd4d70b 3252 _ckvmssts_noperl(lib$get_vm(&n, &b));
22d4bb9c
CB		 3253 b->buf = (char *) b + sizeof(CBuf);
3254 } else {
ebd4d70b 3255 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3256 }
3257
3258 p->curr = b;
3259 iss = sys$qio(0,p->chan_in,
3260 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3261 &p->iosb,
3262 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3263 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
ebd4d70b 3264 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3265}
3266
3267
3268/* writes queued buffers to output, waits for each to complete before
3269 doing the next */
3270
3271static void
3272pipe_tochild2_ast(pPipe p)
3273{
22d4bb9c
CB		 3274 pCBuf b = p->curr2;
3275 int iss = p->iosb2.status;
3276 int n = sizeof(CBuf) + p->bufsize;
3277 int done = (p->info && p->info->done) ||
3278 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 3279#if defined(PERL_IMPLICIT_CONTEXT)
3280 pTHX = p->thx;
3281#endif
22d4bb9c
CB		 3282
3283 do {
3284 if (p->type) { /* type=1 has old buffer, dispose */
3285 if (p->shut_on_empty) {
ebd4d70b 3286 _ckvmssts_noperl(lib$free_vm(&n, &b));
22d4bb9c 3287 } else {
ebd4d70b 3288 _ckvmssts_noperl(lib$insqhi(b, &p->free));
22d4bb9c
CB		 3289 }
3290 p->type = 0;
3291 }
3292
3293 iss = lib$remqti(&p->wait, &b);
3294 if (iss == LIB$_QUEWASEMP) {
3295 if (p->shut_on_empty) {
3296 if (done) {
ebd4d70b 3297 _ckvmssts_noperl(sys$dassgn(p->chan_out));
22d4bb9c 3298 *p->pipe_done = TRUE;
ebd4d70b 3299 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3300 } else {
ebd4d70b 3301 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
22d4bb9c
CB		 3302 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3303 }
3304 return;
3305 }
3306 p->need_wake = TRUE;
3307 return;
3308 }
ebd4d70b 3309 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3310 p->type = 1;
3311 } while (done);
3312
3313
3314 p->curr2 = b;
3315 if (b->eof) {
ebd4d70b 3316 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
22d4bb9c
CB		 3317 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3318 } else {
ebd4d70b 3319 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
22d4bb9c
CB		 3320 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3321 }
3322
3323 return;
3324
3325}
3326
3327
3328static pPipe
fd8cd3a3 3329pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3330{
22d4bb9c
CB		 3331 pPipe p;
3332 char mbx1[64], mbx2[64];
3333 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3334 DSC$K_CLASS_S, mbx1},
3335 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3336 DSC$K_CLASS_S, mbx2};
3337 unsigned int dviitm = DVI$_DEVBUFSIZ;
3338
d4c83939 3339 int n = sizeof(Pipe);
ebd4d70b 3340 _ckvmssts_noperl(lib$get_vm(&n, &p));
8a646e0b
JM		 3341 create_mbx(&p->chan_in , &d_mbx1);
3342 create_mbx(&p->chan_out, &d_mbx2);
22d4bb9c 3343
ebd4d70b 3344 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939 3345 n = p->bufsize * sizeof(char);
ebd4d70b 3346 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3347 p->shut_on_empty = FALSE;
3348 p->info = 0;
3349 p->type = 0;
3350 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 3351#if defined(PERL_IMPLICIT_CONTEXT)
3352 p->thx = aTHX;
3353#endif
22d4bb9c
CB		 3354 pipe_infromchild_ast(p);
3355
3356 strcpy(wmbx, mbx1);
3357 strcpy(rmbx, mbx2);
3358 return p;
3359}
3360
3361static void
3362pipe_infromchild_ast(pPipe p)
3363{
22d4bb9c
CB		 3364 int iss = p->iosb.status;
3365 int eof = (iss == SS$_ENDOFFILE);
3366 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3367 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 3368#if defined(PERL_IMPLICIT_CONTEXT)
3369 pTHX = p->thx;
3370#endif
22d4bb9c
CB		 3371
3372 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
ebd4d70b 3373 _ckvmssts_noperl(sys$dassgn(p->chan_out));
22d4bb9c
CB		 3374 p->chan_out = 0;
3375 }
3376
3377 /* read completed:
3378 input shutdown if EOF from self (done or shut_on_empty)
3379 output shutdown if closing flag set (my_pclose)
3380 send data/eof from child or eof from self
3381 otherwise, re-read (snarf of data from child)
3382 */
3383
3384 if (p->type == 1) {
3385 p->type = 0;
3386 if (myeof && p->chan_in) { /* input shutdown */
ebd4d70b 3387 _ckvmssts_noperl(sys$dassgn(p->chan_in));
22d4bb9c
CB		 3388 p->chan_in = 0;
3389 }
3390
3391 if (p->chan_out) {
3392 if (myeof || kideof) { /* pass EOF to parent */
ebd4d70b
JM		 3393 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3394 pipe_infromchild_ast, p,
3395 0, 0, 0, 0, 0, 0));
22d4bb9c
CB		 3396 return;
3397 } else if (eof) { /* eat EOF --- fall through to read*/
3398
3399 } else { /* transmit data */
ebd4d70b
JM		 3400 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3401 pipe_infromchild_ast,p,
3402 p->buf, p->iosb.count, 0, 0, 0, 0));
22d4bb9c
CB		 3403 return;
3404 }
3405 }
3406 }
3407
3408 /* everything shut? flag as done */
3409
3410 if (!p->chan_in && !p->chan_out) {
3411 *p->pipe_done = TRUE;
ebd4d70b 3412 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c
CB		 3413 return;
3414 }
3415
3416 /* write completed (or read, if snarfing from child)
3417 if still have input active,
3418 queue read...immediate mode if shut_on_empty so we get EOF if empty
3419 otherwise,
3420 check if Perl reading, generate EOFs as needed
3421 */
3422
3423 if (p->type == 0) {
3424 p->type = 1;
3425 if (p->chan_in) {
3426 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3427 pipe_infromchild_ast,p,
3428 p->buf, p->bufsize, 0, 0, 0, 0);
3429 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
ebd4d70b 3430 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3431 } else { /* send EOFs for extra reads */
3432 p->iosb.status = SS$_ENDOFFILE;
3433 p->iosb.dvispec = 0;
ebd4d70b
JM		 3434 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3435 0, 0, 0,
3436 pipe_infromchild_ast, p, 0, 0, 0, 0));
22d4bb9c
CB		 3437 }
3438 }
3439}
3440
3441static pPipe
fd8cd3a3 3442pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 3443{
22d4bb9c
CB		 3444 pPipe p;
3445 char mbx[64];
3446 unsigned long dviitm = DVI$_DEVBUFSIZ;
3447 struct stat s;
3448 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3449 DSC$K_CLASS_S, mbx};
a480973c 3450 int n = sizeof(Pipe);
22d4bb9c
CB		 3451
3452 /* things like terminals and mbx's don't need this filter */
3453 if (fd && fstat(fd,&s) == 0) {
4e0c9737 3454 unsigned long devchar;
cfcfe586
JM		 3455 char device[65];
3456 unsigned short dev_len;
3457 struct dsc$descriptor_s d_dev;
3458 char * cptr;
3459 struct item_list_3 items[3];
3460 int status;
3461 unsigned short dvi_iosb[4];
3462
3463 cptr = getname(fd, out, 1);
ebd4d70b 3464 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
cfcfe586
JM		 3465 d_dev.dsc$a_pointer = out;
3466 d_dev.dsc$w_length = strlen(out);
3467 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3468 d_dev.dsc$b_class = DSC$K_CLASS_S;
3469
3470 items[0].len = 4;
3471 items[0].code = DVI$_DEVCHAR;
3472 items[0].bufadr = &devchar;
3473 items[0].retadr = NULL;
3474 items[1].len = 64;
3475 items[1].code = DVI$_FULLDEVNAM;
3476 items[1].bufadr = device;
3477 items[1].retadr = &dev_len;
3478 items[2].len = 0;
3479 items[2].code = 0;
3480
3481 status = sys$getdviw
3482 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
ebd4d70b 3483 _ckvmssts_noperl(status);
cfcfe586
JM		 3484 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3485 device[dev_len] = 0;
3486
3487 if (!(devchar & DEV$M_DIR)) {
3488 strcpy(out, device);
3489 return 0;
3490 }
3491 }
22d4bb9c
CB		 3492 }
3493
ebd4d70b 3494 _ckvmssts_noperl(lib$get_vm(&n, &p));
22d4bb9c 3495 p->fd_out = dup(fd);
8a646e0b 3496 create_mbx(&p->chan_in, &d_mbx);
ebd4d70b 3497 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939 3498 n = (p->bufsize+1) * sizeof(char);
ebd4d70b 3499 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3500 p->shut_on_empty = FALSE;
3501 p->retry = 0;
3502 p->info = 0;
3503 strcpy(out, mbx);
3504
ebd4d70b
JM		 3505 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3506 pipe_mbxtofd_ast, p,
3507 p->buf, p->bufsize, 0, 0, 0, 0));
22d4bb9c
CB		 3508
3509 return p;
3510}
3511
3512static void
3513pipe_mbxtofd_ast(pPipe p)
3514{
22d4bb9c
CB		 3515 int iss = p->iosb.status;
3516 int done = p->info->done;
3517 int iss2;
3518 int eof = (iss == SS$_ENDOFFILE);
3519 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3520 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 3521#if defined(PERL_IMPLICIT_CONTEXT)
3522 pTHX = p->thx;
3523#endif
22d4bb9c
CB		 3524
3525 if (done && myeof) { /* end piping */
3526 close(p->fd_out);
3527 sys$dassgn(p->chan_in);
3528 *p->pipe_done = TRUE;
ebd4d70b 3529 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c
CB		 3530 return;
3531 }
3532
3533 if (!err && !eof) { /* good data to send to file */
3534 p->buf[p->iosb.count] = '\n';
3535 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3536 if (iss2 < 0) {
3537 p->retry++;
3538 if (p->retry < MAX_RETRY) {
ebd4d70b 3539 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
22d4bb9c
CB		 3540 return;
3541 }
3542 }
3543 p->retry = 0;
3544 } else if (err) {
ebd4d70b 3545 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3546 }
3547
3548
3549 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3550 pipe_mbxtofd_ast, p,
3551 p->buf, p->bufsize, 0, 0, 0, 0);
3552 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
ebd4d70b 3553 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3554}
3555
3556
3557typedef struct _pipeloc PLOC;
3558typedef struct _pipeloc* pPLOC;
3559
3560struct _pipeloc {
3561 pPLOC next;
3562 char dir[NAM$C_MAXRSS+1];
3563};
3564static pPLOC head_PLOC = 0;
3565
5c0ae288 3566void
fd8cd3a3 3567free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 3568{
3569 pPLOC p, pnext;
ff7adb52 3570 pPLOC *pHead = (pPLOC *)head;
5c0ae288 3571
ff7adb52 3572 p = *pHead;
5c0ae288
CL		 3573 while (p) {
3574 pnext = p->next;
e0ef6b43 3575 PerlMem_free(p);
5c0ae288
CL		 3576 p = pnext;
3577 }
ff7adb52 3578 *pHead = 0;
5c0ae288 3579}
22d4bb9c
CB		 3580
3581static void
fd8cd3a3 3582store_pipelocs(pTHX)
22d4bb9c
CB		 3583{
3584 int i;
3585 pPLOC p;
ff7adb52 3586 AV *av = 0;
22d4bb9c 3587 SV *dirsv;
22d4bb9c
CB		 3588 char *dir, *x;
3589 char *unixdir;
3590 char temp[NAM$C_MAXRSS+1];
3591 STRLEN n_a;
3592
ff7adb52 3593 if (head_PLOC)
218fdd94 3594 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 3595
22d4bb9c
CB		 3596/* the . directory from @INC comes last */
3597
e0ef6b43 3598 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3599 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3600 p->next = head_PLOC;
3601 head_PLOC = p;
3602 strcpy(p->dir,"./");
3603
3604/* get the directory from $^X */
3605
c5375c28 3606 unixdir = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 3607 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 3608
218fdd94
CL		 3609#ifdef PERL_IMPLICIT_CONTEXT
3610 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3611#else
22d4bb9c 3612 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 3613#endif
a35dcc95 3614 my_strlcpy(temp, PL_origargv[0], sizeof(temp));
22d4bb9c 3615 x = strrchr(temp,']');
2497a41f
JM		 3616 if (x == NULL) {
3617 x = strrchr(temp,'>');
3618 if (x == NULL) {
3619 /* It could be a UNIX path */
3620 x = strrchr(temp,'/');
3621 }
3622 }
3623 if (x)
3624 x[1] = '\0';
3625 else {
3626 /* Got a bare name, so use default directory */
3627 temp[0] = '.';
3628 temp[1] = '\0';
3629 }
22d4bb9c 3630
4e205ed6 3631 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
e0ef6b43 3632 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3633 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3634 p->next = head_PLOC;
3635 head_PLOC = p;
a35dcc95 3636 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
c5375c28 3637 }
22d4bb9c
CB		 3638 }
3639
3640/* reverse order of @INC entries, skip "." since entered above */
3641
218fdd94
CL		 3642#ifdef PERL_IMPLICIT_CONTEXT
3643 if (aTHX)
3644#endif
ff7adb52
CL		 3645 if (PL_incgv) av = GvAVn(PL_incgv);
3646
3647 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB		 3648 dirsv = *av_fetch(av,i,TRUE);
3649
3650 if (SvROK(dirsv)) continue;
3651 dir = SvPVx(dirsv,n_a);
3652 if (strcmp(dir,".") == 0) continue;
4e205ed6 3653 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
22d4bb9c
CB		 3654 continue;
3655
e0ef6b43 3656 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 3657 p->next = head_PLOC;
3658 head_PLOC = p;
a35dcc95 3659 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
22d4bb9c
CB		 3660 }
3661
3662/* most likely spot (ARCHLIB) put first in the list */
3663
3664#ifdef ARCHLIB_EXP
4e205ed6 3665 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
e0ef6b43 3666 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3667 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3668 p->next = head_PLOC;
3669 head_PLOC = p;
a35dcc95 3670 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
22d4bb9c
CB		 3671 }
3672#endif
c5375c28 3673 PerlMem_free(unixdir);
22d4bb9c
CB		 3674}
3675
a1887106
JM		 3676static I32
3677Perl_cando_by_name_int
3678 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3679#if !defined(PERL_IMPLICIT_CONTEXT)
3680#define cando_by_name_int Perl_cando_by_name_int
3681#else
3682#define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3683#endif
22d4bb9c
CB		 3684
3685static char *
fd8cd3a3 3686find_vmspipe(pTHX)
22d4bb9c
CB		 3687{
3688 static int vmspipe_file_status = 0;
3689 static char vmspipe_file[NAM$C_MAXRSS+1];
3690
3691 /* already found? Check and use ... need read+execute permission */
3692
3693 if (vmspipe_file_status == 1) {
a1887106
JM		 3694 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3695 && cando_by_name_int
3696 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3697 return vmspipe_file;
3698 }
3699 vmspipe_file_status = 0;
3700 }
3701
3702 /* scan through stored @INC, $^X */
3703
3704 if (vmspipe_file_status == 0) {
3705 char file[NAM$C_MAXRSS+1];
3706 pPLOC p = head_PLOC;
3707
3708 while (p) {
2f4077ca 3709 char * exp_res;
4d743a9b 3710 int dirlen;
a35dcc95
CB		 3711 dirlen = my_strlcpy(file, p->dir, sizeof(file));
3712 my_strlcat(file, "vmspipe.com", sizeof(file));
22d4bb9c
CB		 3713 p = p->next;
3714
6fb6c614 3715 exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
2f4077ca 3716 if (!exp_res) continue;
22d4bb9c 3717
a1887106
JM		 3718 if (cando_by_name_int
3719 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3720 && cando_by_name_int
3721 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3722 vmspipe_file_status = 1;
3723 return vmspipe_file;
3724 }
3725 }
3726 vmspipe_file_status = -1; /* failed, use tempfiles */
3727 }
3728
3729 return 0;
3730}
3731
3732static FILE *
fd8cd3a3 3733vmspipe_tempfile(pTHX)
22d4bb9c
CB		 3734{
3735 char file[NAM$C_MAXRSS+1];
3736 FILE *fp;
3737 static int index = 0;
2497a41f
JM		 3738 Stat_t s0, s1;
3739 int cmp_result;
22d4bb9c
CB		 3740
3741 /* create a tempfile */
3742
3743 /* we can't go from W, shr=get to R, shr=get without
3744 an intermediate vulnerable state, so don't bother trying...
3745
3746 and lib$spawn doesn't shr=put, so have to close the write
3747
3748 So... match up the creation date/time and the FID to
3749 make sure we're dealing with the same file
3750
3751 */
3752
3753 index++;
2497a41f
JM		 3754 if (!decc_filename_unix_only) {
3755 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3756 fp = fopen(file,"w");
3757 if (!fp) {
22d4bb9c
CB		 3758 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3759 fp = fopen(file,"w");
3760 if (!fp) {
3761 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3762 fp = fopen(file,"w");
2497a41f
JM		 3763 }
3764 }
3765 }
3766 else {
3767 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3768 fp = fopen(file,"w");
3769 if (!fp) {
3770 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3771 fp = fopen(file,"w");
3772 if (!fp) {
3773 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3774 fp = fopen(file,"w");
3775 }
3776 }
22d4bb9c
CB		 3777 }
3778 if (!fp) return 0; /* we're hosed */
3779
f9ecfa39 3780 fprintf(fp,"$! 'f$verify(0)'\n");
22d4bb9c
CB		 3781 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3782 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3783 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3784 fprintf(fp,"$ perl_on = \"set noon\"\n");
3785 fprintf(fp,"$ perl_exit = \"exit\"\n");
3786 fprintf(fp,"$ perl_del = \"delete\"\n");
3787 fprintf(fp,"$ pif = \"if\"\n");
3788 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 3789 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3790 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 3791 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL		 3792 fprintf(fp,"$! --- build command line to get max possible length\n");
3793 fprintf(fp,"$c=perl_popen_cmd0\n");
3794 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3795 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3796 fprintf(fp,"$x=perl_popen_cmd3\n");
3797 fprintf(fp,"$c=c+x\n");
22d4bb9c 3798 fprintf(fp,"$ perl_on\n");
f9ecfa39 3799 fprintf(fp,"$ 'c'\n");
22d4bb9c 3800 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 3801 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 3802 fprintf(fp,"$ perl_exit 'perl_status'\n");
3803 fsync(fileno(fp));
3804
3805 fgetname(fp, file, 1);
312ac60b 3806 fstat(fileno(fp), &s0.crtl_stat);
22d4bb9c
CB		 3807 fclose(fp);
3808
2497a41f 3809 if (decc_filename_unix_only)
0e5ce2c7 3810 int_tounixspec(file, file, NULL);
22d4bb9c
CB		 3811 fp = fopen(file,"r","shr=get");
3812 if (!fp) return 0;
312ac60b 3813 fstat(fileno(fp), &s1.crtl_stat);
2497a41f 3814
682e4b71 3815 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
2497a41f 3816 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
22d4bb9c
CB		 3817 fclose(fp);
3818 return 0;
3819 }
3820
3821 return fp;
3822}
3823
3824
cd1191f1
CB		 3825static int vms_is_syscommand_xterm(void)
3826{
3827 const static struct dsc$descriptor_s syscommand_dsc =
3828 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3829
3830 const static struct dsc$descriptor_s decwdisplay_dsc =
3831 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3832
3833 struct item_list_3 items[2];
3834 unsigned short dvi_iosb[4];
3835 unsigned long devchar;
3836 unsigned long devclass;
3837 int status;
3838
3839 /* Very simple check to guess if sys$command is a decterm? */
3840 /* First see if the DECW$DISPLAY: device exists */
3841 items[0].len = 4;
3842 items[0].code = DVI$_DEVCHAR;
3843 items[0].bufadr = &devchar;
3844 items[0].retadr = NULL;
3845 items[1].len = 0;
3846 items[1].code = 0;
3847
3848 status = sys$getdviw
3849 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3850
3851 if ($VMS_STATUS_SUCCESS(status)) {
3852 status = dvi_iosb[0];
3853 }
3854
3855 if (!$VMS_STATUS_SUCCESS(status)) {
3856 SETERRNO(EVMSERR, status);
3857 return -1;
3858 }
3859
3860 /* If it does, then for now assume that we are on a workstation */
3861 /* Now verify that SYS$COMMAND is a terminal */
3862 /* for creating the debugger DECTerm */
3863
3864 items[0].len = 4;
3865 items[0].code = DVI$_DEVCLASS;
3866 items[0].bufadr = &devclass;
3867 items[0].retadr = NULL;
3868 items[1].len = 0;
3869 items[1].code = 0;
3870
3871 status = sys$getdviw
3872 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3873
3874 if ($VMS_STATUS_SUCCESS(status)) {
3875 status = dvi_iosb[0];
3876 }
3877
3878 if (!$VMS_STATUS_SUCCESS(status)) {
3879 SETERRNO(EVMSERR, status);
3880 return -1;
3881 }
3882 else {
3883 if (devclass == DC$_TERM) {
3884 return 0;
3885 }
3886 }
3887 return -1;
3888}
3889
3890/* If we are on a DECTerm, we can pretend to fork xterms when requested */
3891static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3892{
3893 int status;
3894 int ret_stat;
3895 char * ret_char;
3896 char device_name[65];
3897 unsigned short device_name_len;
3898 struct dsc$descriptor_s customization_dsc;
3899 struct dsc$descriptor_s device_name_dsc;
3900 const char * cptr;
cd1191f1
CB		 3901 char customization[200];
3902 char title[40];
3903 pInfo info = NULL;
3904 char mbx1[64];
3905 unsigned short p_chan;
3906 int n;
3907 unsigned short iosb[4];
cd1191f1
CB		 3908 const char * cust_str =
3909 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3910 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3911 DSC$K_CLASS_S, mbx1};
3912
8cb5d3d5
JM		 3913 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3914 /*---------------------------------------*/
d30c1055 3915 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
8cb5d3d5
JM		 3916
3917
3918 /* Make sure that this is from the Perl debugger */
cd1191f1
CB		 3919 ret_char = strstr(cmd," xterm ");
3920 if (ret_char == NULL)
3921 return NULL;
3922 cptr = ret_char + 7;
3923 ret_char = strstr(cmd,"tty");
3924 if (ret_char == NULL)
3925 return NULL;
3926 ret_char = strstr(cmd,"sleep");
3927 if (ret_char == NULL)
3928 return NULL;
3929
8cb5d3d5
JM		 3930 if (decw_term_port == 0) {
3931 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3932 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3933 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3934
d30c1055 3935 status = lib$find_image_symbol
8cb5d3d5
JM		 3936 (&filename1_dsc,
3937 &decw_term_port_dsc,
3938 (void *)&decw_term_port,
3939 NULL,
3940 0);
3941
3942 /* Try again with the other image name */
3943 if (!$VMS_STATUS_SUCCESS(status)) {
3944
d30c1055 3945 status = lib$find_ima