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