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