vms/vms.c

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