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