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