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