vms/vms.c

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