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