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