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