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