vms/vms.c

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