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