vms/vms.c

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