vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   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.
  12  */
  13
  14 /*
  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
  22  *
  23  *     [p.162 of _The Lays of Beleriand_]
  24  */
  25
  26 #include <acedef.h>
  27 #include <acldef.h>
  28 #include <armdef.h>
  29 #if __CRTL_VER < 70300000
  30 /* needed for home-rolled utime() */
  31 #include <atrdef.h>
  32 #include <fibdef.h>
  33 #endif
  34 #include <chpdef.h>
  35 #include <clidef.h>
  36 #include <climsgdef.h>
  37 #include <dcdef.h>
  38 #include <descrip.h>
  39 #include <devdef.h>
  40 #include <dvidef.h>
  41 #include <float.h>
  42 #include <fscndef.h>
  43 #include <iodef.h>
  44 #include <jpidef.h>
  45 #include <kgbdef.h>
  46 #include <libclidef.h>
  47 #include <libdef.h>
  48 #include <lib$routines.h>
  49 #include <lnmdef.h>
  50 #include <ossdef.h>
  51 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  52 #include <ppropdef.h>
  53 #endif
  54 #include <prvdef.h>
  55 #include <psldef.h>
  56 #include <rms.h>
  57 #include <shrdef.h>
  58 #include <ssdef.h>
  59 #include <starlet.h>
  60 #include <strdef.h>
  61 #include <str$routines.h>
  62 #include <syidef.h>
  63 #include <uaidef.h>
  64 #include <uicdef.h>
  65 #include <stsdef.h>
  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
  72
  73 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  74 int   decc$feature_get_index(const char *name);
  75 char* decc$feature_get_name(int index);
  76 int   decc$feature_get_value(int index, int mode);
  77 int   decc$feature_set_value(int index, int mode, int value);
  78 #else
  79 #include <unixlib.h>
  80 #endif
  81
  82 #pragma member_alignment save
  83 #pragma nomember_alignment longword
  84 struct 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
  92 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  93
  94 static 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
 111 return 0;
 112 }
 113 #endif
 114
 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
 120 #  define SS$_NOSUCHOBJECT 2696
 121 #endif
 122
 123 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 124 #define PERLIO_NOT_STDIO 0
 125
 126 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 127  * code below needs to get to the underlying CRTL routines. */
 128 #define DONT_MASK_RTL_CALLS
 129 #include "EXTERN.h"
 130 #include "perl.h"
 131 #include "XSUB.h"
 132 /* Anticipating future expansion in lexical warnings . . . */
 133 #ifndef WARN_INTERNAL
 134 #  define WARN_INTERNAL WARN_MISC
 135 #endif
 136
 137 #ifdef VMS_LONGNAME_SUPPORT
 138 #include <libfildef.h>
 139 #endif
 140
 141 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 142 #  define RTL_USES_UTC 1
 143 #endif
 144
 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
 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
 159 static int (*decw_term_port)
 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,
 167     void * char_change_buffer) = 0;
 168
 169 /* gcc's header files don't #define direct access macros
 170  * corresponding to VAXC's variant structs */
 171 #ifdef __GNUC__
 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
 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
 181 #if defined(NEED_AN_H_ERRNO)
 182 dEXT int h_errno;
 183 #endif
 184
 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
 192 struct itmlst_3 {
 193   unsigned short int buflen;
 194   unsigned short int itmcode;
 195   void *bufadr;
 196   unsigned short int *retlen;
 197 };
 198
 199 struct filescan_itmlst_2 {
 200     unsigned short length;
 201     unsigned short itmcode;
 202     char * component;
 203 };
 204
 205 struct vs_str_st {
 206     unsigned short length;
 207     char str[65536];
 208 };
 209
 210 #ifdef __DECC
 211 #pragma message restore
 212 #pragma member_alignment restore
 213 #endif
 214
 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)
 221 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 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)
 224 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 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
 228 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 229 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 230 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 231 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 232
 233 static char *  int_rmsexpand_vms(
 234     const char * filespec, char * outbuf, unsigned opts);
 235 static char * int_rmsexpand_tovms(
 236     const char * filespec, char * outbuf, unsigned opts);
 237 static char *int_tovmsspec
 238    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 239 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 240 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 241 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 242
 243 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 244 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 245
 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
 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
 260
 261 static char *__mystrtolower(char *str)
 262 {
 263   if (str) for (; *str; ++str) *str= tolower(*str);
 264   return str;
 265 }
 266
 267 static struct dsc$descriptor_s fildevdsc =
 268   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 269 static struct dsc$descriptor_s crtlenvdsc =
 270   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 271 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 272 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 273 static struct dsc$descriptor_s **env_tables = defenv;
 274 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 275
 276 /* True if we shouldn't treat barewords as logicals during directory */
 277 /* munching */
 278 static int no_translate_barewords;
 279
 280 #ifndef RTL_USES_UTC
 281 static int tz_updated = 1;
 282 #endif
 283
 284 /* DECC Features that may need to affect how Perl interprets
 285  * displays filename information
 286  */
 287 static int decc_disable_to_vms_logname_translation = 1;
 288 static int decc_disable_posix_root = 1;
 289 int decc_efs_case_preserve = 0;
 290 static int decc_efs_charset = 0;
 291 static int decc_efs_charset_index = -1;
 292 static int decc_filename_unix_no_version = 0;
 293 static int decc_filename_unix_only = 0;
 294 int decc_filename_unix_report = 0;
 295 int decc_posix_compliant_pathnames = 0;
 296 int decc_readdir_dropdotnotype = 0;
 297 static int vms_process_case_tolerant = 1;
 298 int vms_vtf7_filenames = 0;
 299 int gnv_unix_shell = 0;
 300 static int vms_unlink_all_versions = 0;
 301 static int vms_posix_exit = 0;
 302
 303 /* bug workarounds if needed */
 304 int decc_bug_devnull = 1;
 305 int decc_dir_barename = 0;
 306 int vms_bug_stat_filename = 0;
 307
 308 static int vms_debug_on_exception = 0;
 309 static int vms_debug_fileify = 0;
 310
 311 /* Simple logical name translation */
 312 static 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
 343
 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
 352 static int is_unix_filespec(const char *path)
 353 {
 354 int ret_val;
 355 const 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
 374 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 375  */
 376
 377 static void ucs2_to_vtf7
 378    (char *outspec,
 379     unsigned long ucs2_char,
 380     int * output_cnt)
 381 {
 382 unsigned char * ucs_ptr;
 383 int 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  */
 424 static int copy_expand_unix_filename_escape
 425   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 426 {
 427 int count;
 428 int utf8_flag;
 429
 430     utf8_flag = 0;
 431     if (utf8_fl)
 432       utf8_flag = *utf8_fl;
 433
 434     count = 0;
 435     *output_cnt = 0;
 436     if (*inspec >= 0x80) {
 437         if (utf8_fl && vms_vtf7_filenames) {
 438         unsigned long ucs_char;
 439
 440             ucs_char = 0;
 441
 442             if ((*inspec & 0xE0) == 0xC0) {
 443                 /* 2 byte Unicode */
 444                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 445                 if (ucs_char >= 0x80) {
 446                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 447                     return 2;
 448                 }
 449             } else if ((*inspec & 0xF0) == 0xE0) {
 450                 /* 3 byte Unicode */
 451                 ucs_char = ((inspec[0] & 0xF) << 12) +
 452                    ((inspec[1] & 0x3f) << 6) +
 453                    (inspec[2] & 0x3f);
 454                 if (ucs_char >= 0x800) {
 455                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 456                     return 3;
 457                 }
 458
 459 #if 0 /* I do not see longer sequences supported by OpenVMS */
 460       /* Maybe some one can fix this later */
 461             } else if ((*inspec & 0xF8) == 0xF0) {
 462                 /* 4 byte Unicode */
 463                 /* UCS-4 to UCS-2 */
 464             } else if ((*inspec & 0xFC) == 0xF8) {
 465                 /* 5 byte Unicode */
 466                 /* UCS-4 to UCS-2 */
 467             } else if ((*inspec & 0xFE) == 0xFC) {
 468                 /* 6 byte Unicode */
 469                 /* UCS-4 to UCS-2 */
 470 #endif
 471             }
 472         }
 473
 474         /* High bit set, but not a Unicode character! */
 475
 476         /* Non printing DECMCS or ISO Latin-1 character? */
 477         if ((unsigned char)*inspec <= 0x9F) {
 478             int hex;
 479             outspec[0] = '^';
 480             outspec++;
 481             hex = (*inspec >> 4) & 0xF;
 482             if (hex < 0xA)
 483                 outspec[1] = hex + '0';
 484             else {
 485                 outspec[1] = (hex - 9) + 'A';
 486             }
 487             hex = *inspec & 0xF;
 488             if (hex < 0xA)
 489                 outspec[2] = hex + '0';
 490             else {
 491                 outspec[2] = (hex - 9) + 'A';
 492             }
 493             *output_cnt = 3;
 494             return 1;
 495         } else if ((unsigned char)*inspec == 0xA0) {
 496             outspec[0] = '^';
 497             outspec[1] = 'A';
 498             outspec[2] = '0';
 499             *output_cnt = 3;
 500             return 1;
 501         } else if ((unsigned char)*inspec == 0xFF) {
 502             outspec[0] = '^';
 503             outspec[1] = 'F';
 504             outspec[2] = 'F';
 505             *output_cnt = 3;
 506             return 1;
 507         }
 508         *outspec = *inspec;
 509         *output_cnt = 1;
 510         return 1;
 511     }
 512
 513     /* Is this a macro that needs to be passed through?
 514      * Macros start with $( and an alpha character, followed
 515      * by a string of alpha numeric characters ending with a )
 516      * If this does not match, then encode it as ODS-5.
 517      */
 518     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 519     int tcnt;
 520
 521         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 522             tcnt = 3;
 523             outspec[0] = inspec[0];
 524             outspec[1] = inspec[1];
 525             outspec[2] = inspec[2];
 526
 527             while(isalnum(inspec[tcnt]) ||
 528                   (inspec[2] == '.') || (inspec[2] == '_')) {
 529                 outspec[tcnt] = inspec[tcnt];
 530                 tcnt++;
 531             }
 532             if (inspec[tcnt] == ')') {
 533                 outspec[tcnt] = inspec[tcnt];
 534                 tcnt++;
 535                 *output_cnt = tcnt;
 536                 return tcnt;
 537             }
 538         }
 539     }
 540
 541     switch (*inspec) {
 542     case 0x7f:
 543         outspec[0] = '^';
 544         outspec[1] = '7';
 545         outspec[2] = 'F';
 546         *output_cnt = 3;
 547         return 1;
 548         break;
 549     case '?':
 550         if (decc_efs_charset == 0)
 551           outspec[0] = '%';
 552         else
 553           outspec[0] = '?';
 554         *output_cnt = 1;
 555         return 1;
 556         break;
 557     case '.':
 558     case '~':
 559     case '!':
 560     case '#':
 561     case '&':
 562     case '\'':
 563     case '`':
 564     case '(':
 565     case ')':
 566     case '+':
 567     case '@':
 568     case '{':
 569     case '}':
 570     case ',':
 571     case ';':
 572     case '[':
 573     case ']':
 574     case '%':
 575     case '^':
 576     case '\\':
 577         /* Don't escape again if following character is
 578          * already something we escape.
 579          */
 580         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 581             *outspec = *inspec;
 582             *output_cnt = 1;
 583             return 1;
 584             break;
 585         }
 586         /* But otherwise fall through and escape it. */
 587     case '=':
 588         /* Assume that this is to be escaped */
 589         outspec[0] = '^';
 590         outspec[1] = *inspec;
 591         *output_cnt = 2;
 592         return 1;
 593         break;
 594     case ' ': /* space */
 595         /* Assume that this is to be escaped */
 596         outspec[0] = '^';
 597         outspec[1] = '_';
 598         *output_cnt = 2;
 599         return 1;
 600         break;
 601     default:
 602         *outspec = *inspec;
 603         *output_cnt = 1;
 604         return 1;
 605         break;
 606     }
 607 }
 608
 609
 610 /* This handles the expansion of a '^' prefix to the proper character
 611  * in a UNIX file specification.
 612  *
 613  * The output count variable contains the number of characters added
 614  * to the output string.
 615  *
 616  * The return value is the number of characters read from the input
 617  * string
 618  */
 619 static int copy_expand_vms_filename_escape
 620   (char *outspec, const char *inspec, int *output_cnt)
 621 {
 622 int count;
 623 int scnt;
 624
 625     count = 0;
 626     *output_cnt = 0;
 627     if (*inspec == '^') {
 628         inspec++;
 629         switch (*inspec) {
 630         /* Spaces and non-trailing dots should just be passed through,
 631          * but eat the escape character.
 632          */
 633         case '.':
 634             *outspec = *inspec;
 635             count += 2;
 636             (*output_cnt)++;
 637             break;
 638         case '_': /* space */
 639             *outspec = ' ';
 640             count += 2;
 641             (*output_cnt)++;
 642             break;
 643         case '^':
 644             /* Hmm.  Better leave the escape escaped. */
 645             outspec[0] = '^';
 646             outspec[1] = '^';
 647             count += 2;
 648             (*output_cnt) += 2;
 649             break;
 650         case 'U': /* Unicode - FIX-ME this is wrong. */
 651             inspec++;
 652             count++;
 653             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 654             if (scnt == 4) {
 655                 unsigned int c1, c2;
 656                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 657                 outspec[0] = c1 & 0xff;
 658                 outspec[1] = c2 & 0xff;
 659                 if (scnt > 1) {
 660                     (*output_cnt) += 2;
 661                     count += 4;
 662                 }
 663             }
 664             else {
 665                 /* Error - do best we can to continue */
 666                 *outspec = 'U';
 667                 outspec++;
 668                 (*output_cnt++);
 669                 *outspec = *inspec;
 670                 count++;
 671                 (*output_cnt++);
 672             }
 673             break;
 674         default:
 675             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 676             if (scnt == 2) {
 677                 /* Hex encoded */
 678                 unsigned int c1;
 679                 scnt = sscanf(inspec, "%2x", &c1);
 680                 outspec[0] = c1 & 0xff;
 681                 if (scnt > 0) {
 682                     (*output_cnt++);
 683                     count += 2;
 684                 }
 685             }
 686             else {
 687                 *outspec = *inspec;
 688                 count++;
 689                 (*output_cnt++);
 690             }
 691         }
 692     }
 693     else {
 694         *outspec = *inspec;
 695         count++;
 696         (*output_cnt)++;
 697     }
 698     return count;
 699 }
 700
 701 /* vms_split_path - Verify that the input file specification is a
 702  * VMS format file specification, and provide pointers to the components of
 703  * it.  With EFS format filenames, this is virtually the only way to
 704  * parse a VMS path specification into components.
 705  *
 706  * If the sum of the components do not add up to the length of the
 707  * string, then the passed file specification is probably a UNIX style
 708  * path.
 709  */
 710 static int vms_split_path
 711    (const char * path,
 712     char * * volume,
 713     int * vol_len,
 714     char * * root,
 715     int * root_len,
 716     char * * dir,
 717     int * dir_len,
 718     char * * name,
 719     int * name_len,
 720     char * * ext,
 721     int * ext_len,
 722     char * * version,
 723     int * ver_len)
 724 {
 725 struct dsc$descriptor path_desc;
 726 int status;
 727 unsigned long flags;
 728 int ret_stat;
 729 struct filescan_itmlst_2 item_list[9];
 730 const int filespec = 0;
 731 const int nodespec = 1;
 732 const int devspec = 2;
 733 const int rootspec = 3;
 734 const int dirspec = 4;
 735 const int namespec = 5;
 736 const int typespec = 6;
 737 const int verspec = 7;
 738
 739     /* Assume the worst for an easy exit */
 740     ret_stat = -1;
 741     *volume = NULL;
 742     *vol_len = 0;
 743     *root = NULL;
 744     *root_len = 0;
 745     *dir = NULL;
 746     *name = NULL;
 747     *name_len = 0;
 748     *ext = NULL;
 749     *ext_len = 0;
 750     *version = NULL;
 751     *ver_len = 0;
 752
 753     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 754     path_desc.dsc$w_length = strlen(path);
 755     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 756     path_desc.dsc$b_class = DSC$K_CLASS_S;
 757
 758     /* Get the total length, if it is shorter than the string passed
 759      * then this was probably not a VMS formatted file specification
 760      */
 761     item_list[filespec].itmcode = FSCN$_FILESPEC;
 762     item_list[filespec].length = 0;
 763     item_list[filespec].component = NULL;
 764
 765     /* If the node is present, then it gets considered as part of the
 766      * volume name to hopefully make things simple.
 767      */
 768     item_list[nodespec].itmcode = FSCN$_NODE;
 769     item_list[nodespec].length = 0;
 770     item_list[nodespec].component = NULL;
 771
 772     item_list[devspec].itmcode = FSCN$_DEVICE;
 773     item_list[devspec].length = 0;
 774     item_list[devspec].component = NULL;
 775
 776     /* root is a special case,  adding it to either the directory or
 777      * the device components will probably complicate things for the
 778      * callers of this routine, so leave it separate.
 779      */
 780     item_list[rootspec].itmcode = FSCN$_ROOT;
 781     item_list[rootspec].length = 0;
 782     item_list[rootspec].component = NULL;
 783
 784     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 785     item_list[dirspec].length = 0;
 786     item_list[dirspec].component = NULL;
 787
 788     item_list[namespec].itmcode = FSCN$_NAME;
 789     item_list[namespec].length = 0;
 790     item_list[namespec].component = NULL;
 791
 792     item_list[typespec].itmcode = FSCN$_TYPE;
 793     item_list[typespec].length = 0;
 794     item_list[typespec].component = NULL;
 795
 796     item_list[verspec].itmcode = FSCN$_VERSION;
 797     item_list[verspec].length = 0;
 798     item_list[verspec].component = NULL;
 799
 800     item_list[8].itmcode = 0;
 801     item_list[8].length = 0;
 802     item_list[8].component = NULL;
 803
 804     status = sys$filescan
 805        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 806         &flags, NULL, NULL);
 807     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 808
 809     /* If we parsed it successfully these two lengths should be the same */
 810     if (path_desc.dsc$w_length != item_list[filespec].length)
 811         return ret_stat;
 812
 813     /* If we got here, then it is a VMS file specification */
 814     ret_stat = 0;
 815
 816     /* set the volume name */
 817     if (item_list[nodespec].length > 0) {
 818         *volume = item_list[nodespec].component;
 819         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 820     }
 821     else {
 822         *volume = item_list[devspec].component;
 823         *vol_len = item_list[devspec].length;
 824     }
 825
 826     *root = item_list[rootspec].component;
 827     *root_len = item_list[rootspec].length;
 828
 829     *dir = item_list[dirspec].component;
 830     *dir_len = item_list[dirspec].length;
 831
 832     /* Now fun with versions and EFS file specifications
 833      * The parser can not tell the difference when a "." is a version
 834      * delimiter or a part of the file specification.
 835      */
 836     if ((decc_efs_charset) &&
 837         (item_list[verspec].length > 0) &&
 838         (item_list[verspec].component[0] == '.')) {
 839         *name = item_list[namespec].component;
 840         *name_len = item_list[namespec].length + item_list[typespec].length;
 841         *ext = item_list[verspec].component;
 842         *ext_len = item_list[verspec].length;
 843         *version = NULL;
 844         *ver_len = 0;
 845     }
 846     else {
 847         *name = item_list[namespec].component;
 848         *name_len = item_list[namespec].length;
 849         *ext = item_list[typespec].component;
 850         *ext_len = item_list[typespec].length;
 851         *version = item_list[verspec].component;
 852         *ver_len = item_list[verspec].length;
 853     }
 854     return ret_stat;
 855 }
 856
 857 /* Routine to determine if the file specification ends with .dir */
 858 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 859
 860     /* e_len must be 4, and version must be <= 2 characters */
 861     if (e_len != 4 || vs_len > 2)
 862         return 0;
 863
 864     /* If a version number is present, it needs to be one */
 865     if ((vs_len == 2) && (vs_spec[1] != '1'))
 866         return 0;
 867
 868     /* Look for the DIR on the extension */
 869     if (vms_process_case_tolerant) {
 870         if ((toupper(e_spec[1]) == 'D') &&
 871             (toupper(e_spec[2]) == 'I') &&
 872             (toupper(e_spec[3]) == 'R')) {
 873             return 1;
 874         }
 875     } else {
 876         /* Directory extensions are supposed to be in upper case only */
 877         /* I would not be surprised if this rule can not be enforced */
 878         /* if and when someone fully debugs the case sensitive mode */
 879         if ((e_spec[1] == 'D') &&
 880             (e_spec[2] == 'I') &&
 881             (e_spec[3] == 'R')) {
 882             return 1;
 883         }
 884     }
 885     return 0;
 886 }
 887
 888
 889 /* my_maxidx
 890  * Routine to retrieve the maximum equivalence index for an input
 891  * logical name.  Some calls to this routine have no knowledge if
 892  * the variable is a logical or not.  So on error we return a max
 893  * index of zero.
 894  */
 895 /*{{{int my_maxidx(const char *lnm) */
 896 static int
 897 my_maxidx(const char *lnm)
 898 {
 899     int status;
 900     int midx;
 901     int attr = LNM$M_CASE_BLIND;
 902     struct dsc$descriptor lnmdsc;
 903     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 904                                 {0, 0, 0, 0}};
 905
 906     lnmdsc.dsc$w_length = strlen(lnm);
 907     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 908     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 909     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 910
 911     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 912     if ((status & 1) == 0)
 913        midx = 0;
 914
 915     return (midx);
 916 }
 917 /*}}}*/
 918
 919 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 920 int
 921 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 922   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 923 {
 924     const char *cp1;
 925     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 926     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 927     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 928     int midx;
 929     unsigned char acmode;
 930     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 931                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 932     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 933                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 934                                  {0, 0, 0, 0}};
 935     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 936 #if defined(PERL_IMPLICIT_CONTEXT)
 937     pTHX = NULL;
 938     if (PL_curinterp) {
 939       aTHX = PERL_GET_INTERP;
 940     } else {
 941       aTHX = NULL;
 942     }
 943 #endif
 944
 945     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 946       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 947     }
 948     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 949       *cp2 = _toupper(*cp1);
 950       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 951         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 952         return 0;
 953       }
 954     }
 955     lnmdsc.dsc$w_length = cp1 - lnm;
 956     lnmdsc.dsc$a_pointer = uplnm;
 957     uplnm[lnmdsc.dsc$w_length] = '\0';
 958     secure = flags & PERL__TRNENV_SECURE;
 959     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 960     if (!tabvec || !*tabvec) tabvec = env_tables;
 961
 962     for (curtab = 0; tabvec[curtab]; curtab++) {
 963       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 964         if (!ivenv && !secure) {
 965           char *eq;
 966           int i;
 967           if (!environ) {
 968             ivenv = 1;
 969 #if defined(PERL_IMPLICIT_CONTEXT)
 970             if (aTHX == NULL) {
 971                 fprintf(stderr,
 972                     "Can't read CRTL environ\n");
 973             } else
 974 #endif
 975                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 976             continue;
 977           }
 978           retsts = SS$_NOLOGNAM;
 979           for (i = 0; environ[i]; i++) {
 980             if ((eq = strchr(environ[i],'=')) &&
 981                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 982                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 983               eq++;
 984               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 985               if (!eqvlen) continue;
 986               retsts = SS$_NORMAL;
 987               break;
 988             }
 989           }
 990           if (retsts != SS$_NOLOGNAM) break;
 991         }
 992       }
 993       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 994                !str$case_blind_compare(&tmpdsc,&clisym)) {
 995         if (!ivsym && !secure) {
 996           unsigned short int deflen = LNM$C_NAMLENGTH;
 997           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 998           /* dynamic dsc to accommodate possible long value */
 999           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
1000           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1001           if (retsts & 1) {
1002             if (eqvlen > MAX_DCL_SYMBOL) {
1003               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1004               eqvlen = MAX_DCL_SYMBOL;
1005               /* Special hack--we might be called before the interpreter's */
1006               /* fully initialized, in which case either thr or PL_curcop */
1007               /* might be bogus. We have to check, since ckWARN needs them */
1008               /* both to be valid if running threaded */
1009 #if defined(PERL_IMPLICIT_CONTEXT)
1010               if (aTHX == NULL) {
1011                   fprintf(stderr,
1012                      "Value of CLI symbol \"%s\" too long",lnm);
1013               } else
1014 #endif
1015                 if (ckWARN(WARN_MISC)) {
1016                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1017                 }
1018             }
1019             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1020           }
1021           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1022           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1023           if (retsts == LIB$_NOSUCHSYM) continue;
1024           break;
1025         }
1026       }
1027       else if (!ivlnm) {
1028         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1029           midx = my_maxidx(lnm);
1030           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1031             lnmlst[1].bufadr = cp2;
1032             eqvlen = 0;
1033             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1034             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1035             if (retsts == SS$_NOLOGNAM) break;
1036             /* PPFs have a prefix */
1037             if (
1038 #if INTSIZE == 4
1039                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1040 #endif
1041                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1042                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1043                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1044                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1045                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1046               memmove(eqv,eqv+4,eqvlen-4);
1047               eqvlen -= 4;
1048             }
1049             cp2 += eqvlen;
1050             *cp2 = '\0';
1051           }
1052           if ((retsts == SS$_IVLOGNAM) ||
1053               (retsts == SS$_NOLOGNAM)) { continue; }
1054         }
1055         else {
1056           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1057           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1058           if (retsts == SS$_NOLOGNAM) continue;
1059           eqv[eqvlen] = '\0';
1060         }
1061         eqvlen = strlen(eqv);
1062         break;
1063       }
1064     }
1065     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1066     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1067              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1068              retsts == SS$_NOLOGNAM) {
1069       set_errno(EINVAL);  set_vaxc_errno(retsts);
1070     }
1071     else _ckvmssts_noperl(retsts);
1072     return 0;
1073 }  /* end of vmstrnenv */
1074 /*}}}*/
1075
1076 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1077 /* Define as a function so we can access statics. */
1078 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1079 {
1080     int flags = 0;
1081
1082 #if defined(PERL_IMPLICIT_CONTEXT)
1083     if (aTHX != NULL)
1084 #endif
1085 #ifdef SECURE_INTERNAL_GETENV
1086         flags = (PL_curinterp ? PL_tainting : will_taint) ?
1087                  PERL__TRNENV_SECURE : 0;
1088 #endif
1089
1090     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1091 }
1092 /*}}}*/
1093
1094 /* my_getenv
1095  * Note: Uses Perl temp to store result so char * can be returned to
1096  * caller; this pointer will be invalidated at next Perl statement
1097  * transition.
1098  * We define this as a function rather than a macro in terms of my_getenv_len()
1099  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1100  * allocate SVs).
1101  */
1102 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1103 char *
1104 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1105 {
1106     const char *cp1;
1107     static char *__my_getenv_eqv = NULL;
1108     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1109     unsigned long int idx = 0;
1110     int success, secure, saverr, savvmserr;
1111     int midx, flags;
1112     SV *tmpsv;
1113
1114     midx = my_maxidx(lnm) + 1;
1115
1116     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1117       /* Set up a temporary buffer for the return value; Perl will
1118        * clean it up at the next statement transition */
1119       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1120       if (!tmpsv) return NULL;
1121       eqv = SvPVX(tmpsv);
1122     }
1123     else {
1124       /* Assume no interpreter ==> single thread */
1125       if (__my_getenv_eqv != NULL) {
1126         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1127       }
1128       else {
1129         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1130       }
1131       eqv = __my_getenv_eqv;
1132     }
1133
1134     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1135     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1136       int len;
1137       getcwd(eqv,LNM$C_NAMLENGTH);
1138
1139       len = strlen(eqv);
1140
1141       /* Get rid of "000000/ in rooted filespecs */
1142       if (len > 7) {
1143         char * zeros;
1144         zeros = strstr(eqv, "/000000/");
1145         if (zeros != NULL) {
1146           int mlen;
1147           mlen = len - (zeros - eqv) - 7;
1148           memmove(zeros, &zeros[7], mlen);
1149           len = len - 7;
1150           eqv[len] = '\0';
1151         }
1152       }
1153       return eqv;
1154     }
1155     else {
1156       /* Impose security constraints only if tainting */
1157       if (sys) {
1158         /* Impose security constraints only if tainting */
1159         secure = PL_curinterp ? PL_tainting : will_taint;
1160         saverr = errno;  savvmserr = vaxc$errno;
1161       }
1162       else {
1163         secure = 0;
1164       }
1165
1166       flags =
1167 #ifdef SECURE_INTERNAL_GETENV
1168               secure ? PERL__TRNENV_SECURE : 0
1169 #else
1170               0
1171 #endif
1172       ;
1173
1174       /* For the getenv interface we combine all the equivalence names
1175        * of a search list logical into one value to acquire a maximum
1176        * value length of 255*128 (assuming %ENV is using logicals).
1177        */
1178       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1179
1180       /* If the name contains a semicolon-delimited index, parse it
1181        * off and make sure we only retrieve the equivalence name for
1182        * that index.  */
1183       if ((cp2 = strchr(lnm,';')) != NULL) {
1184         strcpy(uplnm,lnm);
1185         uplnm[cp2-lnm] = '\0';
1186         idx = strtoul(cp2+1,NULL,0);
1187         lnm = uplnm;
1188         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1189       }
1190
1191       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1192
1193       /* Discard NOLOGNAM on internal calls since we're often looking
1194        * for an optional name, and this "error" often shows up as the
1195        * (bogus) exit status for a die() call later on.  */
1196       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1197       return success ? eqv : NULL;
1198     }
1199
1200 }  /* end of my_getenv() */
1201 /*}}}*/
1202
1203
1204 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1205 char *
1206 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1207 {
1208     const char *cp1;
1209     char *buf, *cp2;
1210     unsigned long idx = 0;
1211     int midx, flags;
1212     static char *__my_getenv_len_eqv = NULL;
1213     int secure, saverr, savvmserr;
1214     SV *tmpsv;
1215
1216     midx = my_maxidx(lnm) + 1;
1217
1218     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1219       /* Set up a temporary buffer for the return value; Perl will
1220        * clean it up at the next statement transition */
1221       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1222       if (!tmpsv) return NULL;
1223       buf = SvPVX(tmpsv);
1224     }
1225     else {
1226       /* Assume no interpreter ==> single thread */
1227       if (__my_getenv_len_eqv != NULL) {
1228         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1229       }
1230       else {
1231         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1232       }
1233       buf = __my_getenv_len_eqv;
1234     }
1235
1236     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1237     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1238     char * zeros;
1239
1240       getcwd(buf,LNM$C_NAMLENGTH);
1241       *len = strlen(buf);
1242
1243       /* Get rid of "000000/ in rooted filespecs */
1244       if (*len > 7) {
1245       zeros = strstr(buf, "/000000/");
1246       if (zeros != NULL) {
1247         int mlen;
1248         mlen = *len - (zeros - buf) - 7;
1249         memmove(zeros, &zeros[7], mlen);
1250         *len = *len - 7;
1251         buf[*len] = '\0';
1252         }
1253       }
1254       return buf;
1255     }
1256     else {
1257       if (sys) {
1258         /* Impose security constraints only if tainting */
1259         secure = PL_curinterp ? PL_tainting : will_taint;
1260         saverr = errno;  savvmserr = vaxc$errno;
1261       }
1262       else {
1263         secure = 0;
1264       }
1265
1266       flags =
1267 #ifdef SECURE_INTERNAL_GETENV
1268               secure ? PERL__TRNENV_SECURE : 0
1269 #else
1270               0
1271 #endif
1272       ;
1273
1274       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1275
1276       if ((cp2 = strchr(lnm,';')) != NULL) {
1277         strcpy(buf,lnm);
1278         buf[cp2-lnm] = '\0';
1279         idx = strtoul(cp2+1,NULL,0);
1280         lnm = buf;
1281         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1282       }
1283
1284       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1285
1286       /* Get rid of "000000/ in rooted filespecs */
1287       if (*len > 7) {
1288       char * zeros;
1289         zeros = strstr(buf, "/000000/");
1290         if (zeros != NULL) {
1291           int mlen;
1292           mlen = *len - (zeros - buf) - 7;
1293           memmove(zeros, &zeros[7], mlen);
1294           *len = *len - 7;
1295           buf[*len] = '\0';
1296         }
1297       }
1298
1299       /* Discard NOLOGNAM on internal calls since we're often looking
1300        * for an optional name, and this "error" often shows up as the
1301        * (bogus) exit status for a die() call later on.  */
1302       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1303       return *len ? buf : NULL;
1304     }
1305
1306 }  /* end of my_getenv_len() */
1307 /*}}}*/
1308
1309 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1310
1311 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1312
1313 /*{{{ void prime_env_iter() */
1314 void
1315 prime_env_iter(void)
1316 /* Fill the %ENV associative array with all logical names we can
1317  * find, in preparation for iterating over it.
1318  */
1319 {
1320   static int primed = 0;
1321   HV *seenhv = NULL, *envhv;
1322   SV *sv = NULL;
1323   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1324   unsigned short int chan;
1325 #ifndef CLI$M_TRUSTED
1326 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1327 #endif
1328   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1329   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1330   long int i;
1331   bool have_sym = FALSE, have_lnm = FALSE;
1332   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1333   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1334   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1335   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1336   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1337 #if defined(PERL_IMPLICIT_CONTEXT)
1338   pTHX;
1339 #endif
1340 #if defined(USE_ITHREADS)
1341   static perl_mutex primenv_mutex;
1342   MUTEX_INIT(&primenv_mutex);
1343 #endif
1344
1345 #if defined(PERL_IMPLICIT_CONTEXT)
1346     /* We jump through these hoops because we can be called at */
1347     /* platform-specific initialization time, which is before anything is */
1348     /* set up--we can't even do a plain dTHX since that relies on the */
1349     /* interpreter structure to be initialized */
1350     if (PL_curinterp) {
1351       aTHX = PERL_GET_INTERP;
1352     } else {
1353       /* we never get here because the NULL pointer will cause the */
1354       /* several of the routines called by this routine to access violate */
1355
1356       /* This routine is only called by hv.c/hv_iterinit which has a */
1357       /* context, so the real fix may be to pass it through instead of */
1358       /* the hoops above */
1359       aTHX = NULL;
1360     }
1361 #endif
1362
1363   if (primed || !PL_envgv) return;
1364   MUTEX_LOCK(&primenv_mutex);
1365   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1366   envhv = GvHVn(PL_envgv);
1367   /* Perform a dummy fetch as an lval to insure that the hash table is
1368    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1369   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1370
1371   for (i = 0; env_tables[i]; i++) {
1372      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1373          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1374      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1375   }
1376   if (have_sym || have_lnm) {
1377     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1378     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1379     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1380     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1381   }
1382
1383   for (i--; i >= 0; i--) {
1384     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1385       char *start;
1386       int j;
1387       for (j = 0; environ[j]; j++) {
1388         if (!(start = strchr(environ[j],'='))) {
1389           if (ckWARN(WARN_INTERNAL))
1390             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1391         }
1392         else {
1393           start++;
1394           sv = newSVpv(start,0);
1395           SvTAINTED_on(sv);
1396           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1397         }
1398       }
1399       continue;
1400     }
1401     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1402              !str$case_blind_compare(&tmpdsc,&clisym)) {
1403       strcpy(cmd,"Show Symbol/Global *");
1404       cmddsc.dsc$w_length = 20;
1405       if (env_tables[i]->dsc$w_length == 12 &&
1406           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1407           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1408       flags = defflags | CLI$M_NOLOGNAM;
1409     }
1410     else {
1411       strcpy(cmd,"Show Logical *");
1412       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1413         strcat(cmd," /Table=");
1414         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1415         cmddsc.dsc$w_length = strlen(cmd);
1416       }
1417       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1418       flags = defflags | CLI$M_NOCLISYM;
1419     }
1420
1421     /* Create a new subprocess to execute each command, to exclude the
1422      * remote possibility that someone could subvert a mbx or file used
1423      * to write multiple commands to a single subprocess.
1424      */
1425     do {
1426       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1427                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1428       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1429       defflags &= ~CLI$M_TRUSTED;
1430     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1431     _ckvmssts(retsts);
1432     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1433     if (seenhv) SvREFCNT_dec(seenhv);
1434     seenhv = newHV();
1435     while (1) {
1436       char *cp1, *cp2, *key;
1437       unsigned long int sts, iosb[2], retlen, keylen;
1438       register U32 hash;
1439
1440       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1441       if (sts & 1) sts = iosb[0] & 0xffff;
1442       if (sts == SS$_ENDOFFILE) {
1443         int wakect = 0;
1444         while (substs == 0) { sys$hiber(); wakect++;}
1445         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1446         _ckvmssts(substs);
1447         break;
1448       }
1449       _ckvmssts(sts);
1450       retlen = iosb[0] >> 16;
1451       if (!retlen) continue;  /* blank line */
1452       buf[retlen] = '\0';
1453       if (iosb[1] != subpid) {
1454         if (iosb[1]) {
1455           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1456         }
1457         continue;
1458       }
1459       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1460         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1461
1462       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1463       if (*cp1 == '(' || /* Logical name table name */
1464           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1465       if (*cp1 == '"') cp1++;
1466       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1467       key = cp1;  keylen = cp2 - cp1;
1468       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1469       while (*cp2 && *cp2 != '=') cp2++;
1470       while (*cp2 && *cp2 == '=') cp2++;
1471       while (*cp2 && *cp2 == ' ') cp2++;
1472       if (*cp2 == '"') {  /* String translation; may embed "" */
1473         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1474         cp2++;  cp1--; /* Skip "" surrounding translation */
1475       }
1476       else {  /* Numeric translation */
1477         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1478         cp1--;  /* stop on last non-space char */
1479       }
1480       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1481         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1482         continue;
1483       }
1484       PERL_HASH(hash,key,keylen);
1485
1486       if (cp1 == cp2 && *cp2 == '.') {
1487         /* A single dot usually means an unprintable character, such as a null
1488          * to indicate a zero-length value.  Get the actual value to make sure.
1489          */
1490         char lnm[LNM$C_NAMLENGTH+1];
1491         char eqv[MAX_DCL_SYMBOL+1];
1492         int trnlen;
1493         strncpy(lnm, key, keylen);
1494         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1495         sv = newSVpvn(eqv, strlen(eqv));
1496       }
1497       else {
1498         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1499       }
1500
1501       SvTAINTED_on(sv);
1502       hv_store(envhv,key,keylen,sv,hash);
1503       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1504     }
1505     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1506       /* get the PPFs for this process, not the subprocess */
1507       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1508       char eqv[LNM$C_NAMLENGTH+1];
1509       int trnlen, i;
1510       for (i = 0; ppfs[i]; i++) {
1511         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1512         sv = newSVpv(eqv,trnlen);
1513         SvTAINTED_on(sv);
1514         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1515       }
1516     }
1517   }
1518   primed = 1;
1519   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1520   if (buf) Safefree(buf);
1521   if (seenhv) SvREFCNT_dec(seenhv);
1522   MUTEX_UNLOCK(&primenv_mutex);
1523   return;
1524
1525 }  /* end of prime_env_iter */
1526 /*}}}*/
1527
1528
1529 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1530 /* Define or delete an element in the same "environment" as
1531  * vmstrnenv().  If an element is to be deleted, it's removed from
1532  * the first place it's found.  If it's to be set, it's set in the
1533  * place designated by the first element of the table vector.
1534  * Like setenv() returns 0 for success, non-zero on error.
1535  */
1536 int
1537 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1538 {
1539     const char *cp1;
1540     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1541     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1542     int nseg = 0, j;
1543     unsigned long int retsts, usermode = PSL$C_USER;
1544     struct itmlst_3 *ile, *ilist;
1545     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1546                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1547                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1548     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1549     $DESCRIPTOR(local,"_LOCAL");
1550
1551     if (!lnm) {
1552         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1553         return SS$_IVLOGNAM;
1554     }
1555
1556     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1557       *cp2 = _toupper(*cp1);
1558       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1559         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1560         return SS$_IVLOGNAM;
1561       }
1562     }
1563     lnmdsc.dsc$w_length = cp1 - lnm;
1564     if (!tabvec || !*tabvec) tabvec = env_tables;
1565
1566     if (!eqv) {  /* we're deleting n element */
1567       for (curtab = 0; tabvec[curtab]; curtab++) {
1568         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1569         int i;
1570           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1571             if ((cp1 = strchr(environ[i],'=')) &&
1572                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1573                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1574 #ifdef HAS_SETENV
1575               return setenv(lnm,"",1) ? vaxc$errno : 0;
1576             }
1577           }
1578           ivenv = 1; retsts = SS$_NOLOGNAM;
1579 #else
1580               if (ckWARN(WARN_INTERNAL))
1581                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1582               ivenv = 1; retsts = SS$_NOSUCHPGM;
1583               break;
1584             }
1585           }
1586 #endif
1587         }
1588         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1589                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1590           unsigned int symtype;
1591           if (tabvec[curtab]->dsc$w_length == 12 &&
1592               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1593               !str$case_blind_compare(&tmpdsc,&local))
1594             symtype = LIB$K_CLI_LOCAL_SYM;
1595           else symtype = LIB$K_CLI_GLOBAL_SYM;
1596           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1597           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1598           if (retsts == LIB$_NOSUCHSYM) continue;
1599           break;
1600         }
1601         else if (!ivlnm) {
1602           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1603           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1604           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1605           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1606           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1607         }
1608       }
1609     }
1610     else {  /* we're defining a value */
1611       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1612 #ifdef HAS_SETENV
1613         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1614 #else
1615         if (ckWARN(WARN_INTERNAL))
1616           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1617         retsts = SS$_NOSUCHPGM;
1618 #endif
1619       }
1620       else {
1621         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1622         eqvdsc.dsc$w_length  = strlen(eqv);
1623         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1624             !str$case_blind_compare(&tmpdsc,&clisym)) {
1625           unsigned int symtype;
1626           if (tabvec[0]->dsc$w_length == 12 &&
1627               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1628                !str$case_blind_compare(&tmpdsc,&local))
1629             symtype = LIB$K_CLI_LOCAL_SYM;
1630           else symtype = LIB$K_CLI_GLOBAL_SYM;
1631           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1632         }
1633         else {
1634           if (!*eqv) eqvdsc.dsc$w_length = 1;
1635           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1636
1637             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1638             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1639               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1640                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1641               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1642               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1643             }
1644
1645             Newx(ilist,nseg+1,struct itmlst_3);
1646             ile = ilist;
1647             if (!ile) {
1648               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1649               return SS$_INSFMEM;
1650             }
1651             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1652
1653             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1654               ile->itmcode = LNM$_STRING;
1655               ile->bufadr = c;
1656               if ((j+1) == nseg) {
1657                 ile->buflen = strlen(c);
1658                 /* in case we are truncating one that's too long */
1659                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1660               }
1661               else {
1662                 ile->buflen = LNM$C_NAMLENGTH;
1663               }
1664             }
1665
1666             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1667             Safefree (ilist);
1668           }
1669           else {
1670             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1671           }
1672         }
1673       }
1674     }
1675     if (!(retsts & 1)) {
1676       switch (retsts) {
1677         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1678         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1679           set_errno(EVMSERR); break;
1680         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1681         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1682           set_errno(EINVAL); break;
1683         case SS$_NOPRIV:
1684           set_errno(EACCES); break;
1685         default:
1686           _ckvmssts(retsts);
1687           set_errno(EVMSERR);
1688        }
1689        set_vaxc_errno(retsts);
1690        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1691     }
1692     else {
1693       /* We reset error values on success because Perl does an hv_fetch()
1694        * before each hv_store(), and if the thing we're setting didn't
1695        * previously exist, we've got a leftover error message.  (Of course,
1696        * this fails in the face of
1697        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1698        * in that the error reported in $! isn't spurious,
1699        * but it's right more often than not.)
1700        */
1701       set_errno(0); set_vaxc_errno(retsts);
1702       return 0;
1703     }
1704
1705 }  /* end of vmssetenv() */
1706 /*}}}*/
1707
1708 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1709 /* This has to be a function since there's a prototype for it in proto.h */
1710 void
1711 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1712 {
1713     if (lnm && *lnm) {
1714       int len = strlen(lnm);
1715       if  (len == 7) {
1716         char uplnm[8];
1717         int i;
1718         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1719         if (!strcmp(uplnm,"DEFAULT")) {
1720           if (eqv && *eqv) my_chdir(eqv);
1721           return;
1722         }
1723     }
1724 #ifndef RTL_USES_UTC
1725     if (len == 6 || len == 2) {
1726       char uplnm[7];
1727       int i;
1728       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1729       uplnm[len] = '\0';
1730       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1731       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1732     }
1733 #endif
1734   }
1735   (void) vmssetenv(lnm,eqv,NULL);
1736 }
1737 /*}}}*/
1738
1739 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1740 /*  vmssetuserlnm
1741  *  sets a user-mode logical in the process logical name table
1742  *  used for redirection of sys$error
1743  *
1744  *  Fix-me: The pTHX is not needed for this routine, however doio.c
1745  *          is calling it with one instead of using a macro.
1746  *          A macro needs to be added to vmsish.h and doio.c updated to use it.
1747  *
1748  */
1749 void
1750 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1751 {
1752     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1753     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1754     unsigned long int iss, attr = LNM$M_CONFINE;
1755     unsigned char acmode = PSL$C_USER;
1756     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1757                                  {0, 0, 0, 0}};
1758     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1759     d_name.dsc$w_length = strlen(name);
1760
1761     lnmlst[0].buflen = strlen(eqv);
1762     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1763
1764     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1765     if (!(iss&1)) lib$signal(iss);
1766 }
1767 /*}}}*/
1768
1769
1770 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1771 /* my_crypt - VMS password hashing
1772  * my_crypt() provides an interface compatible with the Unix crypt()
1773  * C library function, and uses sys$hash_password() to perform VMS
1774  * password hashing.  The quadword hashed password value is returned
1775  * as a NUL-terminated 8 character string.  my_crypt() does not change
1776  * the case of its string arguments; in order to match the behavior
1777  * of LOGINOUT et al., alphabetic characters in both arguments must
1778  *  be upcased by the caller.
1779  *
1780  * - fix me to call ACM services when available
1781  */
1782 char *
1783 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1784 {
1785 #   ifndef UAI$C_PREFERRED_ALGORITHM
1786 #     define UAI$C_PREFERRED_ALGORITHM 127
1787 #   endif
1788     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1789     unsigned short int salt = 0;
1790     unsigned long int sts;
1791     struct const_dsc {
1792         unsigned short int dsc$w_length;
1793         unsigned char      dsc$b_type;
1794         unsigned char      dsc$b_class;
1795         const char *       dsc$a_pointer;
1796     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1797        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1798     struct itmlst_3 uailst[3] = {
1799         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1800         { sizeof salt, UAI$_SALT,    &salt, 0},
1801         { 0,           0,            NULL,  NULL}};
1802     static char hash[9];
1803
1804     usrdsc.dsc$w_length = strlen(usrname);
1805     usrdsc.dsc$a_pointer = usrname;
1806     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1807       switch (sts) {
1808         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1809           set_errno(EACCES);
1810           break;
1811         case RMS$_RNF:
1812           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1813           break;
1814         default:
1815           set_errno(EVMSERR);
1816       }
1817       set_vaxc_errno(sts);
1818       if (sts != RMS$_RNF) return NULL;
1819     }
1820
1821     txtdsc.dsc$w_length = strlen(textpasswd);
1822     txtdsc.dsc$a_pointer = textpasswd;
1823     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1824       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1825     }
1826
1827     return (char *) hash;
1828
1829 }  /* end of my_crypt() */
1830 /*}}}*/
1831
1832
1833 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1834 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1835 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1836
1837 /* fixup barenames that are directories for internal use.
1838  * There have been problems with the consistent handling of UNIX
1839  * style directory names when routines are presented with a name that
1840  * has no directory delimiters at all.  So this routine will eventually
1841  * fix the issue.
1842  */
1843 static char * fixup_bare_dirnames(const char * name)
1844 {
1845   if (decc_disable_to_vms_logname_translation) {
1846 /* fix me */
1847   }
1848   return NULL;
1849 }
1850
1851 /* 8.3, remove() is now broken on symbolic links */
1852 static int rms_erase(const char * vmsname);
1853
1854
1855 /* mp_do_kill_file
1856  * A little hack to get around a bug in some implementation of remove()
1857  * that do not know how to delete a directory
1858  *
1859  * Delete any file to which user has control access, regardless of whether
1860  * delete access is explicitly allowed.
1861  * Limitations: User must have write access to parent directory.
1862  *              Does not block signals or ASTs; if interrupted in midstream
1863  *              may leave file with an altered ACL.
1864  * HANDLE WITH CARE!
1865  */
1866 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1867 static int
1868 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1869 {
1870     char *vmsname;
1871     char *rslt;
1872     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1873     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1874     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1875     struct myacedef {
1876       unsigned char myace$b_length;
1877       unsigned char myace$b_type;
1878       unsigned short int myace$w_flags;
1879       unsigned long int myace$l_access;
1880       unsigned long int myace$l_ident;
1881     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1882                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1883       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1884      struct itmlst_3
1885        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1886                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1887        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1888        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1889        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1890        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1891
1892     /* Expand the input spec using RMS, since the CRTL remove() and
1893      * system services won't do this by themselves, so we may miss
1894      * a file "hiding" behind a logical name or search list. */
1895     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1896     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1897
1898     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1899     if (rslt == NULL) {
1900         PerlMem_free(vmsname);
1901         return -1;
1902       }
1903
1904     /* Erase the file */
1905     rmsts = rms_erase(vmsname);
1906
1907     /* Did it succeed */
1908     if ($VMS_STATUS_SUCCESS(rmsts)) {
1909         PerlMem_free(vmsname);
1910         return 0;
1911       }
1912
1913     /* If not, can changing protections help? */
1914     if (rmsts != RMS$_PRV) {
1915       set_vaxc_errno(rmsts);
1916       PerlMem_free(vmsname);
1917       return -1;
1918     }
1919
1920     /* No, so we get our own UIC to use as a rights identifier,
1921      * and the insert an ACE at the head of the ACL which allows us
1922      * to delete the file.
1923      */
1924     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1925     fildsc.dsc$w_length = strlen(vmsname);
1926     fildsc.dsc$a_pointer = vmsname;
1927     cxt = 0;
1928     newace.myace$l_ident = oldace.myace$l_ident;
1929     rmsts = -1;
1930     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1931       switch (aclsts) {
1932         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1933           set_errno(ENOENT); break;
1934         case RMS$_DIR:
1935           set_errno(ENOTDIR); break;
1936         case RMS$_DEV:
1937           set_errno(ENODEV); break;
1938         case RMS$_SYN: case SS$_INVFILFOROP:
1939           set_errno(EINVAL); break;
1940         case RMS$_PRV:
1941           set_errno(EACCES); break;
1942         default:
1943           _ckvmssts_noperl(aclsts);
1944       }
1945       set_vaxc_errno(aclsts);
1946       PerlMem_free(vmsname);
1947       return -1;
1948     }
1949     /* Grab any existing ACEs with this identifier in case we fail */
1950     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1951     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1952                     || fndsts == SS$_NOMOREACE ) {
1953       /* Add the new ACE . . . */
1954       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1955         goto yourroom;
1956
1957       rmsts = rms_erase(vmsname);
1958       if ($VMS_STATUS_SUCCESS(rmsts)) {
1959         rmsts = 0;
1960         }
1961         else {
1962         rmsts = -1;
1963         /* We blew it - dir with files in it, no write priv for
1964          * parent directory, etc.  Put things back the way they were. */
1965         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1966           goto yourroom;
1967         if (fndsts & 1) {
1968           addlst[0].bufadr = &oldace;
1969           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1970             goto yourroom;
1971         }
1972       }
1973     }
1974
1975     yourroom:
1976     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1977     /* We just deleted it, so of course it's not there.  Some versions of
1978      * VMS seem to return success on the unlock operation anyhow (after all
1979      * the unlock is successful), but others don't.
1980      */
1981     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1982     if (aclsts & 1) aclsts = fndsts;
1983     if (!(aclsts & 1)) {
1984       set_errno(EVMSERR);
1985       set_vaxc_errno(aclsts);
1986     }
1987
1988     PerlMem_free(vmsname);
1989     return rmsts;
1990
1991 }  /* end of kill_file() */
1992 /*}}}*/
1993
1994
1995 /*{{{int do_rmdir(char *name)*/
1996 int
1997 Perl_do_rmdir(pTHX_ const char *name)
1998 {
1999     char * dirfile;
2000     int retval;
2001     Stat_t st;
2002
2003     /* lstat returns a VMS fileified specification of the name */
2004     /* that is looked up, and also lets verifies that this is a directory */
2005
2006     retval = flex_lstat(name, &st);
2007     if (retval != 0) {
2008         char * ret_spec;
2009
2010         /* Due to a historical feature, flex_stat/lstat can not see some */
2011         /* Unix format file names that the rest of the CRTL can see */
2012         /* Fixing that feature will cause some perl tests to fail */
2013         /* So try this one more time. */
2014
2015         retval = lstat(name, &st.crtl_stat);
2016         if (retval != 0)
2017             return -1;
2018
2019         /* force it to a file spec for the kill file to work. */
2020         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
2021         if (ret_spec == NULL) {
2022             errno = EIO;
2023             return -1;
2024         }
2025     }
2026
2027     if (!S_ISDIR(st.st_mode)) {
2028         errno = ENOTDIR;
2029         retval = -1;
2030     }
2031     else {
2032         dirfile = st.st_devnam;
2033
2034         /* It may be possible for flex_stat to find a file and vmsify() to */
2035         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
2036         /* with that case, so fail it */
2037         if (dirfile[0] == 0) {
2038             errno = EIO;
2039             return -1;
2040         }
2041
2042         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2043     }
2044
2045     return retval;
2046
2047 }  /* end of do_rmdir */
2048 /*}}}*/
2049
2050 /* kill_file
2051  * Delete any file to which user has control access, regardless of whether
2052  * delete access is explicitly allowed.
2053  * Limitations: User must have write access to parent directory.
2054  *              Does not block signals or ASTs; if interrupted in midstream
2055  *              may leave file with an altered ACL.
2056  * HANDLE WITH CARE!
2057  */
2058 /*{{{int kill_file(char *name)*/
2059 int
2060 Perl_kill_file(pTHX_ const char *name)
2061 {
2062     char * vmsfile;
2063     Stat_t st;
2064     int rmsts;
2065
2066     /* Convert the filename to VMS format and see if it is a directory */
2067     /* flex_lstat returns a vmsified file specification */
2068     rmsts = flex_lstat(name, &st);
2069     if (rmsts != 0) {
2070
2071         /* Due to a historical feature, flex_stat/lstat can not see some */
2072         /* Unix format file names that the rest of the CRTL can see when */
2073         /* ODS-2 file specifications are in use. */
2074         /* Fixing that feature will cause some perl tests to fail */
2075         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2076         st.st_mode = 0;
2077         vmsfile = (char *) name; /* cast ok */
2078
2079     } else {
2080         vmsfile = st.st_devnam;
2081         if (vmsfile[0] == 0) {
2082             /* It may be possible for flex_stat to find a file and vmsify() */
2083             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2084             /* deal with that case, so fail it */
2085             errno = EIO;
2086             return -1;
2087         }
2088     }
2089
2090     /* Remove() is allowed to delete directories, according to the X/Open
2091      * specifications.
2092      * This may need special handling to work with the ACL hacks.
2093      */
2094     if (S_ISDIR(st.st_mode)) {
2095         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2096         return rmsts;
2097     }
2098
2099     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2100
2101     /* Need to delete all versions ? */
2102     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2103         int i = 0;
2104
2105         /* Just use lstat() here as do not need st_dev */
2106         /* and we know that the file is in VMS format or that */
2107         /* because of a historical bug, flex_stat can not see the file */
2108         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2109             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2110             if (rmsts != 0)
2111                 break;
2112             i++;
2113
2114             /* Make sure that we do not loop forever */
2115             if (i > 32767) {
2116                 errno = EIO;
2117                 rmsts = -1;
2118                 break;
2119             }
2120         }
2121     }
2122
2123     return rmsts;
2124
2125 }  /* end of kill_file() */
2126 /*}}}*/
2127
2128
2129 /*{{{int my_mkdir(char *,Mode_t)*/
2130 int
2131 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2132 {
2133   STRLEN dirlen = strlen(dir);
2134
2135   /* zero length string sometimes gives ACCVIO */
2136   if (dirlen == 0) return -1;
2137
2138   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2139    * null file name/type.  However, it's commonplace under Unix,
2140    * so we'll allow it for a gain in portability.
2141    */
2142   if (dir[dirlen-1] == '/') {
2143     char *newdir = savepvn(dir,dirlen-1);
2144     int ret = mkdir(newdir,mode);
2145     Safefree(newdir);
2146     return ret;
2147   }
2148   else return mkdir(dir,mode);
2149 }  /* end of my_mkdir */
2150 /*}}}*/
2151
2152 /*{{{int my_chdir(char *)*/
2153 int
2154 Perl_my_chdir(pTHX_ const char *dir)
2155 {
2156   STRLEN dirlen = strlen(dir);
2157
2158   /* zero length string sometimes gives ACCVIO */
2159   if (dirlen == 0) return -1;
2160   const char *dir1;
2161
2162   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2163    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2164    * so that existing scripts do not need to be changed.
2165    */
2166   dir1 = dir;
2167   while ((dirlen > 0) && (*dir1 == ' ')) {
2168     dir1++;
2169     dirlen--;
2170   }
2171
2172   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2173    * that implies
2174    * null file name/type.  However, it's commonplace under Unix,
2175    * so we'll allow it for a gain in portability.
2176    *
2177    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2178    */
2179   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2180       char *newdir;
2181       int ret;
2182       newdir = PerlMem_malloc(dirlen);
2183       if (newdir ==NULL)
2184           _ckvmssts_noperl(SS$_INSFMEM);
2185       strncpy(newdir, dir1, dirlen-1);
2186       newdir[dirlen-1] = '\0';
2187       ret = chdir(newdir);
2188       PerlMem_free(newdir);
2189       return ret;
2190   }
2191   else return chdir(dir1);
2192 }  /* end of my_chdir */
2193 /*}}}*/
2194
2195
2196 /*{{{int my_chmod(char *, mode_t)*/
2197 int
2198 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2199 {
2200   Stat_t st;
2201   int ret = -1;
2202   char * changefile;
2203   STRLEN speclen = strlen(file_spec);
2204
2205   /* zero length string sometimes gives ACCVIO */
2206   if (speclen == 0) return -1;
2207
2208   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2209    * that implies null file name/type.  However, it's commonplace under Unix,
2210    * so we'll allow it for a gain in portability.
2211    *
2212    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2213    * in VMS file.dir notation.
2214    */
2215   changefile = (char *) file_spec; /* cast ok */
2216   ret = flex_lstat(file_spec, &st);
2217   if (ret != 0) {
2218
2219         /* Due to a historical feature, flex_stat/lstat can not see some */
2220         /* Unix format file names that the rest of the CRTL can see when */
2221         /* ODS-2 file specifications are in use. */
2222         /* Fixing that feature will cause some perl tests to fail */
2223         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2224         st.st_mode = 0;
2225
2226   } else {
2227       /* It may be possible to get here with nothing in st_devname */
2228       /* chmod still may work though */
2229       if (st.st_devnam[0] != 0) {
2230           changefile = st.st_devnam;
2231       }
2232   }
2233   ret = chmod(changefile, mode);
2234   return ret;
2235 }  /* end of my_chmod */
2236 /*}}}*/
2237
2238
2239 /*{{{FILE *my_tmpfile()*/
2240 FILE *
2241 my_tmpfile(void)
2242 {
2243   FILE *fp;
2244   char *cp;
2245
2246   if ((fp = tmpfile())) return fp;
2247
2248   cp = PerlMem_malloc(L_tmpnam+24);
2249   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2250
2251   if (decc_filename_unix_only == 0)
2252     strcpy(cp,"Sys$Scratch:");
2253   else
2254     strcpy(cp,"/tmp/");
2255   tmpnam(cp+strlen(cp));
2256   strcat(cp,".Perltmp");
2257   fp = fopen(cp,"w+","fop=dlt");
2258   PerlMem_free(cp);
2259   return fp;
2260 }
2261 /*}}}*/
2262
2263
2264 #ifndef HOMEGROWN_POSIX_SIGNALS
2265 /*
2266  * The C RTL's sigaction fails to check for invalid signal numbers so we
2267  * help it out a bit.  The docs are correct, but the actual routine doesn't
2268  * do what the docs say it will.
2269  */
2270 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2271 int
2272 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2273                    struct sigaction* oact)
2274 {
2275   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2276         SETERRNO(EINVAL, SS$_INVARG);
2277         return -1;
2278   }
2279   return sigaction(sig, act, oact);
2280 }
2281 /*}}}*/
2282 #endif
2283
2284 #ifdef KILL_BY_SIGPRC
2285 #include <errnodef.h>
2286
2287 /* We implement our own kill() using the undocumented system service
2288    sys$sigprc for one of two reasons:
2289
2290    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2291    target process to do a sys$exit, which usually can't be handled
2292    gracefully...certainly not by Perl and the %SIG{} mechanism.
2293
2294    2.) If the kill() in the CRTL can't be called from a signal
2295    handler without disappearing into the ether, i.e., the signal
2296    it purportedly sends is never trapped. Still true as of VMS 7.3.
2297
2298    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2299    in the target process rather than calling sys$exit.
2300
2301    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2302    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2303    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2304    with condition codes C$_SIG0+nsig*8, catching the exception on the
2305    target process and resignaling with appropriate arguments.
2306
2307    But we don't have that VMS 7.0+ exception handler, so if you
2308    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2309
2310    Also note that SIGTERM is listed in the docs as being "unimplemented",
2311    yet always seems to be signaled with a VMS condition code of 4 (and
2312    correctly handled for that code).  So we hardwire it in.
2313
2314    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2315    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2316    than signalling with an unrecognized (and unhandled by CRTL) code.
2317 */
2318
2319 #define _MY_SIG_MAX 28
2320
2321 static unsigned int
2322 Perl_sig_to_vmscondition_int(int sig)
2323 {
2324     static unsigned int sig_code[_MY_SIG_MAX+1] =
2325     {
2326         0,                  /*  0 ZERO     */
2327         SS$_HANGUP,         /*  1 SIGHUP   */
2328         SS$_CONTROLC,       /*  2 SIGINT   */
2329         SS$_CONTROLY,       /*  3 SIGQUIT  */
2330         SS$_RADRMOD,        /*  4 SIGILL   */
2331         SS$_BREAK,          /*  5 SIGTRAP  */
2332         SS$_OPCCUS,         /*  6 SIGABRT  */
2333         SS$_COMPAT,         /*  7 SIGEMT   */
2334 #ifdef __VAX
2335         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2336 #else
2337         SS$_HPARITH,        /*  8 SIGFPE AXP */
2338 #endif
2339         SS$_ABORT,          /*  9 SIGKILL  */
2340         SS$_ACCVIO,         /* 10 SIGBUS   */
2341         SS$_ACCVIO,         /* 11 SIGSEGV  */
2342         SS$_BADPARAM,       /* 12 SIGSYS   */
2343         SS$_NOMBX,          /* 13 SIGPIPE  */
2344         SS$_ASTFLT,         /* 14 SIGALRM  */
2345         4,                  /* 15 SIGTERM  */
2346         0,                  /* 16 SIGUSR1  */
2347         0,                  /* 17 SIGUSR2  */
2348         0,                  /* 18 */
2349         0,                  /* 19 */
2350         0,                  /* 20 SIGCHLD  */
2351         0,                  /* 21 SIGCONT  */
2352         0,                  /* 22 SIGSTOP  */
2353         0,                  /* 23 SIGTSTP  */
2354         0,                  /* 24 SIGTTIN  */
2355         0,                  /* 25 SIGTTOU  */
2356         0,                  /* 26 */
2357         0,                  /* 27 */
2358         0                   /* 28 SIGWINCH  */
2359     };
2360
2361 #if __VMS_VER >= 60200000
2362     static int initted = 0;
2363     if (!initted) {
2364         initted = 1;
2365         sig_code[16] = C$_SIGUSR1;
2366         sig_code[17] = C$_SIGUSR2;
2367 #if __CRTL_VER >= 70000000
2368         sig_code[20] = C$_SIGCHLD;
2369 #endif
2370 #if __CRTL_VER >= 70300000
2371         sig_code[28] = C$_SIGWINCH;
2372 #endif
2373     }
2374 #endif
2375
2376     if (sig < _SIG_MIN) return 0;
2377     if (sig > _MY_SIG_MAX) return 0;
2378     return sig_code[sig];
2379 }
2380
2381 unsigned int
2382 Perl_sig_to_vmscondition(int sig)
2383 {
2384 #ifdef SS$_DEBUG
2385     if (vms_debug_on_exception != 0)
2386         lib$signal(SS$_DEBUG);
2387 #endif
2388     return Perl_sig_to_vmscondition_int(sig);
2389 }
2390
2391
2392 int
2393 Perl_my_kill(int pid, int sig)
2394 {
2395     int iss;
2396     unsigned int code;
2397 #define sys$sigprc SYS$SIGPRC
2398     int sys$sigprc(unsigned int *pidadr,
2399                      struct dsc$descriptor_s *prcname,
2400                      unsigned int code);
2401
2402      /* sig 0 means validate the PID */
2403     /*------------------------------*/
2404     if (sig == 0) {
2405         const unsigned long int jpicode = JPI$_PID;
2406         pid_t ret_pid;
2407         int status;
2408         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2409         if ($VMS_STATUS_SUCCESS(status))
2410            return 0;
2411         switch (status) {
2412         case SS$_NOSUCHNODE:
2413         case SS$_UNREACHABLE:
2414         case SS$_NONEXPR:
2415            errno = ESRCH;
2416            break;
2417         case SS$_NOPRIV:
2418            errno = EPERM;
2419            break;
2420         default:
2421            errno = EVMSERR;
2422         }
2423         vaxc$errno=status;
2424         return -1;
2425     }
2426
2427     code = Perl_sig_to_vmscondition_int(sig);
2428
2429     if (!code) {
2430         SETERRNO(EINVAL, SS$_BADPARAM);
2431         return -1;
2432     }
2433
2434     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2435      * signals are to be sent to multiple processes.
2436      *  pid = 0 - all processes in group except ones that the system exempts
2437      *  pid = -1 - all processes except ones that the system exempts
2438      *  pid = -n - all processes in group (abs(n)) except ...
2439      * For now, just report as not supported.
2440      */
2441
2442     if (pid <= 0) {
2443         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2444         return -1;
2445     }
2446
2447     iss = sys$sigprc((unsigned int *)&pid,0,code);
2448     if (iss&1) return 0;
2449
2450     switch (iss) {
2451       case SS$_NOPRIV:
2452         set_errno(EPERM);  break;
2453       case SS$_NONEXPR:
2454       case SS$_NOSUCHNODE:
2455       case SS$_UNREACHABLE:
2456         set_errno(ESRCH);  break;
2457       case SS$_INSFMEM:
2458         set_errno(ENOMEM); break;
2459       default:
2460         _ckvmssts_noperl(iss);
2461         set_errno(EVMSERR);
2462     }
2463     set_vaxc_errno(iss);
2464
2465     return -1;
2466 }
2467 #endif
2468
2469 /* Routine to convert a VMS status code to a UNIX status code.
2470 ** More tricky than it appears because of conflicting conventions with
2471 ** existing code.
2472 **
2473 ** VMS status codes are a bit mask, with the least significant bit set for
2474 ** success.
2475 **
2476 ** Special UNIX status of EVMSERR indicates that no translation is currently
2477 ** available, and programs should check the VMS status code.
2478 **
2479 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2480 ** decoding.
2481 */
2482
2483 #ifndef C_FACILITY_NO
2484 #define C_FACILITY_NO 0x350000
2485 #endif
2486 #ifndef DCL_IVVERB
2487 #define DCL_IVVERB 0x38090
2488 #endif
2489
2490 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2491 {
2492 int facility;
2493 int fac_sp;
2494 int msg_no;
2495 int msg_status;
2496 int unix_status;
2497
2498   /* Assume the best or the worst */
2499   if (vms_status & STS$M_SUCCESS)
2500     unix_status = 0;
2501   else
2502     unix_status = EVMSERR;
2503
2504   msg_status = vms_status & ~STS$M_CONTROL;
2505
2506   facility = vms_status & STS$M_FAC_NO;
2507   fac_sp = vms_status & STS$M_FAC_SP;
2508   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2509
2510   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2511     switch(msg_no) {
2512     case SS$_NORMAL:
2513         unix_status = 0;
2514         break;
2515     case SS$_ACCVIO:
2516         unix_status = EFAULT;
2517         break;
2518     case SS$_DEVOFFLINE:
2519         unix_status = EBUSY;
2520         break;
2521     case SS$_CLEARED:
2522         unix_status = ENOTCONN;
2523         break;
2524     case SS$_IVCHAN:
2525     case SS$_IVLOGNAM:
2526     case SS$_BADPARAM:
2527     case SS$_IVLOGTAB:
2528     case SS$_NOLOGNAM:
2529     case SS$_NOLOGTAB:
2530     case SS$_INVFILFOROP:
2531     case SS$_INVARG:
2532     case SS$_NOSUCHID:
2533     case SS$_IVIDENT:
2534         unix_status = EINVAL;
2535         break;
2536     case SS$_UNSUPPORTED:
2537         unix_status = ENOTSUP;
2538         break;
2539     case SS$_FILACCERR:
2540     case SS$_NOGRPPRV:
2541     case SS$_NOSYSPRV:
2542         unix_status = EACCES;
2543         break;
2544     case SS$_DEVICEFULL:
2545         unix_status = ENOSPC;
2546         break;
2547     case SS$_NOSUCHDEV:
2548         unix_status = ENODEV;
2549         break;
2550     case SS$_NOSUCHFILE:
2551     case SS$_NOSUCHOBJECT:
2552         unix_status = ENOENT;
2553         break;
2554     case SS$_ABORT:                                 /* Fatal case */
2555     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2556     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2557         unix_status = EINTR;
2558         break;
2559     case SS$_BUFFEROVF:
2560         unix_status = E2BIG;
2561         break;
2562     case SS$_INSFMEM:
2563         unix_status = ENOMEM;
2564         break;
2565     case SS$_NOPRIV:
2566         unix_status = EPERM;
2567         break;
2568     case SS$_NOSUCHNODE:
2569     case SS$_UNREACHABLE:
2570         unix_status = ESRCH;
2571         break;
2572     case SS$_NONEXPR:
2573         unix_status = ECHILD;
2574         break;
2575     default:
2576         if ((facility == 0) && (msg_no < 8)) {
2577           /* These are not real VMS status codes so assume that they are
2578           ** already UNIX status codes
2579           */
2580           unix_status = msg_no;
2581           break;
2582         }
2583     }
2584   }
2585   else {
2586     /* Translate a POSIX exit code to a UNIX exit code */
2587     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2588         unix_status = (msg_no & 0x07F8) >> 3;
2589     }
2590     else {
2591
2592          /* Documented traditional behavior for handling VMS child exits */
2593         /*--------------------------------------------------------------*/
2594         if (child_flag != 0) {
2595
2596              /* Success / Informational return 0 */
2597             /*----------------------------------*/
2598             if (msg_no & STS$K_SUCCESS)
2599                 return 0;
2600
2601              /* Warning returns 1 */
2602             /*-------------------*/
2603             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2604                 return 1;
2605
2606              /* Everything else pass through the severity bits */
2607             /*------------------------------------------------*/
2608             return (msg_no & STS$M_SEVERITY);
2609         }
2610
2611          /* Normal VMS status to ERRNO mapping attempt */
2612         /*--------------------------------------------*/
2613         switch(msg_status) {
2614         /* case RMS$_EOF: */ /* End of File */
2615         case RMS$_FNF:  /* File Not Found */
2616         case RMS$_DNF:  /* Dir Not Found */
2617                 unix_status = ENOENT;
2618                 break;
2619         case RMS$_RNF:  /* Record Not Found */
2620                 unix_status = ESRCH;
2621                 break;
2622         case RMS$_DIR:
2623                 unix_status = ENOTDIR;
2624                 break;
2625         case RMS$_DEV:
2626                 unix_status = ENODEV;
2627                 break;
2628         case RMS$_IFI:
2629         case RMS$_FAC:
2630         case RMS$_ISI:
2631                 unix_status = EBADF;
2632                 break;
2633         case RMS$_FEX:
2634                 unix_status = EEXIST;
2635                 break;
2636         case RMS$_SYN:
2637         case RMS$_FNM:
2638         case LIB$_INVSTRDES:
2639         case LIB$_INVARG:
2640         case LIB$_NOSUCHSYM:
2641         case LIB$_INVSYMNAM:
2642         case DCL_IVVERB:
2643                 unix_status = EINVAL;
2644                 break;
2645         case CLI$_BUFOVF:
2646         case RMS$_RTB:
2647         case CLI$_TKNOVF:
2648         case CLI$_RSLOVF:
2649                 unix_status = E2BIG;
2650                 break;
2651         case RMS$_PRV:  /* No privilege */
2652         case RMS$_ACC:  /* ACP file access failed */
2653         case RMS$_WLK:  /* Device write locked */
2654                 unix_status = EACCES;
2655                 break;
2656         case RMS$_MKD:  /* Failed to mark for delete */
2657                 unix_status = EPERM;
2658                 break;
2659         /* case RMS$_NMF: */  /* No more files */
2660         }
2661     }
2662   }
2663
2664   return unix_status;
2665 }
2666
2667 /* Try to guess at what VMS error status should go with a UNIX errno
2668  * value.  This is hard to do as there could be many possible VMS
2669  * error statuses that caused the errno value to be set.
2670  */
2671
2672 int Perl_unix_status_to_vms(int unix_status)
2673 {
2674 int test_unix_status;
2675
2676      /* Trivial cases first */
2677     /*---------------------*/
2678     if (unix_status == EVMSERR)
2679         return vaxc$errno;
2680
2681      /* Is vaxc$errno sane? */
2682     /*---------------------*/
2683     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2684     if (test_unix_status == unix_status)
2685         return vaxc$errno;
2686
2687      /* If way out of range, must be VMS code already */
2688     /*-----------------------------------------------*/
2689     if (unix_status > EVMSERR)
2690         return unix_status;
2691
2692      /* If out of range, punt */
2693     /*-----------------------*/
2694     if (unix_status > __ERRNO_MAX)
2695         return SS$_ABORT;
2696
2697
2698      /* Ok, now we have to do it the hard way. */
2699     /*----------------------------------------*/
2700     switch(unix_status) {
2701     case 0:     return SS$_NORMAL;
2702     case EPERM: return SS$_NOPRIV;
2703     case ENOENT: return SS$_NOSUCHOBJECT;
2704     case ESRCH: return SS$_UNREACHABLE;
2705     case EINTR: return SS$_ABORT;
2706     /* case EIO: */
2707     /* case ENXIO:  */
2708     case E2BIG: return SS$_BUFFEROVF;
2709     /* case ENOEXEC */
2710     case EBADF: return RMS$_IFI;
2711     case ECHILD: return SS$_NONEXPR;
2712     /* case EAGAIN */
2713     case ENOMEM: return SS$_INSFMEM;
2714     case EACCES: return SS$_FILACCERR;
2715     case EFAULT: return SS$_ACCVIO;
2716     /* case ENOTBLK */
2717     case EBUSY: return SS$_DEVOFFLINE;
2718     case EEXIST: return RMS$_FEX;
2719     /* case EXDEV */
2720     case ENODEV: return SS$_NOSUCHDEV;
2721     case ENOTDIR: return RMS$_DIR;
2722     /* case EISDIR */
2723     case EINVAL: return SS$_INVARG;
2724     /* case ENFILE */
2725     /* case EMFILE */
2726     /* case ENOTTY */
2727     /* case ETXTBSY */
2728     /* case EFBIG */
2729     case ENOSPC: return SS$_DEVICEFULL;
2730     case ESPIPE: return LIB$_INVARG;
2731     /* case EROFS: */
2732     /* case EMLINK: */
2733     /* case EPIPE: */
2734     /* case EDOM */
2735     case ERANGE: return LIB$_INVARG;
2736     /* case EWOULDBLOCK */
2737     /* case EINPROGRESS */
2738     /* case EALREADY */
2739     /* case ENOTSOCK */
2740     /* case EDESTADDRREQ */
2741     /* case EMSGSIZE */
2742     /* case EPROTOTYPE */
2743     /* case ENOPROTOOPT */
2744     /* case EPROTONOSUPPORT */
2745     /* case ESOCKTNOSUPPORT */
2746     /* case EOPNOTSUPP */
2747     /* case EPFNOSUPPORT */
2748     /* case EAFNOSUPPORT */
2749     /* case EADDRINUSE */
2750     /* case EADDRNOTAVAIL */
2751     /* case ENETDOWN */
2752     /* case ENETUNREACH */
2753     /* case ENETRESET */
2754     /* case ECONNABORTED */
2755     /* case ECONNRESET */
2756     /* case ENOBUFS */
2757     /* case EISCONN */
2758     case ENOTCONN: return SS$_CLEARED;
2759     /* case ESHUTDOWN */
2760     /* case ETOOMANYREFS */
2761     /* case ETIMEDOUT */
2762     /* case ECONNREFUSED */
2763     /* case ELOOP */
2764     /* case ENAMETOOLONG */
2765     /* case EHOSTDOWN */
2766     /* case EHOSTUNREACH */
2767     /* case ENOTEMPTY */
2768     /* case EPROCLIM */
2769     /* case EUSERS  */
2770     /* case EDQUOT  */
2771     /* case ENOMSG  */
2772     /* case EIDRM */
2773     /* case EALIGN */
2774     /* case ESTALE */
2775     /* case EREMOTE */
2776     /* case ENOLCK */
2777     /* case ENOSYS */
2778     /* case EFTYPE */
2779     /* case ECANCELED */
2780     /* case EFAIL */
2781     /* case EINPROG */
2782     case ENOTSUP:
2783         return SS$_UNSUPPORTED;
2784     /* case EDEADLK */
2785     /* case ENWAIT */
2786     /* case EILSEQ */
2787     /* case EBADCAT */
2788     /* case EBADMSG */
2789     /* case EABANDONED */
2790     default:
2791         return SS$_ABORT; /* punt */
2792     }
2793 }
2794
2795
2796 /* default piping mailbox size */
2797 #ifdef __VAX
2798 #  define PERL_BUFSIZ        512
2799 #else
2800 #  define PERL_BUFSIZ        8192
2801 #endif
2802
2803
2804 static void
2805 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2806 {
2807   unsigned long int mbxbufsiz;
2808   static unsigned long int syssize = 0;
2809   unsigned long int dviitm = DVI$_DEVNAM;
2810   char csize[LNM$C_NAMLENGTH+1];
2811   int sts;
2812
2813   if (!syssize) {
2814     unsigned long syiitm = SYI$_MAXBUF;
2815     /*
2816      * Get the SYSGEN parameter MAXBUF
2817      *
2818      * If the logical 'PERL_MBX_SIZE' is defined
2819      * use the value of the logical instead of PERL_BUFSIZ, but
2820      * keep the size between 128 and MAXBUF.
2821      *
2822      */
2823     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2824   }
2825
2826   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2827       mbxbufsiz = atoi(csize);
2828   } else {
2829       mbxbufsiz = PERL_BUFSIZ;
2830   }
2831   if (mbxbufsiz < 128) mbxbufsiz = 128;
2832   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2833
2834   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2835
2836   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2837   _ckvmssts_noperl(sts);
2838   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2839
2840 }  /* end of create_mbx() */
2841
2842
2843 /*{{{  my_popen and my_pclose*/
2844
2845 typedef struct _iosb           IOSB;
2846 typedef struct _iosb*         pIOSB;
2847 typedef struct _pipe           Pipe;
2848 typedef struct _pipe*         pPipe;
2849 typedef struct pipe_details    Info;
2850 typedef struct pipe_details*  pInfo;
2851 typedef struct _srqp            RQE;
2852 typedef struct _srqp*          pRQE;
2853 typedef struct _tochildbuf      CBuf;
2854 typedef struct _tochildbuf*    pCBuf;
2855
2856 struct _iosb {
2857     unsigned short status;
2858     unsigned short count;
2859     unsigned long  dvispec;
2860 };
2861
2862 #pragma member_alignment save
2863 #pragma nomember_alignment quadword
2864 struct _srqp {          /* VMS self-relative queue entry */
2865     unsigned long qptr[2];
2866 };
2867 #pragma member_alignment restore
2868 static RQE  RQE_ZERO = {0,0};
2869
2870 struct _tochildbuf {
2871     RQE             q;
2872     int             eof;
2873     unsigned short  size;
2874     char            *buf;
2875 };
2876
2877 struct _pipe {
2878     RQE            free;
2879     RQE            wait;
2880     int            fd_out;
2881     unsigned short chan_in;
2882     unsigned short chan_out;
2883     char          *buf;
2884     unsigned int   bufsize;
2885     IOSB           iosb;
2886     IOSB           iosb2;
2887     int           *pipe_done;
2888     int            retry;
2889     int            type;
2890     int            shut_on_empty;
2891     int            need_wake;
2892     pPipe         *home;
2893     pInfo          info;
2894     pCBuf          curr;
2895     pCBuf          curr2;
2896 #if defined(PERL_IMPLICIT_CONTEXT)
2897     void            *thx;           /* Either a thread or an interpreter */
2898                                     /* pointer, depending on how we're built */
2899 #endif
2900 };
2901
2902
2903 struct pipe_details
2904 {
2905     pInfo           next;
2906     PerlIO *fp;  /* file pointer to pipe mailbox */
2907     int useFILE; /* using stdio, not perlio */
2908     int pid;   /* PID of subprocess */
2909     int mode;  /* == 'r' if pipe open for reading */
2910     int done;  /* subprocess has completed */
2911     int waiting; /* waiting for completion/closure */
2912     int             closing;        /* my_pclose is closing this pipe */
2913     unsigned long   completion;     /* termination status of subprocess */
2914     pPipe           in;             /* pipe in to sub */
2915     pPipe           out;            /* pipe out of sub */
2916     pPipe           err;            /* pipe of sub's sys$error */
2917     int             in_done;        /* true when in pipe finished */
2918     int             out_done;
2919     int             err_done;
2920     unsigned short  xchan;          /* channel to debug xterm */
2921     unsigned short  xchan_valid;    /* channel is assigned */
2922 };
2923
2924 struct exit_control_block
2925 {
2926     struct exit_control_block *flink;
2927     unsigned long int (*exit_routine)(void);
2928     unsigned long int arg_count;
2929     unsigned long int *status_address;
2930     unsigned long int exit_status;
2931 };
2932
2933 typedef struct _closed_pipes    Xpipe;
2934 typedef struct _closed_pipes*  pXpipe;
2935
2936 struct _closed_pipes {
2937     int             pid;            /* PID of subprocess */
2938     unsigned long   completion;     /* termination status of subprocess */
2939 };
2940 #define NKEEPCLOSED 50
2941 static Xpipe closed_list[NKEEPCLOSED];
2942 static int   closed_index = 0;
2943 static int   closed_num = 0;
2944
2945 #define RETRY_DELAY     "0 ::0.20"
2946 #define MAX_RETRY              50
2947
2948 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2949 static unsigned long mypid;
2950 static unsigned long delaytime[2];
2951
2952 static pInfo open_pipes = NULL;
2953 static $DESCRIPTOR(nl_desc, "NL:");
2954
2955 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2956
2957
2958
2959 static unsigned long int
2960 pipe_exit_routine(void)
2961 {
2962     pInfo info;
2963     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2964     int sts, did_stuff, j;
2965
2966    /*
2967     * Flush any pending i/o, but since we are in process run-down, be
2968     * careful about referencing PerlIO structures that may already have
2969     * been deallocated.  We may not even have an interpreter anymore.
2970     */
2971     info = open_pipes;
2972     while (info) {
2973         if (info->fp) {
2974 #if defined(PERL_IMPLICIT_CONTEXT)
2975            /* We need to use the Perl context of the thread that created */
2976            /* the pipe. */
2977            pTHX;
2978            if (info->err)
2979                aTHX = info->err->thx;
2980            else if (info->out)
2981                aTHX = info->out->thx;
2982            else if (info->in)
2983                aTHX = info->in->thx;
2984 #endif
2985            if (!info->useFILE
2986 #if defined(USE_ITHREADS)
2987              && my_perl
2988 #endif
2989 #ifdef USE_PERLIO
2990              && PL_perlio_fd_refcnt
2991 #endif
2992               )
2993                PerlIO_flush(info->fp);
2994            else
2995                fflush((FILE *)info->fp);
2996         }
2997         info = info->next;
2998     }
2999
3000     /*
3001      next we try sending an EOF...ignore if doesn't work, make sure we
3002      don't hang
3003     */
3004     did_stuff = 0;
3005     info = open_pipes;
3006
3007     while (info) {
3008       _ckvmssts_noperl(sys$setast(0));
3009       if (info->in && !info->in->shut_on_empty) {
3010         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3011                                  0, 0, 0, 0, 0, 0));
3012         info->waiting = 1;
3013         did_stuff = 1;
3014       }
3015       _ckvmssts_noperl(sys$setast(1));
3016       info = info->next;
3017     }
3018
3019     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3020
3021     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3022         int nwait = 0;
3023
3024         info = open_pipes;
3025         while (info) {
3026           _ckvmssts_noperl(sys$setast(0));
3027           if (info->waiting && info->done)
3028                 info->waiting = 0;
3029           nwait += info->waiting;
3030           _ckvmssts_noperl(sys$setast(1));
3031           info = info->next;
3032         }
3033         if (!nwait) break;
3034         sleep(1);
3035     }
3036
3037     did_stuff = 0;
3038     info = open_pipes;
3039     while (info) {
3040       _ckvmssts_noperl(sys$setast(0));
3041       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3042         sts = sys$forcex(&info->pid,0,&abort);
3043         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3044         did_stuff = 1;
3045       }
3046       _ckvmssts_noperl(sys$setast(1));
3047       info = info->next;
3048     }
3049
3050     /* again, wait for effect */
3051
3052     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3053         int nwait = 0;
3054
3055         info = open_pipes;
3056         while (info) {
3057           _ckvmssts_noperl(sys$setast(0));
3058           if (info->waiting && info->done)
3059                 info->waiting = 0;
3060           nwait += info->waiting;
3061           _ckvmssts_noperl(sys$setast(1));
3062           info = info->next;
3063         }
3064         if (!nwait) break;
3065         sleep(1);
3066     }
3067
3068     info = open_pipes;
3069     while (info) {
3070       _ckvmssts_noperl(sys$setast(0));
3071       if (!info->done) {  /* We tried to be nice . . . */
3072         sts = sys$delprc(&info->pid,0);
3073         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3074         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3075       }
3076       _ckvmssts_noperl(sys$setast(1));
3077       info = info->next;
3078     }
3079
3080     while(open_pipes) {
3081
3082 #if defined(PERL_IMPLICIT_CONTEXT)
3083       /* We need to use the Perl context of the thread that created */
3084       /* the pipe. */
3085       pTHX;
3086       if (open_pipes->err)
3087           aTHX = open_pipes->err->thx;
3088       else if (open_pipes->out)
3089           aTHX = open_pipes->out->thx;
3090       else if (open_pipes->in)
3091           aTHX = open_pipes->in->thx;
3092 #endif
3093       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3094       else if (!(sts & 1)) retsts = sts;
3095     }
3096     return retsts;
3097 }
3098
3099 static struct exit_control_block pipe_exitblock =
3100        {(struct exit_control_block *) 0,
3101         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3102
3103 static void pipe_mbxtofd_ast(pPipe p);
3104 static void pipe_tochild1_ast(pPipe p);
3105 static void pipe_tochild2_ast(pPipe p);
3106
3107 static void
3108 popen_completion_ast(pInfo info)
3109 {
3110   pInfo i = open_pipes;
3111   int iss;
3112
3113   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3114   closed_list[closed_index].pid = info->pid;
3115   closed_list[closed_index].completion = info->completion;
3116   closed_index++;
3117   if (closed_index == NKEEPCLOSED)
3118     closed_index = 0;
3119   closed_num++;
3120
3121   while (i) {
3122     if (i == info) break;
3123     i = i->next;
3124   }
3125   if (!i) return;       /* unlinked, probably freed too */
3126
3127   info->done = TRUE;
3128
3129 /*
3130     Writing to subprocess ...
3131             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3132
3133             chan_out may be waiting for "done" flag, or hung waiting
3134             for i/o completion to child...cancel the i/o.  This will
3135             put it into "snarf mode" (done but no EOF yet) that discards
3136             input.
3137
3138     Output from subprocess (stdout, stderr) needs to be flushed and
3139     shut down.   We try sending an EOF, but if the mbx is full the pipe
3140     routine should still catch the "shut_on_empty" flag, telling it to
3141     use immediate-style reads so that "mbx empty" -> EOF.
3142
3143
3144 */
3145   if (info->in && !info->in_done) {               /* only for mode=w */
3146         if (info->in->shut_on_empty && info->in->need_wake) {
3147             info->in->need_wake = FALSE;
3148             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3149         } else {
3150             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3151         }
3152   }
3153
3154   if (info->out && !info->out_done) {             /* were we also piping output? */
3155       info->out->shut_on_empty = TRUE;
3156       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3157       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3158       _ckvmssts_noperl(iss);
3159   }
3160
3161   if (info->err && !info->err_done) {        /* we were piping stderr */
3162         info->err->shut_on_empty = TRUE;
3163         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3164         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3165         _ckvmssts_noperl(iss);
3166   }
3167   _ckvmssts_noperl(sys$setef(pipe_ef));
3168
3169 }
3170
3171 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3172 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3173 static void pipe_infromchild_ast(pPipe p);
3174
3175 /*
3176     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3177     inside an AST routine without worrying about reentrancy and which Perl
3178     memory allocator is being used.
3179
3180     We read data and queue up the buffers, then spit them out one at a
3181     time to the output mailbox when the output mailbox is ready for one.
3182
3183 */
3184 #define INITIAL_TOCHILDQUEUE  2
3185
3186 static pPipe
3187 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3188 {
3189     pPipe p;
3190     pCBuf b;
3191     char mbx1[64], mbx2[64];
3192     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3193                                       DSC$K_CLASS_S, mbx1},
3194                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3195                                       DSC$K_CLASS_S, mbx2};
3196     unsigned int dviitm = DVI$_DEVBUFSIZ;
3197     int j, n;
3198
3199     n = sizeof(Pipe);
3200     _ckvmssts_noperl(lib$get_vm(&n, &p));
3201
3202     create_mbx(&p->chan_in , &d_mbx1);
3203     create_mbx(&p->chan_out, &d_mbx2);
3204     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3205
3206     p->buf           = 0;
3207     p->shut_on_empty = FALSE;
3208     p->need_wake     = FALSE;
3209     p->type          = 0;
3210     p->retry         = 0;
3211     p->iosb.status   = SS$_NORMAL;
3212     p->iosb2.status  = SS$_NORMAL;
3213     p->free          = RQE_ZERO;
3214     p->wait          = RQE_ZERO;
3215     p->curr          = 0;
3216     p->curr2         = 0;
3217     p->info          = 0;
3218 #ifdef PERL_IMPLICIT_CONTEXT
3219     p->thx           = aTHX;
3220 #endif
3221
3222     n = sizeof(CBuf) + p->bufsize;
3223
3224     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3225         _ckvmssts_noperl(lib$get_vm(&n, &b));
3226         b->buf = (char *) b + sizeof(CBuf);
3227         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3228     }
3229
3230     pipe_tochild2_ast(p);
3231     pipe_tochild1_ast(p);
3232     strcpy(wmbx, mbx1);
3233     strcpy(rmbx, mbx2);
3234     return p;
3235 }
3236
3237 /*  reads the MBX Perl is writing, and queues */
3238
3239 static void
3240 pipe_tochild1_ast(pPipe p)
3241 {
3242     pCBuf b = p->curr;
3243     int iss = p->iosb.status;
3244     int eof = (iss == SS$_ENDOFFILE);
3245     int sts;
3246 #ifdef PERL_IMPLICIT_CONTEXT
3247     pTHX = p->thx;
3248 #endif
3249
3250     if (p->retry) {
3251         if (eof) {
3252             p->shut_on_empty = TRUE;
3253             b->eof     = TRUE;
3254             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3255         } else  {
3256             _ckvmssts_noperl(iss);
3257         }
3258
3259         b->eof  = eof;
3260         b->size = p->iosb.count;
3261         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3262         if (p->need_wake) {
3263             p->need_wake = FALSE;
3264             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3265         }
3266     } else {
3267         p->retry = 1;   /* initial call */
3268     }
3269
3270     if (eof) {                  /* flush the free queue, return when done */
3271         int n = sizeof(CBuf) + p->bufsize;
3272         while (1) {
3273             iss = lib$remqti(&p->free, &b);
3274             if (iss == LIB$_QUEWASEMP) return;
3275             _ckvmssts_noperl(iss);
3276             _ckvmssts_noperl(lib$free_vm(&n, &b));
3277         }
3278     }
3279
3280     iss = lib$remqti(&p->free, &b);
3281     if (iss == LIB$_QUEWASEMP) {
3282         int n = sizeof(CBuf) + p->bufsize;
3283         _ckvmssts_noperl(lib$get_vm(&n, &b));
3284         b->buf = (char *) b + sizeof(CBuf);
3285     } else {
3286        _ckvmssts_noperl(iss);
3287     }
3288
3289     p->curr = b;
3290     iss = sys$qio(0,p->chan_in,
3291              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3292              &p->iosb,
3293              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3294     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3295     _ckvmssts_noperl(iss);
3296 }
3297
3298
3299 /* writes queued buffers to output, waits for each to complete before
3300    doing the next */
3301
3302 static void
3303 pipe_tochild2_ast(pPipe p)
3304 {
3305     pCBuf b = p->curr2;
3306     int iss = p->iosb2.status;
3307     int n = sizeof(CBuf) + p->bufsize;
3308     int done = (p->info && p->info->done) ||
3309               iss == SS$_CANCEL || iss == SS$_ABORT;
3310 #if defined(PERL_IMPLICIT_CONTEXT)
3311     pTHX = p->thx;
3312 #endif
3313
3314     do {
3315         if (p->type) {         /* type=1 has old buffer, dispose */
3316             if (p->shut_on_empty) {
3317                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3318             } else {
3319                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3320             }
3321             p->type = 0;
3322         }
3323
3324         iss = lib$remqti(&p->wait, &b);
3325         if (iss == LIB$_QUEWASEMP) {
3326             if (p->shut_on_empty) {
3327                 if (done) {
3328                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3329                     *p->pipe_done = TRUE;
3330                     _ckvmssts_noperl(sys$setef(pipe_ef));
3331                 } else {
3332                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3333                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3334                 }
3335                 return;
3336             }
3337             p->need_wake = TRUE;
3338             return;
3339         }
3340         _ckvmssts_noperl(iss);
3341         p->type = 1;
3342     } while (done);
3343
3344
3345     p->curr2 = b;
3346     if (b->eof) {
3347         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3348             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3349     } else {
3350         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3351             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3352     }
3353
3354     return;
3355
3356 }
3357
3358
3359 static pPipe
3360 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3361 {
3362     pPipe p;
3363     char mbx1[64], mbx2[64];
3364     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3365                                       DSC$K_CLASS_S, mbx1},
3366                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3367                                       DSC$K_CLASS_S, mbx2};
3368     unsigned int dviitm = DVI$_DEVBUFSIZ;
3369
3370     int n = sizeof(Pipe);
3371     _ckvmssts_noperl(lib$get_vm(&n, &p));
3372     create_mbx(&p->chan_in , &d_mbx1);
3373     create_mbx(&p->chan_out, &d_mbx2);
3374
3375     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3376     n = p->bufsize * sizeof(char);
3377     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3378     p->shut_on_empty = FALSE;
3379     p->info   = 0;
3380     p->type   = 0;
3381     p->iosb.status = SS$_NORMAL;
3382 #if defined(PERL_IMPLICIT_CONTEXT)
3383     p->thx = aTHX;
3384 #endif
3385     pipe_infromchild_ast(p);
3386
3387     strcpy(wmbx, mbx1);
3388     strcpy(rmbx, mbx2);
3389     return p;
3390 }
3391
3392 static void
3393 pipe_infromchild_ast(pPipe p)
3394 {
3395     int iss = p->iosb.status;
3396     int eof = (iss == SS$_ENDOFFILE);
3397     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3398     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3399 #if defined(PERL_IMPLICIT_CONTEXT)
3400     pTHX = p->thx;
3401 #endif
3402
3403     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3404         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3405         p->chan_out = 0;
3406     }
3407
3408     /* read completed:
3409             input shutdown if EOF from self (done or shut_on_empty)
3410             output shutdown if closing flag set (my_pclose)
3411             send data/eof from child or eof from self
3412             otherwise, re-read (snarf of data from child)
3413     */
3414
3415     if (p->type == 1) {
3416         p->type = 0;
3417         if (myeof && p->chan_in) {                  /* input shutdown */
3418             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3419             p->chan_in = 0;
3420         }
3421
3422         if (p->chan_out) {
3423             if (myeof || kideof) {      /* pass EOF to parent */
3424                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3425                                          pipe_infromchild_ast, p,
3426                                          0, 0, 0, 0, 0, 0));
3427                 return;
3428             } else if (eof) {       /* eat EOF --- fall through to read*/
3429
3430             } else {                /* transmit data */
3431                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3432                                          pipe_infromchild_ast,p,
3433                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3434                 return;
3435             }
3436         }
3437     }
3438
3439     /*  everything shut? flag as done */
3440
3441     if (!p->chan_in && !p->chan_out) {
3442         *p->pipe_done = TRUE;
3443         _ckvmssts_noperl(sys$setef(pipe_ef));
3444         return;
3445     }
3446
3447     /* write completed (or read, if snarfing from child)
3448             if still have input active,
3449                queue read...immediate mode if shut_on_empty so we get EOF if empty
3450             otherwise,
3451                check if Perl reading, generate EOFs as needed
3452     */
3453
3454     if (p->type == 0) {
3455         p->type = 1;
3456         if (p->chan_in) {
3457             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3458                           pipe_infromchild_ast,p,
3459                           p->buf, p->bufsize, 0, 0, 0, 0);
3460             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3461             _ckvmssts_noperl(iss);
3462         } else {           /* send EOFs for extra reads */
3463             p->iosb.status = SS$_ENDOFFILE;
3464             p->iosb.dvispec = 0;
3465             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3466                                      0, 0, 0,
3467                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3468         }
3469     }
3470 }
3471
3472 static pPipe
3473 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3474 {
3475     pPipe p;
3476     char mbx[64];
3477     unsigned long dviitm = DVI$_DEVBUFSIZ;
3478     struct stat s;
3479     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3480                                       DSC$K_CLASS_S, mbx};
3481     int n = sizeof(Pipe);
3482
3483     /* things like terminals and mbx's don't need this filter */
3484     if (fd && fstat(fd,&s) == 0) {
3485         unsigned long devchar;
3486         char device[65];
3487         unsigned short dev_len;
3488         struct dsc$descriptor_s d_dev;
3489         char * cptr;
3490         struct item_list_3 items[3];
3491         int status;
3492         unsigned short dvi_iosb[4];
3493
3494         cptr = getname(fd, out, 1);
3495         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3496         d_dev.dsc$a_pointer = out;
3497         d_dev.dsc$w_length = strlen(out);
3498         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3499         d_dev.dsc$b_class = DSC$K_CLASS_S;
3500
3501         items[0].len = 4;
3502         items[0].code = DVI$_DEVCHAR;
3503         items[0].bufadr = &devchar;
3504         items[0].retadr = NULL;
3505         items[1].len = 64;
3506         items[1].code = DVI$_FULLDEVNAM;
3507         items[1].bufadr = device;
3508         items[1].retadr = &dev_len;
3509         items[2].len = 0;
3510         items[2].code = 0;
3511
3512         status = sys$getdviw
3513                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3514         _ckvmssts_noperl(status);
3515         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3516             device[dev_len] = 0;
3517
3518             if (!(devchar & DEV$M_DIR)) {
3519                 strcpy(out, device);
3520                 return 0;
3521             }
3522         }
3523     }
3524
3525     _ckvmssts_noperl(lib$get_vm(&n, &p));
3526     p->fd_out = dup(fd);
3527     create_mbx(&p->chan_in, &d_mbx);
3528     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3529     n = (p->bufsize+1) * sizeof(char);
3530     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3531     p->shut_on_empty = FALSE;
3532     p->retry = 0;
3533     p->info  = 0;
3534     strcpy(out, mbx);
3535
3536     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3537                              pipe_mbxtofd_ast, p,
3538                              p->buf, p->bufsize, 0, 0, 0, 0));
3539
3540     return p;
3541 }
3542
3543 static void
3544 pipe_mbxtofd_ast(pPipe p)
3545 {
3546     int iss = p->iosb.status;
3547     int done = p->info->done;
3548     int iss2;
3549     int eof = (iss == SS$_ENDOFFILE);
3550     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3551     int err = !(iss&1) && !eof;
3552 #if defined(PERL_IMPLICIT_CONTEXT)
3553     pTHX = p->thx;
3554 #endif
3555
3556     if (done && myeof) {               /* end piping */
3557         close(p->fd_out);
3558         sys$dassgn(p->chan_in);
3559         *p->pipe_done = TRUE;
3560         _ckvmssts_noperl(sys$setef(pipe_ef));
3561         return;
3562     }
3563
3564     if (!err && !eof) {             /* good data to send to file */
3565         p->buf[p->iosb.count] = '\n';
3566         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3567         if (iss2 < 0) {
3568             p->retry++;
3569             if (p->retry < MAX_RETRY) {
3570                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3571                 return;
3572             }
3573         }
3574         p->retry = 0;
3575     } else if (err) {
3576         _ckvmssts_noperl(iss);
3577     }
3578
3579
3580     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3581           pipe_mbxtofd_ast, p,
3582           p->buf, p->bufsize, 0, 0, 0, 0);
3583     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3584     _ckvmssts_noperl(iss);
3585 }
3586
3587
3588 typedef struct _pipeloc     PLOC;
3589 typedef struct _pipeloc*   pPLOC;
3590
3591 struct _pipeloc {
3592     pPLOC   next;
3593     char    dir[NAM$C_MAXRSS+1];
3594 };
3595 static pPLOC  head_PLOC = 0;
3596
3597 void
3598 free_pipelocs(pTHX_ void *head)
3599 {
3600     pPLOC p, pnext;
3601     pPLOC *pHead = (pPLOC *)head;
3602
3603     p = *pHead;
3604     while (p) {
3605         pnext = p->next;
3606         PerlMem_free(p);
3607         p = pnext;
3608     }
3609     *pHead = 0;
3610 }
3611
3612 static void
3613 store_pipelocs(pTHX)
3614 {
3615     int    i;
3616     pPLOC  p;
3617     AV    *av = 0;
3618     SV    *dirsv;
3619     char  *dir, *x;
3620     char  *unixdir;
3621     char  temp[NAM$C_MAXRSS+1];
3622     STRLEN n_a;
3623
3624     if (head_PLOC)
3625         free_pipelocs(aTHX_ &head_PLOC);
3626
3627 /*  the . directory from @INC comes last */
3628
3629     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3630     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3631     p->next = head_PLOC;
3632     head_PLOC = p;
3633     strcpy(p->dir,"./");
3634
3635 /*  get the directory from $^X */
3636
3637     unixdir = PerlMem_malloc(VMS_MAXRSS);
3638     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3639
3640 #ifdef PERL_IMPLICIT_CONTEXT
3641     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3642 #else
3643     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3644 #endif
3645         strcpy(temp, PL_origargv[0]);
3646         x = strrchr(temp,']');
3647         if (x == NULL) {
3648         x = strrchr(temp,'>');
3649           if (x == NULL) {
3650             /* It could be a UNIX path */
3651             x = strrchr(temp,'/');
3652           }
3653         }
3654         if (x)
3655           x[1] = '\0';
3656         else {
3657           /* Got a bare name, so use default directory */
3658           temp[0] = '.';
3659           temp[1] = '\0';
3660         }
3661
3662         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3663             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3664             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3665             p->next = head_PLOC;
3666             head_PLOC = p;
3667             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3668             p->dir[NAM$C_MAXRSS] = '\0';
3669         }
3670     }
3671
3672 /*  reverse order of @INC entries, skip "." since entered above */
3673
3674 #ifdef PERL_IMPLICIT_CONTEXT
3675     if (aTHX)
3676 #endif
3677     if (PL_incgv) av = GvAVn(PL_incgv);
3678
3679     for (i = 0; av && i <= AvFILL(av); i++) {
3680         dirsv = *av_fetch(av,i,TRUE);
3681
3682         if (SvROK(dirsv)) continue;
3683         dir = SvPVx(dirsv,n_a);
3684         if (strcmp(dir,".") == 0) continue;
3685         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3686             continue;
3687
3688         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3689         p->next = head_PLOC;
3690         head_PLOC = p;
3691         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3692         p->dir[NAM$C_MAXRSS] = '\0';
3693     }
3694
3695 /* most likely spot (ARCHLIB) put first in the list */
3696
3697 #ifdef ARCHLIB_EXP
3698     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3699         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3700         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3701         p->next = head_PLOC;
3702         head_PLOC = p;
3703         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3704         p->dir[NAM$C_MAXRSS] = '\0';
3705     }
3706 #endif
3707     PerlMem_free(unixdir);
3708 }
3709
3710 static I32
3711 Perl_cando_by_name_int
3712    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3713 #if !defined(PERL_IMPLICIT_CONTEXT)
3714 #define cando_by_name_int               Perl_cando_by_name_int
3715 #else
3716 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3717 #endif
3718
3719 static char *
3720 find_vmspipe(pTHX)
3721 {
3722     static int   vmspipe_file_status = 0;
3723     static char  vmspipe_file[NAM$C_MAXRSS+1];
3724
3725     /* already found? Check and use ... need read+execute permission */
3726
3727     if (vmspipe_file_status == 1) {
3728         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3729          && cando_by_name_int
3730            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3731             return vmspipe_file;
3732         }
3733         vmspipe_file_status = 0;
3734     }
3735
3736     /* scan through stored @INC, $^X */
3737
3738     if (vmspipe_file_status == 0) {
3739         char file[NAM$C_MAXRSS+1];
3740         pPLOC  p = head_PLOC;
3741
3742         while (p) {
3743             char * exp_res;
3744             int dirlen;
3745             strcpy(file, p->dir);
3746             dirlen = strlen(file);
3747             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3748             file[NAM$C_MAXRSS] = '\0';
3749             p = p->next;
3750
3751             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3752             if (!exp_res) continue;
3753
3754             if (cando_by_name_int
3755                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3756              && cando_by_name_int
3757                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3758                 vmspipe_file_status = 1;
3759                 return vmspipe_file;
3760             }
3761         }
3762         vmspipe_file_status = -1;   /* failed, use tempfiles */
3763     }
3764
3765     return 0;
3766 }
3767
3768 static FILE *
3769 vmspipe_tempfile(pTHX)
3770 {
3771     char file[NAM$C_MAXRSS+1];
3772     FILE *fp;
3773     static int index = 0;
3774     Stat_t s0, s1;
3775     int cmp_result;
3776
3777     /* create a tempfile */
3778
3779     /* we can't go from   W, shr=get to  R, shr=get without
3780        an intermediate vulnerable state, so don't bother trying...
3781
3782        and lib$spawn doesn't shr=put, so have to close the write
3783
3784        So... match up the creation date/time and the FID to
3785        make sure we're dealing with the same file
3786
3787     */
3788
3789     index++;
3790     if (!decc_filename_unix_only) {
3791       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3792       fp = fopen(file,"w");
3793       if (!fp) {
3794         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3795         fp = fopen(file,"w");
3796         if (!fp) {
3797             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3798             fp = fopen(file,"w");
3799         }
3800       }
3801      }
3802      else {
3803       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3804       fp = fopen(file,"w");
3805       if (!fp) {
3806         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3807         fp = fopen(file,"w");
3808         if (!fp) {
3809           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3810           fp = fopen(file,"w");
3811         }
3812       }
3813     }
3814     if (!fp) return 0;  /* we're hosed */
3815
3816     fprintf(fp,"$! 'f$verify(0)'\n");
3817     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3818     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3819     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3820     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3821     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3822     fprintf(fp,"$ perl_del    = \"delete\"\n");
3823     fprintf(fp,"$ pif         = \"if\"\n");
3824     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3825     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3826     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3827     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3828     fprintf(fp,"$!  --- build command line to get max possible length\n");
3829     fprintf(fp,"$c=perl_popen_cmd0\n");
3830     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3831     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3832     fprintf(fp,"$x=perl_popen_cmd3\n");
3833     fprintf(fp,"$c=c+x\n");
3834     fprintf(fp,"$ perl_on\n");
3835     fprintf(fp,"$ 'c'\n");
3836     fprintf(fp,"$ perl_status = $STATUS\n");
3837     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3838     fprintf(fp,"$ perl_exit 'perl_status'\n");
3839     fsync(fileno(fp));
3840
3841     fgetname(fp, file, 1);
3842     fstat(fileno(fp), &s0.crtl_stat);
3843     fclose(fp);
3844
3845     if (decc_filename_unix_only)
3846         int_tounixspec(file, file, NULL);
3847     fp = fopen(file,"r","shr=get");
3848     if (!fp) return 0;
3849     fstat(fileno(fp), &s1.crtl_stat);
3850
3851     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3852     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3853         fclose(fp);
3854         return 0;
3855     }
3856
3857     return fp;
3858 }
3859
3860
3861 static int vms_is_syscommand_xterm(void)
3862 {
3863     const static struct dsc$descriptor_s syscommand_dsc =
3864       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3865
3866     const static struct dsc$descriptor_s decwdisplay_dsc =
3867       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3868
3869     struct item_list_3 items[2];
3870     unsigned short dvi_iosb[4];
3871     unsigned long devchar;
3872     unsigned long devclass;
3873     int status;
3874
3875     /* Very simple check to guess if sys$command is a decterm? */
3876     /* First see if the DECW$DISPLAY: device exists */
3877     items[0].len = 4;
3878     items[0].code = DVI$_DEVCHAR;
3879     items[0].bufadr = &devchar;
3880     items[0].retadr = NULL;
3881     items[1].len = 0;
3882     items[1].code = 0;
3883
3884     status = sys$getdviw
3885         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3886
3887     if ($VMS_STATUS_SUCCESS(status)) {
3888         status = dvi_iosb[0];
3889     }
3890
3891     if (!$VMS_STATUS_SUCCESS(status)) {
3892         SETERRNO(EVMSERR, status);
3893         return -1;
3894     }
3895
3896     /* If it does, then for now assume that we are on a workstation */
3897     /* Now verify that SYS$COMMAND is a terminal */
3898     /* for creating the debugger DECTerm */
3899
3900     items[0].len = 4;
3901     items[0].code = DVI$_DEVCLASS;
3902     items[0].bufadr = &devclass;
3903     items[0].retadr = NULL;
3904     items[1].len = 0;
3905     items[1].code = 0;
3906
3907     status = sys$getdviw
3908         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3909
3910     if ($VMS_STATUS_SUCCESS(status)) {
3911         status = dvi_iosb[0];
3912     }
3913
3914     if (!$VMS_STATUS_SUCCESS(status)) {
3915         SETERRNO(EVMSERR, status);
3916         return -1;
3917     }
3918     else {
3919         if (devclass == DC$_TERM) {
3920             return 0;
3921         }
3922     }
3923     return -1;
3924 }
3925
3926 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3927 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3928 {
3929     int status;
3930     int ret_stat;
3931     char * ret_char;
3932     char device_name[65];
3933     unsigned short device_name_len;
3934     struct dsc$descriptor_s customization_dsc;
3935     struct dsc$descriptor_s device_name_dsc;
3936     const char * cptr;
3937     char customization[200];
3938     char title[40];
3939     pInfo info = NULL;
3940     char mbx1[64];
3941     unsigned short p_chan;
3942     int n;
3943     unsigned short iosb[4];
3944     const char * cust_str =
3945         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3946     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3947                                           DSC$K_CLASS_S, mbx1};
3948
3949      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3950     /*---------------------------------------*/
3951     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3952
3953
3954     /* Make sure that this is from the Perl debugger */
3955     ret_char = strstr(cmd," xterm ");
3956     if (ret_char == NULL)
3957         return NULL;
3958     cptr = ret_char + 7;
3959     ret_char = strstr(cmd,"tty");
3960     if (ret_char == NULL)
3961         return NULL;
3962     ret_char = strstr(cmd,"sleep");
3963     if (ret_char == NULL)
3964         return NULL;
3965
3966     if (decw_term_port == 0) {
3967         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3968         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3969         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3970
3971        status = lib$find_image_symbol
3972                                (&filename1_dsc,
3973                                 &decw_term_port_dsc,
3974                                 (void *)&decw_term_port,
3975                                 NULL,
3976                                 0);
3977
3978         /* Try again with the other image name */
3979         if (!$VMS_STATUS_SUCCESS(status)) {
3980
3981            status = lib$find_image_symbol
3982                                (&filename2_dsc,
3983                                 &decw_term_port_dsc,
3984                                 (void *)&decw_term_port,
3985                                 NULL,
3986                                 0);
3987
3988         }
3989
3990     }
3991
3992
3993     /* No decw$term_port, give it up */
3994     if (!$VMS_STATUS_SUCCESS(status))
3995         return NULL;
3996
3997     /* Are we on a workstation? */
3998     /* to do: capture the rows / columns and pass their properties */
3999     ret_stat = vms_is_syscommand_xterm();
4000     if (ret_stat < 0)
4001         return NULL;
4002
4003     /* Make the title: */
4004     ret_char = strstr(cptr,"-title");
4005     if (ret_char != NULL) {
4006         while ((*cptr != 0) && (*cptr != '\"')) {
4007             cptr++;
4008         }
4009         if (*cptr == '\"')
4010             cptr++;
4011         n = 0;
4012         while ((*cptr != 0) && (*cptr != '\"')) {
4013             title[n] = *cptr;
4014             n++;
4015             if (n == 39) {
4016                 title[39] = 0;
4017                 break;
4018             }
4019             cptr++;
4020         }
4021         title[n] = 0;
4022     }
4023     else {
4024             /* Default title */
4025             strcpy(title,"Perl Debug DECTerm");
4026     }
4027     sprintf(customization, cust_str, title);
4028
4029     customization_dsc.dsc$a_pointer = customization;
4030     customization_dsc.dsc$w_length = strlen(customization);
4031     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4032     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4033
4034     device_name_dsc.dsc$a_pointer = device_name;
4035     device_name_dsc.dsc$w_length = sizeof device_name -1;
4036     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4037     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4038
4039     device_name_len = 0;
4040
4041     /* Try to create the window */
4042      status = (*decw_term_port)
4043        (NULL,
4044         NULL,
4045         &customization_dsc,
4046         &device_name_dsc,
4047         &device_name_len,
4048         NULL,
4049         NULL,
4050         NULL);
4051     if (!$VMS_STATUS_SUCCESS(status)) {
4052         SETERRNO(EVMSERR, status);
4053         return NULL;
4054     }
4055
4056     device_name[device_name_len] = '\0';
4057
4058     /* Need to set this up to look like a pipe for cleanup */
4059     n = sizeof(Info);
4060     status = lib$get_vm(&n, &info);
4061     if (!$VMS_STATUS_SUCCESS(status)) {
4062         SETERRNO(ENOMEM, status);
4063         return NULL;
4064     }
4065
4066     info->mode = *mode;
4067     info->done = FALSE;
4068     info->completion = 0;
4069     info->closing    = FALSE;
4070     info->in         = 0;
4071     info->out        = 0;
4072     info->err        = 0;
4073     info->fp         = NULL;
4074     info->useFILE    = 0;
4075     info->waiting    = 0;
4076     info->in_done    = TRUE;
4077     info->out_done   = TRUE;
4078     info->err_done   = TRUE;
4079
4080     /* Assign a channel on this so that it will persist, and not login */
4081     /* We stash this channel in the info structure for reference. */
4082     /* The created xterm self destructs when the last channel is removed */
4083     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4084     /* So leave this assigned. */
4085     device_name_dsc.dsc$w_length = device_name_len;
4086     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4087     if (!$VMS_STATUS_SUCCESS(status)) {
4088         SETERRNO(EVMSERR, status);
4089         return NULL;
4090     }
4091     info->xchan_valid = 1;
4092
4093     /* Now create a mailbox to be read by the application */
4094
4095     create_mbx(&p_chan, &d_mbx1);
4096
4097     /* write the name of the created terminal to the mailbox */
4098     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4099             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4100
4101     if (!$VMS_STATUS_SUCCESS(status)) {
4102         SETERRNO(EVMSERR, status);
4103         return NULL;
4104     }
4105
4106     info->fp  = PerlIO_open(mbx1, mode);
4107
4108     /* Done with this channel */
4109     sys$dassgn(p_chan);
4110
4111     /* If any errors, then clean up */
4112     if (!info->fp) {
4113         n = sizeof(Info);
4114         _ckvmssts_noperl(lib$free_vm(&n, &info));
4115         return NULL;
4116         }
4117
4118     /* All done */
4119     return info->fp;
4120 }
4121
4122 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4123
4124 static PerlIO *
4125 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4126 {
4127     static int handler_set_up = FALSE;
4128     PerlIO * ret_fp;
4129     unsigned long int sts, flags = CLI$M_NOWAIT;
4130     /* The use of a GLOBAL table (as was done previously) rendered
4131      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4132      * environment.  Hence we've switched to LOCAL symbol table.
4133      */
4134     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4135     int j, wait = 0, n;
4136     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4137     char *in, *out, *err, mbx[512];
4138     FILE *tpipe = 0;
4139     char tfilebuf[NAM$C_MAXRSS+1];
4140     pInfo info = NULL;
4141     char cmd_sym_name[20];
4142     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4143                                       DSC$K_CLASS_S, symbol};
4144     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4145                                       DSC$K_CLASS_S, 0};
4146     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4147                                       DSC$K_CLASS_S, cmd_sym_name};
4148     struct dsc$descriptor_s *vmscmd;
4149     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4150     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4151     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4152
4153     /* Check here for Xterm create request.  This means looking for
4154      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4155      *  is possible to create an xterm.
4156      */
4157     if (*in_mode == 'r') {
4158         PerlIO * xterm_fd;
4159
4160 #if defined(PERL_IMPLICIT_CONTEXT)
4161         /* Can not fork an xterm with a NULL context */
4162         /* This probably could never happen */
4163         xterm_fd = NULL;
4164         if (aTHX != NULL)
4165 #endif
4166         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4167         if (xterm_fd != NULL)
4168             return xterm_fd;
4169     }
4170
4171     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4172
4173     /* once-per-program initialization...
4174        note that the SETAST calls and the dual test of pipe_ef
4175        makes sure that only the FIRST thread through here does
4176        the initialization...all other threads wait until it's
4177        done.
4178
4179        Yeah, uglier than a pthread call, it's got all the stuff inline
4180        rather than in a separate routine.
4181     */
4182
4183     if (!pipe_ef) {
4184         _ckvmssts_noperl(sys$setast(0));
4185         if (!pipe_ef) {
4186             unsigned long int pidcode = JPI$_PID;
4187             $DESCRIPTOR(d_delay, RETRY_DELAY);
4188             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4189             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4190             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4191         }
4192         if (!handler_set_up) {
4193           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4194           handler_set_up = TRUE;
4195         }
4196         _ckvmssts_noperl(sys$setast(1));
4197     }
4198
4199     /* see if we can find a VMSPIPE.COM */
4200
4201     tfilebuf[0] = '@';
4202     vmspipe = find_vmspipe(aTHX);
4203     if (vmspipe) {
4204         strcpy(tfilebuf+1,vmspipe);
4205     } else {        /* uh, oh...we're in tempfile hell */
4206         tpipe = vmspipe_tempfile(aTHX);
4207         if (!tpipe) {       /* a fish popular in Boston */
4208             if (ckWARN(WARN_PIPE)) {
4209                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4210             }
4211         return NULL;
4212         }
4213         fgetname(tpipe,tfilebuf+1,1);
4214     }
4215     vmspipedsc.dsc$a_pointer = tfilebuf;
4216     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4217
4218     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4219     if (!(sts & 1)) {
4220       switch (sts) {
4221         case RMS$_FNF:  case RMS$_DNF:
4222           set_errno(ENOENT); break;
4223         case RMS$_DIR:
4224           set_errno(ENOTDIR); break;
4225         case RMS$_DEV:
4226           set_errno(ENODEV); break;
4227         case RMS$_PRV:
4228           set_errno(EACCES); break;
4229         case RMS$_SYN:
4230           set_errno(EINVAL); break;
4231         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4232           set_errno(E2BIG); break;
4233         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4234           _ckvmssts_noperl(sts); /* fall through */
4235         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4236           set_errno(EVMSERR);
4237       }
4238       set_vaxc_errno(sts);
4239       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4240         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4241       }
4242       *psts = sts;
4243       return NULL;
4244     }
4245     n = sizeof(Info);
4246     _ckvmssts_noperl(lib$get_vm(&n, &info));
4247
4248     strcpy(mode,in_mode);
4249     info->mode = *mode;
4250     info->done = FALSE;
4251     info->completion = 0;
4252     info->closing    = FALSE;
4253     info->in         = 0;
4254     info->out        = 0;
4255     info->err        = 0;
4256     info->fp         = NULL;
4257     info->useFILE    = 0;
4258     info->waiting    = 0;
4259     info->in_done    = TRUE;
4260     info->out_done   = TRUE;
4261     info->err_done   = TRUE;
4262     info->xchan      = 0;
4263     info->xchan_valid = 0;
4264
4265     in = PerlMem_malloc(VMS_MAXRSS);
4266     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4267     out = PerlMem_malloc(VMS_MAXRSS);
4268     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4269     err = PerlMem_malloc(VMS_MAXRSS);
4270     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4271
4272     in[0] = out[0] = err[0] = '\0';
4273
4274     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4275         info->useFILE = 1;
4276         strcpy(p,p+1);
4277     }
4278     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4279         wait = 1;
4280         strcpy(p,p+1);
4281     }
4282
4283     if (*mode == 'r') {             /* piping from subroutine */
4284
4285         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4286         if (info->out) {
4287             info->out->pipe_done = &info->out_done;
4288             info->out_done = FALSE;
4289             info->out->info = info;
4290         }
4291         if (!info->useFILE) {
4292             info->fp  = PerlIO_open(mbx, mode);
4293         } else {
4294             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4295             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4296         }
4297
4298         if (!info->fp && info->out) {
4299             sys$cancel(info->out->chan_out);
4300
4301             while (!info->out_done) {
4302                 int done;
4303                 _ckvmssts_noperl(sys$setast(0));
4304                 done = info->out_done;
4305                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4306                 _ckvmssts_noperl(sys$setast(1));
4307                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4308             }
4309
4310             if (info->out->buf) {
4311                 n = info->out->bufsize * sizeof(char);
4312                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4313             }
4314             n = sizeof(Pipe);
4315             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4316             n = sizeof(Info);
4317             _ckvmssts_noperl(lib$free_vm(&n, &info));
4318             *psts = RMS$_FNF;
4319             return NULL;
4320         }
4321
4322         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4323         if (info->err) {
4324             info->err->pipe_done = &info->err_done;
4325             info->err_done = FALSE;
4326             info->err->info = info;
4327         }
4328
4329     } else if (*mode == 'w') {      /* piping to subroutine */
4330
4331         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4332         if (info->out) {
4333             info->out->pipe_done = &info->out_done;
4334             info->out_done = FALSE;
4335             info->out->info = info;
4336         }
4337
4338         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4339         if (info->err) {
4340             info->err->pipe_done = &info->err_done;
4341             info->err_done = FALSE;
4342             info->err->info = info;
4343         }
4344
4345         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4346         if (!info->useFILE) {
4347             info->fp  = PerlIO_open(mbx, mode);
4348         } else {
4349             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4350             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4351         }
4352
4353         if (info->in) {
4354             info->in->pipe_done = &info->in_done;
4355             info->in_done = FALSE;
4356             info->in->info = info;
4357         }
4358
4359         /* error cleanup */
4360         if (!info->fp && info->in) {
4361             info->done = TRUE;
4362             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4363                                       0, 0, 0, 0, 0, 0, 0, 0));
4364
4365             while (!info->in_done) {
4366                 int done;
4367                 _ckvmssts_noperl(sys$setast(0));
4368                 done = info->in_done;
4369                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4370                 _ckvmssts_noperl(sys$setast(1));
4371                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4372             }
4373
4374             if (info->in->buf) {
4375                 n = info->in->bufsize * sizeof(char);
4376                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4377             }
4378             n = sizeof(Pipe);
4379             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4380             n = sizeof(Info);
4381             _ckvmssts_noperl(lib$free_vm(&n, &info));
4382             *psts = RMS$_FNF;
4383             return NULL;
4384         }
4385
4386
4387     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4388         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4389         if (info->out) {
4390             info->out->pipe_done = &info->out_done;
4391             info->out_done = FALSE;
4392             info->out->info = info;
4393         }
4394
4395         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4396         if (info->err) {
4397             info->err->pipe_done = &info->err_done;
4398             info->err_done = FALSE;
4399             info->err->info = info;
4400         }
4401     }
4402
4403     symbol[MAX_DCL_SYMBOL] = '\0';
4404
4405     strncpy(symbol, in, MAX_DCL_SYMBOL);
4406     d_symbol.dsc$w_length = strlen(symbol);
4407     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4408
4409     strncpy(symbol, err, MAX_DCL_SYMBOL);
4410     d_symbol.dsc$w_length = strlen(symbol);
4411     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4412
4413     strncpy(symbol, out, MAX_DCL_SYMBOL);
4414     d_symbol.dsc$w_length = strlen(symbol);
4415     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4416
4417     /* Done with the names for the pipes */
4418     PerlMem_free(err);
4419     PerlMem_free(out);
4420     PerlMem_free(in);
4421
4422     p = vmscmd->dsc$a_pointer;
4423     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4424     if (*p == '$') p++;                         /* remove leading $ */
4425     while (*p == ' ' || *p == '\t') p++;
4426
4427     for (j = 0; j < 4; j++) {
4428         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4429         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4430
4431     strncpy(symbol, p, MAX_DCL_SYMBOL);
4432     d_symbol.dsc$w_length = strlen(symbol);
4433     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4434
4435         if (strlen(p) > MAX_DCL_SYMBOL) {
4436             p += MAX_DCL_SYMBOL;
4437         } else {
4438             p += strlen(p);
4439         }
4440     }
4441     _ckvmssts_noperl(sys$setast(0));
4442     info->next=open_pipes;  /* prepend to list */
4443     open_pipes=info;
4444     _ckvmssts_noperl(sys$setast(1));
4445     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4446      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4447      * have SYS$COMMAND if we need it.
4448      */
4449     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4450                       0, &info->pid, &info->completion,
4451                       0, popen_completion_ast,info,0,0,0));
4452
4453     /* if we were using a tempfile, close it now */
4454
4455     if (tpipe) fclose(tpipe);
4456
4457     /* once the subprocess is spawned, it has copied the symbols and
4458        we can get rid of ours */
4459
4460     for (j = 0; j < 4; j++) {
4461         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4462         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4463     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4464     }
4465     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4466     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4467     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4468     vms_execfree(vmscmd);
4469
4470 #ifdef PERL_IMPLICIT_CONTEXT
4471     if (aTHX)
4472 #endif
4473     PL_forkprocess = info->pid;
4474
4475     ret_fp = info->fp;
4476     if (wait) {
4477          dSAVEDERRNO;
4478          int done = 0;
4479          while (!done) {
4480              _ckvmssts_noperl(sys$setast(0));
4481              done = info->done;
4482              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4483              _ckvmssts_noperl(sys$setast(1));
4484              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4485          }
4486         *psts = info->completion;
4487 /* Caller thinks it is open and tries to close it. */
4488 /* This causes some problems, as it changes the error status */
4489 /*        my_pclose(info->fp); */
4490
4491          /* If we did not have a file pointer open, then we have to */
4492          /* clean up here or eventually we will run out of something */
4493          SAVE_ERRNO;
4494          if (info->fp == NULL) {
4495              my_pclose_pinfo(aTHX_ info);
4496          }
4497          RESTORE_ERRNO;
4498
4499     } else {
4500         *psts = info->pid;
4501     }
4502     return ret_fp;
4503 }  /* end of safe_popen */
4504
4505
4506 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4507 PerlIO *
4508 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4509 {
4510     int sts;
4511     TAINT_ENV();
4512     TAINT_PROPER("popen");
4513     PERL_FLUSHALL_FOR_CHILD;
4514     return safe_popen(aTHX_ cmd,mode,&sts);
4515 }
4516
4517 /*}}}*/
4518
4519
4520 /* Routine to close and cleanup a pipe info structure */
4521
4522 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4523
4524     unsigned long int retsts;
4525     int done, n;
4526     pInfo next, last;
4527
4528     /* If we were writing to a subprocess, insure that someone reading from
4529      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4530      * produce an EOF record in the mailbox.
4531      *
4532      *  well, at least sometimes it *does*, so we have to watch out for
4533      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4534      */
4535      if (info->fp) {
4536         if (!info->useFILE
4537 #if defined(USE_ITHREADS)
4538           && my_perl
4539 #endif
4540 #ifdef USE_PERLIO
4541           && PL_perlio_fd_refcnt
4542 #endif
4543            )
4544             PerlIO_flush(info->fp);
4545         else
4546             fflush((FILE *)info->fp);
4547     }
4548
4549     _ckvmssts(sys$setast(0));
4550      info->closing = TRUE;
4551      done = info->done && info->in_done && info->out_done && info->err_done;
4552      /* hanging on write to Perl's input? cancel it */
4553      if (info->mode == 'r' && info->out && !info->out_done) {
4554         if (info->out->chan_out) {
4555             _ckvmssts(sys$cancel(info->out->chan_out));
4556             if (!info->out->chan_in) {   /* EOF generation, need AST */
4557                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4558             }
4559         }
4560      }
4561      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4562          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4563                            0, 0, 0, 0, 0, 0));
4564     _ckvmssts(sys$setast(1));
4565     if (info->fp) {
4566      if (!info->useFILE
4567 #if defined(USE_ITHREADS)
4568          && my_perl
4569 #endif
4570 #ifdef USE_PERLIO
4571          && PL_perlio_fd_refcnt
4572 #endif
4573         )
4574         PerlIO_close(info->fp);
4575      else
4576         fclose((FILE *)info->fp);
4577     }
4578      /*
4579         we have to wait until subprocess completes, but ALSO wait until all
4580         the i/o completes...otherwise we'll be freeing the "info" structure
4581         that the i/o ASTs could still be using...
4582      */
4583
4584      while (!done) {
4585          _ckvmssts(sys$setast(0));
4586          done = info->done && info->in_done && info->out_done && info->err_done;
4587          if (!done) _ckvmssts(sys$clref(pipe_ef));
4588          _ckvmssts(sys$setast(1));
4589          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4590      }
4591      retsts = info->completion;
4592
4593     /* remove from list of open pipes */
4594     _ckvmssts(sys$setast(0));
4595     last = NULL;
4596     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4597         if (next == info)
4598             break;
4599     }
4600
4601     if (last)
4602         last->next = info->next;
4603     else
4604         open_pipes = info->next;
4605     _ckvmssts(sys$setast(1));
4606
4607     /* free buffers and structures */
4608
4609     if (info->in) {
4610         if (info->in->buf) {
4611             n = info->in->bufsize * sizeof(char);
4612             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4613         }
4614         n = sizeof(Pipe);
4615         _ckvmssts(lib$free_vm(&n, &info->in));
4616     }
4617     if (info->out) {
4618         if (info->out->buf) {
4619             n = info->out->bufsize * sizeof(char);
4620             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4621         }
4622         n = sizeof(Pipe);
4623         _ckvmssts(lib$free_vm(&n, &info->out));
4624     }
4625     if (info->err) {
4626         if (info->err->buf) {
4627             n = info->err->bufsize * sizeof(char);
4628             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4629         }
4630         n = sizeof(Pipe);
4631         _ckvmssts(lib$free_vm(&n, &info->err));
4632     }
4633     n = sizeof(Info);
4634     _ckvmssts(lib$free_vm(&n, &info));
4635
4636     return retsts;
4637 }
4638
4639
4640 /*{{{  I32 my_pclose(PerlIO *fp)*/
4641 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4642 {
4643     pInfo info, last = NULL;
4644     I32 ret_status;
4645
4646     /* Fixme - need ast and mutex protection here */
4647     for (info = open_pipes; info != NULL; last = info, info = info->next)
4648         if (info->fp == fp) break;
4649
4650     if (info == NULL) {  /* no such pipe open */
4651       set_errno(ECHILD); /* quoth POSIX */
4652       set_vaxc_errno(SS$_NONEXPR);
4653       return -1;
4654     }
4655
4656     ret_status = my_pclose_pinfo(aTHX_ info);
4657
4658     return ret_status;
4659
4660 }  /* end of my_pclose() */
4661
4662 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4663   /* Roll our own prototype because we want this regardless of whether
4664    * _VMS_WAIT is defined.
4665    */
4666   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4667 #endif
4668 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4669    created with popen(); otherwise partially emulate waitpid() unless
4670    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4671    Also check processes not considered by the CRTL waitpid().
4672  */
4673 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4674 Pid_t
4675 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4676 {
4677     pInfo info;
4678     int done;
4679     int sts;
4680     int j;
4681
4682     if (statusp) *statusp = 0;
4683
4684     for (info = open_pipes; info != NULL; info = info->next)
4685         if (info->pid == pid) break;
4686
4687     if (info != NULL) {  /* we know about this child */
4688       while (!info->done) {
4689           _ckvmssts(sys$setast(0));
4690           done = info->done;
4691           if (!done) _ckvmssts(sys$clref(pipe_ef));
4692           _ckvmssts(sys$setast(1));
4693           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4694       }
4695
4696       if (statusp) *statusp = info->completion;
4697       return pid;
4698     }
4699
4700     /* child that already terminated? */
4701
4702     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4703         if (closed_list[j].pid == pid) {
4704             if (statusp) *statusp = closed_list[j].completion;
4705             return pid;
4706         }
4707     }
4708
4709     /* fall through if this child is not one of our own pipe children */
4710
4711 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4712
4713       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4714        * in 7.2 did we get a version that fills in the VMS completion
4715        * status as Perl has always tried to do.
4716        */
4717
4718       sts = __vms_waitpid( pid, statusp, flags );
4719
4720       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4721          return sts;
4722
4723       /* If the real waitpid tells us the child does not exist, we
4724        * fall through here to implement waiting for a child that
4725        * was created by some means other than exec() (say, spawned
4726        * from DCL) or to wait for a process that is not a subprocess
4727        * of the current process.
4728        */
4729
4730 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4731
4732     {
4733       $DESCRIPTOR(intdsc,"0 00:00:01");
4734       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4735       unsigned long int pidcode = JPI$_PID, mypid;
4736       unsigned long int interval[2];
4737       unsigned int jpi_iosb[2];
4738       struct itmlst_3 jpilist[2] = {
4739           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4740           {                      0,         0,                 0, 0}
4741       };
4742
4743       if (pid <= 0) {
4744         /* Sorry folks, we don't presently implement rooting around for
4745            the first child we can find, and we definitely don't want to
4746            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4747          */
4748         set_errno(ENOTSUP);
4749         return -1;
4750       }
4751
4752       /* Get the owner of the child so I can warn if it's not mine. If the
4753        * process doesn't exist or I don't have the privs to look at it,
4754        * I can go home early.
4755        */
4756       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4757       if (sts & 1) sts = jpi_iosb[0];
4758       if (!(sts & 1)) {
4759         switch (sts) {
4760             case SS$_NONEXPR:
4761                 set_errno(ECHILD);
4762                 break;
4763             case SS$_NOPRIV:
4764                 set_errno(EACCES);
4765                 break;
4766             default:
4767                 _ckvmssts(sts);
4768         }
4769         set_vaxc_errno(sts);
4770         return -1;
4771       }
4772
4773       if (ckWARN(WARN_EXEC)) {
4774         /* remind folks they are asking for non-standard waitpid behavior */
4775         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4776         if (ownerpid != mypid)
4777           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4778                       "waitpid: process %x is not a child of process %x",
4779                       pid,mypid);
4780       }
4781
4782       /* simply check on it once a second until it's not there anymore. */
4783
4784       _ckvmssts(sys$bintim(&intdsc,interval));
4785       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4786             _ckvmssts(sys$schdwk(0,0,interval,0));
4787             _ckvmssts(sys$hiber());
4788       }
4789       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4790
4791       _ckvmssts(sts);
4792       return pid;
4793     }
4794 }  /* end of waitpid() */
4795 /*}}}*/
4796 /*}}}*/
4797 /*}}}*/
4798
4799 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4800 char *
4801 my_gconvert(double val, int ndig, int trail, char *buf)
4802 {
4803   static char __gcvtbuf[DBL_DIG+1];
4804   char *loc;
4805
4806   loc = buf ? buf : __gcvtbuf;
4807
4808 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4809   if (val < 1) {
4810     sprintf(loc,"%.*g",ndig,val);
4811     return loc;
4812   }
4813 #endif
4814
4815   if (val) {
4816     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4817     return gcvt(val,ndig,loc);
4818   }
4819   else {
4820     loc[0] = '0'; loc[1] = '\0';
4821     return loc;
4822   }
4823
4824 }
4825 /*}}}*/
4826
4827 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4828 static int rms_free_search_context(struct FAB * fab)
4829 {
4830 struct NAM * nam;
4831
4832     nam = fab->fab$l_nam;
4833     nam->nam$b_nop |= NAM$M_SYNCHK;
4834     nam->nam$l_rlf = NULL;
4835     fab->fab$b_dns = 0;
4836     return sys$parse(fab, NULL, NULL);
4837 }
4838
4839 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4840 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4841 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4842 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4843 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4844 #define rms_nam_esll(nam) nam.nam$b_esl
4845 #define rms_nam_esl(nam) nam.nam$b_esl
4846 #define rms_nam_name(nam) nam.nam$l_name
4847 #define rms_nam_namel(nam) nam.nam$l_name
4848 #define rms_nam_type(nam) nam.nam$l_type
4849 #define rms_nam_typel(nam) nam.nam$l_type
4850 #define rms_nam_ver(nam) nam.nam$l_ver