vms/vms.c

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