vms/vms.c

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