vms/vms.c

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