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