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