vms/vms.c

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