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