vms/vms.c

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