vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993-2015 by Charles Bailey and others.
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  */
  10
  11 /*
  12  *   Yet small as was their hunted band
  13  *   still fell and fearless was each hand,
  14  *   and strong deeds they wrought yet oft,
  15  *   and loved the woods, whose ways more soft
  16  *   them seemed than thralls of that black throne
  17  *   to live and languish in halls of stone.
  18  *        "The Lay of Leithian", Canto II, lines 135-40
  19  *
  20  *     [p.162 of _The Lays of Beleriand_]
  21  */
  22
  23 #include <acedef.h>
  24 #include <acldef.h>
  25 #include <armdef.h>
  26 #if __CRTL_VER < 70300000
  27 /* needed for home-rolled utime() */
  28 #include <atrdef.h>
  29 #include <fibdef.h>
  30 #endif
  31 #include <chpdef.h>
  32 #include <clidef.h>
  33 #include <climsgdef.h>
  34 #include <dcdef.h>
  35 #include <descrip.h>
  36 #include <devdef.h>
  37 #include <dvidef.h>
  38 #include <float.h>
  39 #include <fscndef.h>
  40 #include <iodef.h>
  41 #include <jpidef.h>
  42 #include <kgbdef.h>
  43 #include <libclidef.h>
  44 #include <libdef.h>
  45 #include <lib$routines.h>
  46 #include <lnmdef.h>
  47 #include <ossdef.h>
  48 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  49 #include <ppropdef.h>
  50 #endif
  51 #include <prvdef.h>
  52 #include <psldef.h>
  53 #include <rms.h>
  54 #include <shrdef.h>
  55 #include <ssdef.h>
  56 #include <starlet.h>
  57 #include <strdef.h>
  58 #include <str$routines.h>
  59 #include <syidef.h>
  60 #include <uaidef.h>
  61 #include <uicdef.h>
  62 #include <stsdef.h>
  63 #include <efndef.h>
  64 #define NO_EFN EFN$C_ENF
  65
  66 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  67 int   decc$feature_get_index(const char *name);
  68 char* decc$feature_get_name(int index);
  69 int   decc$feature_get_value(int index, int mode);
  70 int   decc$feature_set_value(int index, int mode, int value);
  71 #else
  72 #include <unixlib.h>
  73 #endif
  74
  75 #pragma member_alignment save
  76 #pragma nomember_alignment longword
  77 struct item_list_3 {
  78         unsigned short len;
  79         unsigned short code;
  80         void * bufadr;
  81         unsigned short * retadr;
  82 };
  83 #pragma member_alignment restore
  84
  85 /* Older versions of ssdef.h don't have these */
  86 #ifndef SS$_INVFILFOROP
  87 #  define SS$_INVFILFOROP 3930
  88 #endif
  89 #ifndef SS$_NOSUCHOBJECT
  90 #  define SS$_NOSUCHOBJECT 2696
  91 #endif
  92
  93 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
  94 #define PERLIO_NOT_STDIO 0
  95
  96 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
  97  * code below needs to get to the underlying CRTL routines. */
  98 #define DONT_MASK_RTL_CALLS
  99 #include "EXTERN.h"
 100 #include "perl.h"
 101 #include "XSUB.h"
 102 /* Anticipating future expansion in lexical warnings . . . */
 103 #ifndef WARN_INTERNAL
 104 #  define WARN_INTERNAL WARN_MISC
 105 #endif
 106
 107 #ifdef VMS_LONGNAME_SUPPORT
 108 #include <libfildef.h>
 109 #endif
 110
 111 #if !defined(__VAX) && __CRTL_VER >= 80200000
 112 #ifdef lstat
 113 #undef lstat
 114 #endif
 115 #else
 116 #ifdef lstat
 117 #undef lstat
 118 #endif
 119 #define lstat(_x, _y) stat(_x, _y)
 120 #endif
 121
 122 /* Routine to create a decterm for use with the Perl debugger */
 123 /* No headers, this information was found in the Programming Concepts Manual */
 124
 125 static int (*decw_term_port)
 126    (const struct dsc$descriptor_s * display,
 127     const struct dsc$descriptor_s * setup_file,
 128     const struct dsc$descriptor_s * customization,
 129     struct dsc$descriptor_s * result_device_name,
 130     unsigned short * result_device_name_length,
 131     void * controller,
 132     void * char_buffer,
 133     void * char_change_buffer) = 0;
 134
 135 /* gcc's header files don't #define direct access macros
 136  * corresponding to VAXC's variant structs */
 137 #ifdef __GNUC__
 138 #  define uic$v_format uic$r_uic_form.uic$v_format
 139 #  define uic$v_group uic$r_uic_form.uic$v_group
 140 #  define uic$v_member uic$r_uic_form.uic$v_member
 141 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 142 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 143 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 144 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 145 #endif
 146
 147 #if defined(NEED_AN_H_ERRNO)
 148 dEXT int h_errno;
 149 #endif
 150
 151 #if defined(__DECC) || defined(__DECCXX)
 152 #pragma member_alignment save
 153 #pragma nomember_alignment longword
 154 #pragma message save
 155 #pragma message disable misalgndmem
 156 #endif
 157 struct itmlst_3 {
 158   unsigned short int buflen;
 159   unsigned short int itmcode;
 160   void *bufadr;
 161   unsigned short int *retlen;
 162 };
 163
 164 struct filescan_itmlst_2 {
 165     unsigned short length;
 166     unsigned short itmcode;
 167     char * component;
 168 };
 169
 170 struct vs_str_st {
 171     unsigned short length;
 172     char str[VMS_MAXRSS];
 173     unsigned short pad; /* for longword struct alignment */
 174 };
 175
 176 #if defined(__DECC) || defined(__DECCXX)
 177 #pragma message restore
 178 #pragma member_alignment restore
 179 #endif
 180
 181 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 182 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 183 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 184 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 185 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 186 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 187 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 188 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 189 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 190 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 191 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 192 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 193
 194 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 195 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 196 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 197 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 198
 199 static char *  int_rmsexpand_vms(
 200     const char * filespec, char * outbuf, unsigned opts);
 201 static char * int_rmsexpand_tovms(
 202     const char * filespec, char * outbuf, unsigned opts);
 203 static char *int_tovmsspec
 204    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 205 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 206 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 207 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 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 /* DECC Features that may need to affect how Perl interprets
 247  * displays filename information
 248  */
 249 static int decc_disable_to_vms_logname_translation = 1;
 250 static int decc_disable_posix_root = 1;
 251 int decc_efs_case_preserve = 0;
 252 static int decc_efs_charset = 0;
 253 static int decc_efs_charset_index = -1;
 254 static int decc_filename_unix_no_version = 0;
 255 static int decc_filename_unix_only = 0;
 256 int decc_filename_unix_report = 0;
 257 int decc_posix_compliant_pathnames = 0;
 258 int decc_readdir_dropdotnotype = 0;
 259 static int vms_process_case_tolerant = 1;
 260 int vms_vtf7_filenames = 0;
 261 int gnv_unix_shell = 0;
 262 static int vms_unlink_all_versions = 0;
 263 static int vms_posix_exit = 0;
 264
 265 /* bug workarounds if needed */
 266 int decc_bug_devnull = 1;
 267 int vms_bug_stat_filename = 0;
 268
 269 static int vms_debug_on_exception = 0;
 270 static int vms_debug_fileify = 0;
 271
 272 /* Simple logical name translation */
 273 static int
 274 simple_trnlnm(const char * logname, char * value, int value_len)
 275 {
 276     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 277     const unsigned long attr = LNM$M_CASE_BLIND;
 278     struct dsc$descriptor_s name_dsc;
 279     int status;
 280     unsigned short result;
 281     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 282                                 {0, 0, 0, 0}};
 283
 284     name_dsc.dsc$w_length = strlen(logname);
 285     name_dsc.dsc$a_pointer = (char *)logname;
 286     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 287     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 288
 289     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 290
 291     if ($VMS_STATUS_SUCCESS(status)) {
 292
 293          /* Null terminate and return the string */
 294         /*--------------------------------------*/
 295         value[result] = 0;
 296         return result;
 297     }
 298
 299     return 0;
 300 }
 301
 302
 303 /* Is this a UNIX file specification?
 304  *   No longer a simple check with EFS file specs
 305  *   For now, not a full check, but need to
 306  *   handle POSIX ^UP^ specifications
 307  *   Fixing to handle ^/ cases would require
 308  *   changes to many other conversion routines.
 309  */
 310
 311 static int
 312 is_unix_filespec(const char *path)
 313 {
 314     int ret_val;
 315     const char * pch1;
 316
 317     ret_val = 0;
 318     if (strncmp(path,"\"^UP^",5) != 0) {
 319         pch1 = strchr(path, '/');
 320         if (pch1 != NULL)
 321             ret_val = 1;
 322         else {
 323
 324             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 325             if (decc_filename_unix_report || decc_filename_unix_only) {
 326             if (strcmp(path,".") == 0)
 327                 ret_val = 1;
 328             }
 329         }
 330     }
 331     return ret_val;
 332 }
 333
 334 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 335  */
 336
 337 static void
 338 ucs2_to_vtf7(char *outspec, unsigned long ucs2_char, int * output_cnt)
 339 {
 340     unsigned char * ucs_ptr;
 341     int hex;
 342
 343     ucs_ptr = (unsigned char *)&ucs2_char;
 344
 345     outspec[0] = '^';
 346     outspec[1] = 'U';
 347     hex = (ucs_ptr[1] >> 4) & 0xf;
 348     if (hex < 0xA)
 349         outspec[2] = hex + '0';
 350     else
 351         outspec[2] = (hex - 9) + 'A';
 352     hex = ucs_ptr[1] & 0xF;
 353     if (hex < 0xA)
 354         outspec[3] = hex + '0';
 355     else {
 356         outspec[3] = (hex - 9) + 'A';
 357     }
 358     hex = (ucs_ptr[0] >> 4) & 0xf;
 359     if (hex < 0xA)
 360         outspec[4] = hex + '0';
 361     else
 362         outspec[4] = (hex - 9) + 'A';
 363     hex = ucs_ptr[1] & 0xF;
 364     if (hex < 0xA)
 365         outspec[5] = hex + '0';
 366     else {
 367         outspec[5] = (hex - 9) + 'A';
 368     }
 369     *output_cnt = 6;
 370 }
 371
 372
 373 /* This handles the conversion of a UNIX extended character set to a ^
 374  * escaped VMS character.
 375  * in a UNIX file specification.
 376  *
 377  * The output count variable contains the number of characters added
 378  * to the output string.
 379  *
 380  * The return value is the number of characters read from the input string
 381  */
 382 static int
 383 copy_expand_unix_filename_escape(char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 384 {
 385     int count;
 386     int utf8_flag;
 387
 388     utf8_flag = 0;
 389     if (utf8_fl)
 390       utf8_flag = *utf8_fl;
 391
 392     count = 0;
 393     *output_cnt = 0;
 394     if (*inspec >= 0x80) {
 395         if (utf8_fl && vms_vtf7_filenames) {
 396         unsigned long ucs_char;
 397
 398             ucs_char = 0;
 399
 400             if ((*inspec & 0xE0) == 0xC0) {
 401                 /* 2 byte Unicode */
 402                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 403                 if (ucs_char >= 0x80) {
 404                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 405                     return 2;
 406                 }
 407             } else if ((*inspec & 0xF0) == 0xE0) {
 408                 /* 3 byte Unicode */
 409                 ucs_char = ((inspec[0] & 0xF) << 12) +
 410                    ((inspec[1] & 0x3f) << 6) +
 411                    (inspec[2] & 0x3f);
 412                 if (ucs_char >= 0x800) {
 413                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 414                     return 3;
 415                 }
 416
 417 #if 0 /* I do not see longer sequences supported by OpenVMS */
 418       /* Maybe some one can fix this later */
 419             } else if ((*inspec & 0xF8) == 0xF0) {
 420                 /* 4 byte Unicode */
 421                 /* UCS-4 to UCS-2 */
 422             } else if ((*inspec & 0xFC) == 0xF8) {
 423                 /* 5 byte Unicode */
 424                 /* UCS-4 to UCS-2 */
 425             } else if ((*inspec & 0xFE) == 0xFC) {
 426                 /* 6 byte Unicode */
 427                 /* UCS-4 to UCS-2 */
 428 #endif
 429             }
 430         }
 431
 432         /* High bit set, but not a Unicode character! */
 433
 434         /* Non printing DECMCS or ISO Latin-1 character? */
 435         if ((unsigned char)*inspec <= 0x9F) {
 436             int hex;
 437             outspec[0] = '^';
 438             outspec++;
 439             hex = (*inspec >> 4) & 0xF;
 440             if (hex < 0xA)
 441                 outspec[1] = hex + '0';
 442             else {
 443                 outspec[1] = (hex - 9) + 'A';
 444             }
 445             hex = *inspec & 0xF;
 446             if (hex < 0xA)
 447                 outspec[2] = hex + '0';
 448             else {
 449                 outspec[2] = (hex - 9) + 'A';
 450             }
 451             *output_cnt = 3;
 452             return 1;
 453         } else if ((unsigned char)*inspec == 0xA0) {
 454             outspec[0] = '^';
 455             outspec[1] = 'A';
 456             outspec[2] = '0';
 457             *output_cnt = 3;
 458             return 1;
 459         } else if ((unsigned char)*inspec == 0xFF) {
 460             outspec[0] = '^';
 461             outspec[1] = 'F';
 462             outspec[2] = 'F';
 463             *output_cnt = 3;
 464             return 1;
 465         }
 466         *outspec = *inspec;
 467         *output_cnt = 1;
 468         return 1;
 469     }
 470
 471     /* Is this a macro that needs to be passed through?
 472      * Macros start with $( and an alpha character, followed
 473      * by a string of alpha numeric characters ending with a )
 474      * If this does not match, then encode it as ODS-5.
 475      */
 476     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 477     int tcnt;
 478
 479         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 480             tcnt = 3;
 481             outspec[0] = inspec[0];
 482             outspec[1] = inspec[1];
 483             outspec[2] = inspec[2];
 484
 485             while(isalnum(inspec[tcnt]) ||
 486                   (inspec[2] == '.') || (inspec[2] == '_')) {
 487                 outspec[tcnt] = inspec[tcnt];
 488                 tcnt++;
 489             }
 490             if (inspec[tcnt] == ')') {
 491                 outspec[tcnt] = inspec[tcnt];
 492                 tcnt++;
 493                 *output_cnt = tcnt;
 494                 return tcnt;
 495             }
 496         }
 497     }
 498
 499     switch (*inspec) {
 500     case 0x7f:
 501         outspec[0] = '^';
 502         outspec[1] = '7';
 503         outspec[2] = 'F';
 504         *output_cnt = 3;
 505         return 1;
 506         break;
 507     case '?':
 508         if (decc_efs_charset == 0)
 509           outspec[0] = '%';
 510         else
 511           outspec[0] = '?';
 512         *output_cnt = 1;
 513         return 1;
 514         break;
 515     case '.':
 516     case '~':
 517     case '!':
 518     case '#':
 519     case '&':
 520     case '\'':
 521     case '`':
 522     case '(':
 523     case ')':
 524     case '+':
 525     case '@':
 526     case '{':
 527     case '}':
 528     case ',':
 529     case ';':
 530     case '[':
 531     case ']':
 532     case '%':
 533     case '^':
 534     case '\\':
 535         /* Don't escape again if following character is
 536          * already something we escape.
 537          */
 538         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 539             *outspec = *inspec;
 540             *output_cnt = 1;
 541             return 1;
 542             break;
 543         }
 544         /* But otherwise fall through and escape it. */
 545     case '=':
 546         /* Assume that this is to be escaped */
 547         outspec[0] = '^';
 548         outspec[1] = *inspec;
 549         *output_cnt = 2;
 550         return 1;
 551         break;
 552     case ' ': /* space */
 553         /* Assume that this is to be escaped */
 554         outspec[0] = '^';
 555         outspec[1] = '_';
 556         *output_cnt = 2;
 557         return 1;
 558         break;
 559     default:
 560         *outspec = *inspec;
 561         *output_cnt = 1;
 562         return 1;
 563         break;
 564     }
 565     return 0;
 566 }
 567
 568
 569 /* This handles the expansion of a '^' prefix to the proper character
 570  * in a UNIX file specification.
 571  *
 572  * The output count variable contains the number of characters added
 573  * to the output string.
 574  *
 575  * The return value is the number of characters read from the input
 576  * string
 577  */
 578 static int
 579 copy_expand_vms_filename_escape(char *outspec, const char *inspec, int *output_cnt)
 580 {
 581     int count;
 582     int scnt;
 583
 584     count = 0;
 585     *output_cnt = 0;
 586     if (*inspec == '^') {
 587         inspec++;
 588         switch (*inspec) {
 589         /* Spaces and non-trailing dots should just be passed through,
 590          * but eat the escape character.
 591          */
 592         case '.':
 593             *outspec = *inspec;
 594             count += 2;
 595             (*output_cnt)++;
 596             break;
 597         case '_': /* space */
 598             *outspec = ' ';
 599             count += 2;
 600             (*output_cnt)++;
 601             break;
 602         case '^':
 603             /* Hmm.  Better leave the escape escaped. */
 604             outspec[0] = '^';
 605             outspec[1] = '^';
 606             count += 2;
 607             (*output_cnt) += 2;
 608             break;
 609         case 'U': /* Unicode - FIX-ME this is wrong. */
 610             inspec++;
 611             count++;
 612             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 613             if (scnt == 4) {
 614                 unsigned int c1, c2;
 615                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 616                 outspec[0] = c1 & 0xff;
 617                 outspec[1] = c2 & 0xff;
 618                 if (scnt > 1) {
 619                     (*output_cnt) += 2;
 620                     count += 4;
 621                 }
 622             }
 623             else {
 624                 /* Error - do best we can to continue */
 625                 *outspec = 'U';
 626                 outspec++;
 627                 (*output_cnt++);
 628                 *outspec = *inspec;
 629                 count++;
 630                 (*output_cnt++);
 631             }
 632             break;
 633         default:
 634             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 635             if (scnt == 2) {
 636                 /* Hex encoded */
 637                 unsigned int c1;
 638                 scnt = sscanf(inspec, "%2x", &c1);
 639                 outspec[0] = c1 & 0xff;
 640                 if (scnt > 0) {
 641                     (*output_cnt++);
 642                     count += 2;
 643                 }
 644             }
 645             else {
 646                 *outspec = *inspec;
 647                 count++;
 648                 (*output_cnt++);
 649             }
 650         }
 651     }
 652     else {
 653         *outspec = *inspec;
 654         count++;
 655         (*output_cnt)++;
 656     }
 657     return count;
 658 }
 659
 660 /* vms_split_path - Verify that the input file specification is a
 661  * VMS format file specification, and provide pointers to the components of
 662  * it.  With EFS format filenames, this is virtually the only way to
 663  * parse a VMS path specification into components.
 664  *
 665  * If the sum of the components do not add up to the length of the
 666  * string, then the passed file specification is probably a UNIX style
 667  * path.
 668  */
 669 static int
 670 vms_split_path(const char * path, char * * volume, int * vol_len, char * * root, int * root_len,
 671                char * * dir, int * dir_len, char * * name, int * name_len,
 672                char * * ext, int * ext_len, char * * version, int * ver_len)
 673 {
 674     struct dsc$descriptor path_desc;
 675     int status;
 676     unsigned long flags;
 677     int ret_stat;
 678     struct filescan_itmlst_2 item_list[9];
 679     const int filespec = 0;
 680     const int nodespec = 1;
 681     const int devspec = 2;
 682     const int rootspec = 3;
 683     const int dirspec = 4;
 684     const int namespec = 5;
 685     const int typespec = 6;
 686     const int verspec = 7;
 687
 688     /* Assume the worst for an easy exit */
 689     ret_stat = -1;
 690     *volume = NULL;
 691     *vol_len = 0;
 692     *root = NULL;
 693     *root_len = 0;
 694     *dir = NULL;
 695     *name = NULL;
 696     *name_len = 0;
 697     *ext = NULL;
 698     *ext_len = 0;
 699     *version = NULL;
 700     *ver_len = 0;
 701
 702     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 703     path_desc.dsc$w_length = strlen(path);
 704     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 705     path_desc.dsc$b_class = DSC$K_CLASS_S;
 706
 707     /* Get the total length, if it is shorter than the string passed
 708      * then this was probably not a VMS formatted file specification
 709      */
 710     item_list[filespec].itmcode = FSCN$_FILESPEC;
 711     item_list[filespec].length = 0;
 712     item_list[filespec].component = NULL;
 713
 714     /* If the node is present, then it gets considered as part of the
 715      * volume name to hopefully make things simple.
 716      */
 717     item_list[nodespec].itmcode = FSCN$_NODE;
 718     item_list[nodespec].length = 0;
 719     item_list[nodespec].component = NULL;
 720
 721     item_list[devspec].itmcode = FSCN$_DEVICE;
 722     item_list[devspec].length = 0;
 723     item_list[devspec].component = NULL;
 724
 725     /* root is a special case,  adding it to either the directory or
 726      * the device components will probably complicate things for the
 727      * callers of this routine, so leave it separate.
 728      */
 729     item_list[rootspec].itmcode = FSCN$_ROOT;
 730     item_list[rootspec].length = 0;
 731     item_list[rootspec].component = NULL;
 732
 733     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 734     item_list[dirspec].length = 0;
 735     item_list[dirspec].component = NULL;
 736
 737     item_list[namespec].itmcode = FSCN$_NAME;
 738     item_list[namespec].length = 0;
 739     item_list[namespec].component = NULL;
 740
 741     item_list[typespec].itmcode = FSCN$_TYPE;
 742     item_list[typespec].length = 0;
 743     item_list[typespec].component = NULL;
 744
 745     item_list[verspec].itmcode = FSCN$_VERSION;
 746     item_list[verspec].length = 0;
 747     item_list[verspec].component = NULL;
 748
 749     item_list[8].itmcode = 0;
 750     item_list[8].length = 0;
 751     item_list[8].component = NULL;
 752
 753     status = sys$filescan
 754        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 755         &flags, NULL, NULL);
 756     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 757
 758     /* If we parsed it successfully these two lengths should be the same */
 759     if (path_desc.dsc$w_length != item_list[filespec].length)
 760         return ret_stat;
 761
 762     /* If we got here, then it is a VMS file specification */
 763     ret_stat = 0;
 764
 765     /* set the volume name */
 766     if (item_list[nodespec].length > 0) {
 767         *volume = item_list[nodespec].component;
 768         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 769     }
 770     else {
 771         *volume = item_list[devspec].component;
 772         *vol_len = item_list[devspec].length;
 773     }
 774
 775     *root = item_list[rootspec].component;
 776     *root_len = item_list[rootspec].length;
 777
 778     *dir = item_list[dirspec].component;
 779     *dir_len = item_list[dirspec].length;
 780
 781     /* Now fun with versions and EFS file specifications
 782      * The parser can not tell the difference when a "." is a version
 783      * delimiter or a part of the file specification.
 784      */
 785     if ((decc_efs_charset) &&
 786         (item_list[verspec].length > 0) &&
 787         (item_list[verspec].component[0] == '.')) {
 788         *name = item_list[namespec].component;
 789         *name_len = item_list[namespec].length + item_list[typespec].length;
 790         *ext = item_list[verspec].component;
 791         *ext_len = item_list[verspec].length;
 792         *version = NULL;
 793         *ver_len = 0;
 794     }
 795     else {
 796         *name = item_list[namespec].component;
 797         *name_len = item_list[namespec].length;
 798         *ext = item_list[typespec].component;
 799         *ext_len = item_list[typespec].length;
 800         *version = item_list[verspec].component;
 801         *ver_len = item_list[verspec].length;
 802     }
 803     return ret_stat;
 804 }
 805
 806 /* Routine to determine if the file specification ends with .dir */
 807 static int
 808 is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len)
 809 {
 810
 811     /* e_len must be 4, and version must be <= 2 characters */
 812     if (e_len != 4 || vs_len > 2)
 813         return 0;
 814
 815     /* If a version number is present, it needs to be one */
 816     if ((vs_len == 2) && (vs_spec[1] != '1'))
 817         return 0;
 818
 819     /* Look for the DIR on the extension */
 820     if (vms_process_case_tolerant) {
 821         if ((toupper(e_spec[1]) == 'D') &&
 822             (toupper(e_spec[2]) == 'I') &&
 823             (toupper(e_spec[3]) == 'R')) {
 824             return 1;
 825         }
 826     } else {
 827         /* Directory extensions are supposed to be in upper case only */
 828         /* I would not be surprised if this rule can not be enforced */
 829         /* if and when someone fully debugs the case sensitive mode */
 830         if ((e_spec[1] == 'D') &&
 831             (e_spec[2] == 'I') &&
 832             (e_spec[3] == 'R')) {
 833             return 1;
 834         }
 835     }
 836     return 0;
 837 }
 838
 839
 840 /* my_maxidx
 841  * Routine to retrieve the maximum equivalence index for an input
 842  * logical name.  Some calls to this routine have no knowledge if
 843  * the variable is a logical or not.  So on error we return a max
 844  * index of zero.
 845  */
 846 /*{{{int my_maxidx(const char *lnm) */
 847 static int
 848 my_maxidx(const char *lnm)
 849 {
 850     int status;
 851     int midx;
 852     int attr = LNM$M_CASE_BLIND;
 853     struct dsc$descriptor lnmdsc;
 854     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 855                                 {0, 0, 0, 0}};
 856
 857     lnmdsc.dsc$w_length = strlen(lnm);
 858     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 859     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 860     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 861
 862     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 863     if ((status & 1) == 0)
 864        midx = 0;
 865
 866     return (midx);
 867 }
 868 /*}}}*/
 869
 870 /* Routine to remove the 2-byte prefix from the translation of a
 871  * process-permanent file (PPF).
 872  */
 873 static inline unsigned short int
 874 S_remove_ppf_prefix(const char *lnm, char *eqv, unsigned short int eqvlen)
 875 {
 876     if (*((int *)lnm) == *((int *)"SYS$")                    &&
 877         eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00      &&
 878         ( (lnm[4] == 'O' && !strcmp(lnm,"SYS$OUTPUT"))  ||
 879           (lnm[4] == 'I' && !strcmp(lnm,"SYS$INPUT"))   ||
 880           (lnm[4] == 'E' && !strcmp(lnm,"SYS$ERROR"))   ||
 881           (lnm[4] == 'C' && !strcmp(lnm,"SYS$COMMAND")) )  ) {
 882
 883         memmove(eqv, eqv+4, eqvlen-4);
 884         eqvlen -= 4;
 885     }
 886     return eqvlen;
 887 }
 888
 889 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 890 int
 891 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 892   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 893 {
 894     const char *cp1;
 895     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 896     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 897     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 898     int midx;
 899     unsigned char acmode;
 900     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 901                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 902     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 903                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 904                                  {0, 0, 0, 0}};
 905     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 906 #if defined(PERL_IMPLICIT_CONTEXT)
 907     pTHX = NULL;
 908     if (PL_curinterp) {
 909       aTHX = PERL_GET_INTERP;
 910     } else {
 911       aTHX = NULL;
 912     }
 913 #endif
 914
 915     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 916       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 917     }
 918     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 919       *cp2 = _toupper(*cp1);
 920       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 921         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 922         return 0;
 923       }
 924     }
 925     lnmdsc.dsc$w_length = cp1 - lnm;
 926     lnmdsc.dsc$a_pointer = uplnm;
 927     uplnm[lnmdsc.dsc$w_length] = '\0';
 928     secure = flags & PERL__TRNENV_SECURE;
 929     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 930     if (!tabvec || !*tabvec) tabvec = env_tables;
 931
 932     for (curtab = 0; tabvec[curtab]; curtab++) {
 933       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 934         if (!ivenv && !secure) {
 935           char *eq;
 936           int i;
 937           if (!environ) {
 938             ivenv = 1;
 939 #if defined(PERL_IMPLICIT_CONTEXT)
 940             if (aTHX == NULL) {
 941                 fprintf(stderr,
 942                     "Can't read CRTL environ\n");
 943             } else
 944 #endif
 945                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 946             continue;
 947           }
 948           retsts = SS$_NOLOGNAM;
 949           for (i = 0; environ[i]; i++) {
 950             if ((eq = strchr(environ[i],'=')) &&
 951                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 952                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 953               eq++;
 954               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 955               if (!eqvlen) continue;
 956               retsts = SS$_NORMAL;
 957               break;
 958             }
 959           }
 960           if (retsts != SS$_NOLOGNAM) break;
 961         }
 962       }
 963       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 964                !str$case_blind_compare(&tmpdsc,&clisym)) {
 965         if (!ivsym && !secure) {
 966           unsigned short int deflen = LNM$C_NAMLENGTH;
 967           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 968           /* dynamic dsc to accommodate possible long value */
 969           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 970           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 971           if (retsts & 1) {
 972             if (eqvlen > MAX_DCL_SYMBOL) {
 973               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 974               eqvlen = MAX_DCL_SYMBOL;
 975               /* Special hack--we might be called before the interpreter's */
 976               /* fully initialized, in which case either thr or PL_curcop */
 977               /* might be bogus. We have to check, since ckWARN needs them */
 978               /* both to be valid if running threaded */
 979 #if defined(PERL_IMPLICIT_CONTEXT)
 980               if (aTHX == NULL) {
 981                   fprintf(stderr,
 982                      "Value of CLI symbol \"%s\" too long",lnm);
 983               } else
 984 #endif
 985                 if (ckWARN(WARN_MISC)) {
 986                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 987                 }
 988             }
 989             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 990           }
 991           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
 992           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 993           if (retsts == LIB$_NOSUCHSYM) continue;
 994           break;
 995         }
 996       }
 997       else if (!ivlnm) {
 998         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 999           midx = my_maxidx(lnm);
1000           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1001             lnmlst[1].bufadr = cp2;
1002             eqvlen = 0;
1003             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1004             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1005             if (retsts == SS$_NOLOGNAM) break;
1006             eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
1007             cp2 += eqvlen;
1008             *cp2 = '\0';
1009           }
1010           if ((retsts == SS$_IVLOGNAM) ||
1011               (retsts == SS$_NOLOGNAM)) { continue; }
1012           eqvlen = strlen(eqv);
1013         }
1014         else {
1015           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1016           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1017           if (retsts == SS$_NOLOGNAM) continue;
1018           eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
1019           eqv[eqvlen] = '\0';
1020         }
1021         break;
1022       }
1023     }
1024     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1025     else if (retsts == LIB$_NOSUCHSYM ||
1026              retsts == SS$_NOLOGNAM) {
1027      /* Unsuccessful lookup is normal -- no need to set errno */
1028      return 0;
1029     }
1030     else if (retsts == LIB$_INVSYMNAM ||
1031              retsts == SS$_IVLOGNAM   ||
1032              retsts == SS$_IVLOGTAB) {
1033       set_errno(EINVAL);  set_vaxc_errno(retsts);
1034     }
1035     else _ckvmssts_noperl(retsts);
1036     return 0;
1037 }  /* end of vmstrnenv */
1038 /*}}}*/
1039
1040 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1041 /* Define as a function so we can access statics. */
1042 int
1043 Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1044 {
1045     int flags = 0;
1046
1047 #if defined(PERL_IMPLICIT_CONTEXT)
1048     if (aTHX != NULL)
1049 #endif
1050 #ifdef SECURE_INTERNAL_GETENV
1051         flags = (PL_curinterp ? TAINTING_get : will_taint) ?
1052                  PERL__TRNENV_SECURE : 0;
1053 #endif
1054
1055     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1056 }
1057 /*}}}*/
1058
1059 /* my_getenv
1060  * Note: Uses Perl temp to store result so char * can be returned to
1061  * caller; this pointer will be invalidated at next Perl statement
1062  * transition.
1063  * We define this as a function rather than a macro in terms of my_getenv_len()
1064  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1065  * allocate SVs).
1066  */
1067 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1068 char *
1069 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1070 {
1071     const char *cp1;
1072     static char *__my_getenv_eqv = NULL;
1073     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1074     unsigned long int idx = 0;
1075     int success, secure;
1076     int midx, flags;
1077     SV *tmpsv;
1078
1079     midx = my_maxidx(lnm) + 1;
1080
1081     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1082       /* Set up a temporary buffer for the return value; Perl will
1083        * clean it up at the next statement transition */
1084       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1085       if (!tmpsv) return NULL;
1086       eqv = SvPVX(tmpsv);
1087     }
1088     else {
1089       /* Assume no interpreter ==> single thread */
1090       if (__my_getenv_eqv != NULL) {
1091         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1092       }
1093       else {
1094         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1095       }
1096       eqv = __my_getenv_eqv;
1097     }
1098
1099     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1100     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1101       int len;
1102       getcwd(eqv,LNM$C_NAMLENGTH);
1103
1104       len = strlen(eqv);
1105
1106       /* Get rid of "000000/ in rooted filespecs */
1107       if (len > 7) {
1108         char * zeros;
1109         zeros = strstr(eqv, "/000000/");
1110         if (zeros != NULL) {
1111           int mlen;
1112           mlen = len - (zeros - eqv) - 7;
1113           memmove(zeros, &zeros[7], mlen);
1114           len = len - 7;
1115           eqv[len] = '\0';
1116         }
1117       }
1118       return eqv;
1119     }
1120     else {
1121       /* Impose security constraints only if tainting */
1122       if (sys) {
1123         /* Impose security constraints only if tainting */
1124         secure = PL_curinterp ? TAINTING_get : will_taint;
1125       }
1126       else {
1127         secure = 0;
1128       }
1129
1130       flags =
1131 #ifdef SECURE_INTERNAL_GETENV
1132               secure ? PERL__TRNENV_SECURE : 0
1133 #else
1134               0
1135 #endif
1136       ;
1137
1138       /* For the getenv interface we combine all the equivalence names
1139        * of a search list logical into one value to acquire a maximum
1140        * value length of 255*128 (assuming %ENV is using logicals).
1141        */
1142       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1143
1144       /* If the name contains a semicolon-delimited index, parse it
1145        * off and make sure we only retrieve the equivalence name for
1146        * that index.  */
1147       if ((cp2 = strchr(lnm,';')) != NULL) {
1148         my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1149         idx = strtoul(cp2+1,NULL,0);
1150         lnm = uplnm;
1151         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1152       }
1153
1154       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1155
1156       return success ? eqv : NULL;
1157     }
1158
1159 }  /* end of my_getenv() */
1160 /*}}}*/
1161
1162
1163 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1164 char *
1165 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1166 {
1167     const char *cp1;
1168     char *buf, *cp2;
1169     unsigned long idx = 0;
1170     int midx, flags;
1171     static char *__my_getenv_len_eqv = NULL;
1172     int secure;
1173     SV *tmpsv;
1174
1175     midx = my_maxidx(lnm) + 1;
1176
1177     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1178       /* Set up a temporary buffer for the return value; Perl will
1179        * clean it up at the next statement transition */
1180       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1181       if (!tmpsv) return NULL;
1182       buf = SvPVX(tmpsv);
1183     }
1184     else {
1185       /* Assume no interpreter ==> single thread */
1186       if (__my_getenv_len_eqv != NULL) {
1187         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1188       }
1189       else {
1190         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1191       }
1192       buf = __my_getenv_len_eqv;
1193     }
1194
1195     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1196     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1197     char * zeros;
1198
1199       getcwd(buf,LNM$C_NAMLENGTH);
1200       *len = strlen(buf);
1201
1202       /* Get rid of "000000/ in rooted filespecs */
1203       if (*len > 7) {
1204       zeros = strstr(buf, "/000000/");
1205       if (zeros != NULL) {
1206         int mlen;
1207         mlen = *len - (zeros - buf) - 7;
1208         memmove(zeros, &zeros[7], mlen);
1209         *len = *len - 7;
1210         buf[*len] = '\0';
1211         }
1212       }
1213       return buf;
1214     }
1215     else {
1216       if (sys) {
1217         /* Impose security constraints only if tainting */
1218         secure = PL_curinterp ? TAINTING_get : will_taint;
1219       }
1220       else {
1221         secure = 0;
1222       }
1223
1224       flags =
1225 #ifdef SECURE_INTERNAL_GETENV
1226               secure ? PERL__TRNENV_SECURE : 0
1227 #else
1228               0
1229 #endif
1230       ;
1231
1232       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1233
1234       if ((cp2 = strchr(lnm,';')) != NULL) {
1235         my_strlcpy(buf, lnm, cp2 - lnm + 1);
1236         idx = strtoul(cp2+1,NULL,0);
1237         lnm = buf;
1238         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1239       }
1240
1241       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1242
1243       /* Get rid of "000000/ in rooted filespecs */
1244       if (*len > 7) {
1245         char * zeros;
1246         zeros = strstr(buf, "/000000/");
1247         if (zeros != NULL) {
1248           int mlen;
1249           mlen = *len - (zeros - buf) - 7;
1250           memmove(zeros, &zeros[7], mlen);
1251           *len = *len - 7;
1252           buf[*len] = '\0';
1253         }
1254       }
1255
1256       return *len ? buf : NULL;
1257     }
1258
1259 }  /* end of my_getenv_len() */
1260 /*}}}*/
1261
1262 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1263
1264 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1265
1266 /*{{{ void prime_env_iter() */
1267 void
1268 prime_env_iter(void)
1269 /* Fill the %ENV associative array with all logical names we can
1270  * find, in preparation for iterating over it.
1271  */
1272 {
1273   static int primed = 0;
1274   HV *seenhv = NULL, *envhv;
1275   SV *sv = NULL;
1276   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1277   unsigned short int chan;
1278 #ifndef CLI$M_TRUSTED
1279 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1280 #endif
1281   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1282   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1283   long int i;
1284   bool have_sym = FALSE, have_lnm = FALSE;
1285   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1286   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1287   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1288   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1289   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1290 #if defined(PERL_IMPLICIT_CONTEXT)
1291   pTHX;
1292 #endif
1293 #if defined(USE_ITHREADS)
1294   static perl_mutex primenv_mutex;
1295   MUTEX_INIT(&primenv_mutex);
1296 #endif
1297
1298 #if defined(PERL_IMPLICIT_CONTEXT)
1299     /* We jump through these hoops because we can be called at */
1300     /* platform-specific initialization time, which is before anything is */
1301     /* set up--we can't even do a plain dTHX since that relies on the */
1302     /* interpreter structure to be initialized */
1303     if (PL_curinterp) {
1304       aTHX = PERL_GET_INTERP;
1305     } else {
1306       /* we never get here because the NULL pointer will cause the */
1307       /* several of the routines called by this routine to access violate */
1308
1309       /* This routine is only called by hv.c/hv_iterinit which has a */
1310       /* context, so the real fix may be to pass it through instead of */
1311       /* the hoops above */
1312       aTHX = NULL;
1313     }
1314 #endif
1315
1316   if (primed || !PL_envgv) return;
1317   MUTEX_LOCK(&primenv_mutex);
1318   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1319   envhv = GvHVn(PL_envgv);
1320   /* Perform a dummy fetch as an lval to insure that the hash table is
1321    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1322   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1323
1324   for (i = 0; env_tables[i]; i++) {
1325      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1326          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1327      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1328   }
1329   if (have_sym || have_lnm) {
1330     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1331     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1332     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1333     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1334   }
1335
1336   for (i--; i >= 0; i--) {
1337     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1338       char *start;
1339       int j;
1340       for (j = 0; environ[j]; j++) {
1341         if (!(start = strchr(environ[j],'='))) {
1342           if (ckWARN(WARN_INTERNAL))
1343             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1344         }
1345         else {
1346           start++;
1347           sv = newSVpv(start,0);
1348           SvTAINTED_on(sv);
1349           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1350         }
1351       }
1352       continue;
1353     }
1354     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1355              !str$case_blind_compare(&tmpdsc,&clisym)) {
1356       my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1357       cmddsc.dsc$w_length = 20;
1358       if (env_tables[i]->dsc$w_length == 12 &&
1359           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1360           !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local  *", sizeof(cmd)-12);
1361       flags = defflags | CLI$M_NOLOGNAM;
1362     }
1363     else {
1364       my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1365       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1366         my_strlcat(cmd," /Table=", sizeof(cmd));
1367         cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, sizeof(cmd));
1368       }
1369       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1370       flags = defflags | CLI$M_NOCLISYM;
1371     }
1372
1373     /* Create a new subprocess to execute each command, to exclude the
1374      * remote possibility that someone could subvert a mbx or file used
1375      * to write multiple commands to a single subprocess.
1376      */
1377     do {
1378       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1379                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1380       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1381       defflags &= ~CLI$M_TRUSTED;
1382     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1383     _ckvmssts(retsts);
1384     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1385     if (seenhv) SvREFCNT_dec(seenhv);
1386     seenhv = newHV();
1387     while (1) {
1388       char *cp1, *cp2, *key;
1389       unsigned long int sts, iosb[2], retlen, keylen;
1390       U32 hash;
1391
1392       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1393       if (sts & 1) sts = iosb[0] & 0xffff;
1394       if (sts == SS$_ENDOFFILE) {
1395         int wakect = 0;
1396         while (substs == 0) { sys$hiber(); wakect++;}
1397         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1398         _ckvmssts(substs);
1399         break;
1400       }
1401       _ckvmssts(sts);
1402       retlen = iosb[0] >> 16;
1403       if (!retlen) continue;  /* blank line */
1404       buf[retlen] = '\0';
1405       if (iosb[1] != subpid) {
1406         if (iosb[1]) {
1407           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1408         }
1409         continue;
1410       }
1411       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1412         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1413
1414       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1415       if (*cp1 == '(' || /* Logical name table name */
1416           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1417       if (*cp1 == '"') cp1++;
1418       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1419       key = cp1;  keylen = cp2 - cp1;
1420       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1421       while (*cp2 && *cp2 != '=') cp2++;
1422       while (*cp2 && *cp2 == '=') cp2++;
1423       while (*cp2 && *cp2 == ' ') cp2++;
1424       if (*cp2 == '"') {  /* String translation; may embed "" */
1425         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1426         cp2++;  cp1--; /* Skip "" surrounding translation */
1427       }
1428       else {  /* Numeric translation */
1429         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1430         cp1--;  /* stop on last non-space char */
1431       }
1432       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1433         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1434         continue;
1435       }
1436       PERL_HASH(hash,key,keylen);
1437
1438       if (cp1 == cp2 && *cp2 == '.') {
1439         /* A single dot usually means an unprintable character, such as a null
1440          * to indicate a zero-length value.  Get the actual value to make sure.
1441          */
1442         char lnm[LNM$C_NAMLENGTH+1];
1443         char eqv[MAX_DCL_SYMBOL+1];
1444         int trnlen;
1445         strncpy(lnm, key, keylen);
1446         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1447         sv = newSVpvn(eqv, strlen(eqv));
1448       }
1449       else {
1450         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1451       }
1452
1453       SvTAINTED_on(sv);
1454       hv_store(envhv,key,keylen,sv,hash);
1455       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1456     }
1457     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1458       /* get the PPFs for this process, not the subprocess */
1459       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1460       char eqv[LNM$C_NAMLENGTH+1];
1461       int trnlen, i;
1462       for (i = 0; ppfs[i]; i++) {
1463         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1464         sv = newSVpv(eqv,trnlen);
1465         SvTAINTED_on(sv);
1466         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1467       }
1468     }
1469   }
1470   primed = 1;
1471   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1472   if (buf) Safefree(buf);
1473   if (seenhv) SvREFCNT_dec(seenhv);
1474   MUTEX_UNLOCK(&primenv_mutex);
1475   return;
1476
1477 }  /* end of prime_env_iter */
1478 /*}}}*/
1479
1480
1481 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1482 /* Define or delete an element in the same "environment" as
1483  * vmstrnenv().  If an element is to be deleted, it's removed from
1484  * the first place it's found.  If it's to be set, it's set in the
1485  * place designated by the first element of the table vector.
1486  * Like setenv() returns 0 for success, non-zero on error.
1487  */
1488 int
1489 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1490 {
1491     const char *cp1;
1492     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1493     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1494     int nseg = 0, j;
1495     unsigned long int retsts, usermode = PSL$C_USER;
1496     struct itmlst_3 *ile, *ilist;
1497     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1498                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1499                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1500     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1501     $DESCRIPTOR(local,"_LOCAL");
1502
1503     if (!lnm) {
1504         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1505         return SS$_IVLOGNAM;
1506     }
1507
1508     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1509       *cp2 = _toupper(*cp1);
1510       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1511         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1512         return SS$_IVLOGNAM;
1513       }
1514     }
1515     lnmdsc.dsc$w_length = cp1 - lnm;
1516     if (!tabvec || !*tabvec) tabvec = env_tables;
1517
1518     if (!eqv) {  /* we're deleting n element */
1519       for (curtab = 0; tabvec[curtab]; curtab++) {
1520         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1521         int i;
1522           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1523             if ((cp1 = strchr(environ[i],'=')) &&
1524                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1525                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1526 #ifdef HAS_SETENV
1527               return setenv(lnm,"",1) ? vaxc$errno : 0;
1528             }
1529           }
1530           ivenv = 1; retsts = SS$_NOLOGNAM;
1531 #else
1532               if (ckWARN(WARN_INTERNAL))
1533                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1534               ivenv = 1; retsts = SS$_NOSUCHPGM;
1535               break;
1536             }
1537           }
1538 #endif
1539         }
1540         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1541                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1542           unsigned int symtype;
1543           if (tabvec[curtab]->dsc$w_length == 12 &&
1544               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1545               !str$case_blind_compare(&tmpdsc,&local))
1546             symtype = LIB$K_CLI_LOCAL_SYM;
1547           else symtype = LIB$K_CLI_GLOBAL_SYM;
1548           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1549           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1550           if (retsts == LIB$_NOSUCHSYM) continue;
1551           break;
1552         }
1553         else if (!ivlnm) {
1554           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1555           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1556           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1557           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1558           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1559         }
1560       }
1561     }
1562     else {  /* we're defining a value */
1563       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1564 #ifdef HAS_SETENV
1565         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1566 #else
1567         if (ckWARN(WARN_INTERNAL))
1568           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1569         retsts = SS$_NOSUCHPGM;
1570 #endif
1571       }
1572       else {
1573         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1574         eqvdsc.dsc$w_length  = strlen(eqv);
1575         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1576             !str$case_blind_compare(&tmpdsc,&clisym)) {
1577           unsigned int symtype;
1578           if (tabvec[0]->dsc$w_length == 12 &&
1579               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1580                !str$case_blind_compare(&tmpdsc,&local))
1581             symtype = LIB$K_CLI_LOCAL_SYM;
1582           else symtype = LIB$K_CLI_GLOBAL_SYM;
1583           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1584         }
1585         else {
1586           if (!*eqv) eqvdsc.dsc$w_length = 1;
1587           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1588
1589             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1590             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1591               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1592                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1593               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1594               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1595             }
1596
1597             Newx(ilist,nseg+1,struct itmlst_3);
1598             ile = ilist;
1599             if (!ile) {
1600               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1601               return SS$_INSFMEM;
1602             }
1603             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1604
1605             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1606               ile->itmcode = LNM$_STRING;
1607               ile->bufadr = c;
1608               if ((j+1) == nseg) {
1609                 ile->buflen = strlen(c);
1610                 /* in case we are truncating one that's too long */
1611                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1612               }
1613               else {
1614                 ile->buflen = LNM$C_NAMLENGTH;
1615               }
1616             }
1617
1618             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1619             Safefree (ilist);
1620           }
1621           else {
1622             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1623           }
1624         }
1625       }
1626     }
1627     if (!(retsts & 1)) {
1628       switch (retsts) {
1629         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1630         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1631           set_errno(EVMSERR); break;
1632         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1633         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1634           set_errno(EINVAL); break;
1635         case SS$_NOPRIV:
1636           set_errno(EACCES); break;
1637         default:
1638           _ckvmssts(retsts);
1639           set_errno(EVMSERR);
1640        }
1641        set_vaxc_errno(retsts);
1642        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1643     }
1644     else {
1645       /* We reset error values on success because Perl does an hv_fetch()
1646        * before each hv_store(), and if the thing we're setting didn't
1647        * previously exist, we've got a leftover error message.  (Of course,
1648        * this fails in the face of
1649        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1650        * in that the error reported in $! isn't spurious,
1651        * but it's right more often than not.)
1652        */
1653       set_errno(0); set_vaxc_errno(retsts);
1654       return 0;
1655     }
1656
1657 }  /* end of vmssetenv() */
1658 /*}}}*/
1659
1660 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1661 /* This has to be a function since there's a prototype for it in proto.h */
1662 void
1663 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1664 {
1665     if (lnm && *lnm) {
1666       int len = strlen(lnm);
1667       if  (len == 7) {
1668         char uplnm[8];
1669         int i;
1670         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1671         if (!strcmp(uplnm,"DEFAULT")) {
1672           if (eqv && *eqv) my_chdir(eqv);
1673           return;
1674         }
1675     }
1676   }
1677   (void) vmssetenv(lnm,eqv,NULL);
1678 }
1679 /*}}}*/
1680
1681 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1682 /*  vmssetuserlnm
1683  *  sets a user-mode logical in the process logical name table
1684  *  used for redirection of sys$error
1685  */
1686 void
1687 Perl_vmssetuserlnm(const char *name, const char *eqv)
1688 {
1689     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1690     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1691     unsigned long int iss, attr = LNM$M_CONFINE;
1692     unsigned char acmode = PSL$C_USER;
1693     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1694                                  {0, 0, 0, 0}};
1695     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1696     d_name.dsc$w_length = strlen(name);
1697
1698     lnmlst[0].buflen = strlen(eqv);
1699     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1700
1701     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1702     if (!(iss&1)) lib$signal(iss);
1703 }
1704 /*}}}*/
1705
1706
1707 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1708 /* my_crypt - VMS password hashing
1709  * my_crypt() provides an interface compatible with the Unix crypt()
1710  * C library function, and uses sys$hash_password() to perform VMS
1711  * password hashing.  The quadword hashed password value is returned
1712  * as a NUL-terminated 8 character string.  my_crypt() does not change
1713  * the case of its string arguments; in order to match the behavior
1714  * of LOGINOUT et al., alphabetic characters in both arguments must
1715  *  be upcased by the caller.
1716  *
1717  * - fix me to call ACM services when available
1718  */
1719 char *
1720 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1721 {
1722 #   ifndef UAI$C_PREFERRED_ALGORITHM
1723 #     define UAI$C_PREFERRED_ALGORITHM 127
1724 #   endif
1725     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1726     unsigned short int salt = 0;
1727     unsigned long int sts;
1728     struct const_dsc {
1729         unsigned short int dsc$w_length;
1730         unsigned char      dsc$b_type;
1731         unsigned char      dsc$b_class;
1732         const char *       dsc$a_pointer;
1733     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1734        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1735     struct itmlst_3 uailst[3] = {
1736         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1737         { sizeof salt, UAI$_SALT,    &salt, 0},
1738         { 0,           0,            NULL,  NULL}};
1739     static char hash[9];
1740
1741     usrdsc.dsc$w_length = strlen(usrname);
1742     usrdsc.dsc$a_pointer = usrname;
1743     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1744       switch (sts) {
1745         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1746           set_errno(EACCES);
1747           break;
1748         case RMS$_RNF:
1749           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1750           break;
1751         default:
1752           set_errno(EVMSERR);
1753       }
1754       set_vaxc_errno(sts);
1755       if (sts != RMS$_RNF) return NULL;
1756     }
1757
1758     txtdsc.dsc$w_length = strlen(textpasswd);
1759     txtdsc.dsc$a_pointer = textpasswd;
1760     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1761       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1762     }
1763
1764     return (char *) hash;
1765
1766 }  /* end of my_crypt() */
1767 /*}}}*/
1768
1769
1770 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1771 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1772 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1773
1774 /* 8.3, remove() is now broken on symbolic links */
1775 static int rms_erase(const char * vmsname);
1776
1777
1778 /* mp_do_kill_file
1779  * A little hack to get around a bug in some implementation of remove()
1780  * that do not know how to delete a directory
1781  *
1782  * Delete any file to which user has control access, regardless of whether
1783  * delete access is explicitly allowed.
1784  * Limitations: User must have write access to parent directory.
1785  *              Does not block signals or ASTs; if interrupted in midstream
1786  *              may leave file with an altered ACL.
1787  * HANDLE WITH CARE!
1788  */
1789 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1790 static int
1791 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1792 {
1793     char *vmsname;
1794     char *rslt;
1795     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1796     unsigned long int cxt = 0, aclsts, fndsts;
1797     int rmsts = -1;
1798     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1799     struct myacedef {
1800       unsigned char myace$b_length;
1801       unsigned char myace$b_type;
1802       unsigned short int myace$w_flags;
1803       unsigned long int myace$l_access;
1804       unsigned long int myace$l_ident;
1805     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1806                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1807       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1808      struct itmlst_3
1809        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1810                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1811        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1812        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1813        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1814        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1815
1816     /* Expand the input spec using RMS, since the CRTL remove() and
1817      * system services won't do this by themselves, so we may miss
1818      * a file "hiding" behind a logical name or search list. */
1819     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1820     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1821
1822     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1823     if (rslt == NULL) {
1824         PerlMem_free(vmsname);
1825         return -1;
1826       }
1827
1828     /* Erase the file */
1829     rmsts = rms_erase(vmsname);
1830
1831     /* Did it succeed */
1832     if ($VMS_STATUS_SUCCESS(rmsts)) {
1833         PerlMem_free(vmsname);
1834         return 0;
1835       }
1836
1837     /* If not, can changing protections help? */
1838     if (rmsts != RMS$_PRV) {
1839       set_vaxc_errno(rmsts);
1840       PerlMem_free(vmsname);
1841       return -1;
1842     }
1843
1844     /* No, so we get our own UIC to use as a rights identifier,
1845      * and the insert an ACE at the head of the ACL which allows us
1846      * to delete the file.
1847      */
1848     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1849     fildsc.dsc$w_length = strlen(vmsname);
1850     fildsc.dsc$a_pointer = vmsname;
1851     cxt = 0;
1852     newace.myace$l_ident = oldace.myace$l_ident;
1853     rmsts = -1;
1854     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1855       switch (aclsts) {
1856         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1857           set_errno(ENOENT); break;
1858         case RMS$_DIR:
1859           set_errno(ENOTDIR); break;
1860         case RMS$_DEV:
1861           set_errno(ENODEV); break;
1862         case RMS$_SYN: case SS$_INVFILFOROP:
1863           set_errno(EINVAL); break;
1864         case RMS$_PRV:
1865           set_errno(EACCES); break;
1866         default:
1867           _ckvmssts_noperl(aclsts);
1868       }
1869       set_vaxc_errno(aclsts);
1870       PerlMem_free(vmsname);
1871       return -1;
1872     }
1873     /* Grab any existing ACEs with this identifier in case we fail */
1874     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1875     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1876                     || fndsts == SS$_NOMOREACE ) {
1877       /* Add the new ACE . . . */
1878       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1879         goto yourroom;
1880
1881       rmsts = rms_erase(vmsname);
1882       if ($VMS_STATUS_SUCCESS(rmsts)) {
1883         rmsts = 0;
1884         }
1885         else {
1886         rmsts = -1;
1887         /* We blew it - dir with files in it, no write priv for
1888          * parent directory, etc.  Put things back the way they were. */
1889         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1890           goto yourroom;
1891         if (fndsts & 1) {
1892           addlst[0].bufadr = &oldace;
1893           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1894             goto yourroom;
1895         }
1896       }
1897     }
1898
1899     yourroom:
1900     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1901     /* We just deleted it, so of course it's not there.  Some versions of
1902      * VMS seem to return success on the unlock operation anyhow (after all
1903      * the unlock is successful), but others don't.
1904      */
1905     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1906     if (aclsts & 1) aclsts = fndsts;
1907     if (!(aclsts & 1)) {
1908       set_errno(EVMSERR);
1909       set_vaxc_errno(aclsts);
1910     }
1911
1912     PerlMem_free(vmsname);
1913     return rmsts;
1914
1915 }  /* end of kill_file() */
1916 /*}}}*/
1917
1918
1919 /*{{{int do_rmdir(char *name)*/
1920 int
1921 Perl_do_rmdir(pTHX_ const char *name)
1922 {
1923     char * dirfile;
1924     int retval;
1925     Stat_t st;
1926
1927     /* lstat returns a VMS fileified specification of the name */
1928     /* that is looked up, and also lets verifies that this is a directory */
1929
1930     retval = flex_lstat(name, &st);
1931     if (retval != 0) {
1932         char * ret_spec;
1933
1934         /* Due to a historical feature, flex_stat/lstat can not see some */
1935         /* Unix format file names that the rest of the CRTL can see */
1936         /* Fixing that feature will cause some perl tests to fail */
1937         /* So try this one more time. */
1938
1939         retval = lstat(name, &st.crtl_stat);
1940         if (retval != 0)
1941             return -1;
1942
1943         /* force it to a file spec for the kill file to work. */
1944         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1945         if (ret_spec == NULL) {
1946             errno = EIO;
1947             return -1;
1948         }
1949     }
1950
1951     if (!S_ISDIR(st.st_mode)) {
1952         errno = ENOTDIR;
1953         retval = -1;
1954     }
1955     else {
1956         dirfile = st.st_devnam;
1957
1958         /* It may be possible for flex_stat to find a file and vmsify() to */
1959         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
1960         /* with that case, so fail it */
1961         if (dirfile[0] == 0) {
1962             errno = EIO;
1963             return -1;
1964         }
1965
1966         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1967     }
1968
1969     return retval;
1970
1971 }  /* end of do_rmdir */
1972 /*}}}*/
1973
1974 /* kill_file
1975  * Delete any file to which user has control access, regardless of whether
1976  * delete access is explicitly allowed.
1977  * Limitations: User must have write access to parent directory.
1978  *              Does not block signals or ASTs; if interrupted in midstream
1979  *              may leave file with an altered ACL.
1980  * HANDLE WITH CARE!
1981  */
1982 /*{{{int kill_file(char *name)*/
1983 int
1984 Perl_kill_file(pTHX_ const char *name)
1985 {
1986     char * vmsfile;
1987     Stat_t st;
1988     int rmsts;
1989
1990     /* Convert the filename to VMS format and see if it is a directory */
1991     /* flex_lstat returns a vmsified file specification */
1992     rmsts = flex_lstat(name, &st);
1993     if (rmsts != 0) {
1994
1995         /* Due to a historical feature, flex_stat/lstat can not see some */
1996         /* Unix format file names that the rest of the CRTL can see when */
1997         /* ODS-2 file specifications are in use. */
1998         /* Fixing that feature will cause some perl tests to fail */
1999         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2000         st.st_mode = 0;
2001         vmsfile = (char *) name; /* cast ok */
2002
2003     } else {
2004         vmsfile = st.st_devnam;
2005         if (vmsfile[0] == 0) {
2006             /* It may be possible for flex_stat to find a file and vmsify() */
2007             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2008             /* deal with that case, so fail it */
2009             errno = EIO;
2010             return -1;
2011         }
2012     }
2013
2014     /* Remove() is allowed to delete directories, according to the X/Open
2015      * specifications.
2016      * This may need special handling to work with the ACL hacks.
2017      */
2018     if (S_ISDIR(st.st_mode)) {
2019         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2020         return rmsts;
2021     }
2022
2023     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2024
2025     /* Need to delete all versions ? */
2026     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2027         int i = 0;
2028
2029         /* Just use lstat() here as do not need st_dev */
2030         /* and we know that the file is in VMS format or that */
2031         /* because of a historical bug, flex_stat can not see the file */
2032         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2033             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2034             if (rmsts != 0)
2035                 break;
2036             i++;
2037
2038             /* Make sure that we do not loop forever */
2039             if (i > 32767) {
2040                 errno = EIO;
2041                 rmsts = -1;
2042                 break;
2043             }
2044         }
2045     }
2046
2047     return rmsts;
2048
2049 }  /* end of kill_file() */
2050 /*}}}*/
2051
2052
2053 /*{{{int my_mkdir(char *,Mode_t)*/
2054 int
2055 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2056 {
2057   STRLEN dirlen = strlen(dir);
2058
2059   /* zero length string sometimes gives ACCVIO */
2060   if (dirlen == 0) return -1;
2061
2062   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2063    * null file name/type.  However, it's commonplace under Unix,
2064    * so we'll allow it for a gain in portability.
2065    */
2066   if (dir[dirlen-1] == '/') {
2067     char *newdir = savepvn(dir,dirlen-1);
2068     int ret = mkdir(newdir,mode);
2069     Safefree(newdir);
2070     return ret;
2071   }
2072   else return mkdir(dir,mode);
2073 }  /* end of my_mkdir */
2074 /*}}}*/
2075
2076 /*{{{int my_chdir(char *)*/
2077 int
2078 Perl_my_chdir(pTHX_ const char *dir)
2079 {
2080   STRLEN dirlen = strlen(dir);
2081   const char *dir1 = dir;
2082
2083   /* zero length string sometimes gives ACCVIO */
2084   if (dirlen == 0) {
2085     SETERRNO(EINVAL, SS$_BADPARAM);
2086     return -1;
2087   }
2088
2089   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2090    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2091    * so that existing scripts do not need to be changed.
2092    */
2093   while ((dirlen > 0) && (*dir1 == ' ')) {
2094     dir1++;
2095     dirlen--;
2096   }
2097
2098   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2099    * that implies
2100    * null file name/type.  However, it's commonplace under Unix,
2101    * so we'll allow it for a gain in portability.
2102    *
2103    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2104    */
2105   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2106       char *newdir;
2107       int ret;
2108       newdir = (char *)PerlMem_malloc(dirlen);
2109       if (newdir ==NULL)
2110           _ckvmssts_noperl(SS$_INSFMEM);
2111       memcpy(newdir, dir1, dirlen-1);
2112       newdir[dirlen-1] = '\0';
2113       ret = chdir(newdir);
2114       PerlMem_free(newdir);
2115       return ret;
2116   }
2117   else return chdir(dir1);
2118 }  /* end of my_chdir */
2119 /*}}}*/
2120
2121
2122 /*{{{int my_chmod(char *, mode_t)*/
2123 int
2124 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2125 {
2126   Stat_t st;
2127   int ret = -1;
2128   char * changefile;
2129   STRLEN speclen = strlen(file_spec);
2130
2131   /* zero length string sometimes gives ACCVIO */
2132   if (speclen == 0) return -1;
2133
2134   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2135    * that implies null file name/type.  However, it's commonplace under Unix,
2136    * so we'll allow it for a gain in portability.
2137    *
2138    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2139    * in VMS file.dir notation.
2140    */
2141   changefile = (char *) file_spec; /* cast ok */
2142   ret = flex_lstat(file_spec, &st);
2143   if (ret != 0) {
2144
2145         /* Due to a historical feature, flex_stat/lstat can not see some */
2146         /* Unix format file names that the rest of the CRTL can see when */
2147         /* ODS-2 file specifications are in use. */
2148         /* Fixing that feature will cause some perl tests to fail */
2149         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2150         st.st_mode = 0;
2151
2152   } else {
2153       /* It may be possible to get here with nothing in st_devname */
2154       /* chmod still may work though */
2155       if (st.st_devnam[0] != 0) {
2156           changefile = st.st_devnam;
2157       }
2158   }
2159   ret = chmod(changefile, mode);
2160   return ret;
2161 }  /* end of my_chmod */
2162 /*}}}*/
2163
2164
2165 /*{{{FILE *my_tmpfile()*/
2166 FILE *
2167 my_tmpfile(void)
2168 {
2169   FILE *fp;
2170   char *cp;
2171
2172   if ((fp = tmpfile())) return fp;
2173
2174   cp = (char *)PerlMem_malloc(L_tmpnam+24);
2175   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2176
2177   if (decc_filename_unix_only == 0)
2178     strcpy(cp,"Sys$Scratch:");
2179   else
2180     strcpy(cp,"/tmp/");
2181   tmpnam(cp+strlen(cp));
2182   strcat(cp,".Perltmp");
2183   fp = fopen(cp,"w+","fop=dlt");
2184   PerlMem_free(cp);
2185   return fp;
2186 }
2187 /*}}}*/
2188
2189
2190 /*
2191  * The C RTL's sigaction fails to check for invalid signal numbers so we
2192  * help it out a bit.  The docs are correct, but the actual routine doesn't
2193  * do what the docs say it will.
2194  */
2195 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2196 int
2197 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2198                    struct sigaction* oact)
2199 {
2200   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2201         SETERRNO(EINVAL, SS$_INVARG);
2202         return -1;
2203   }
2204   return sigaction(sig, act, oact);
2205 }
2206 /*}}}*/
2207
2208 #ifdef KILL_BY_SIGPRC
2209 #include <errnodef.h>
2210
2211 /* We implement our own kill() using the undocumented system service
2212    sys$sigprc for one of two reasons:
2213
2214    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2215    target process to do a sys$exit, which usually can't be handled
2216    gracefully...certainly not by Perl and the %SIG{} mechanism.
2217
2218    2.) If the kill() in the CRTL can't be called from a signal
2219    handler without disappearing into the ether, i.e., the signal
2220    it purportedly sends is never trapped. Still true as of VMS 7.3.
2221
2222    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2223    in the target process rather than calling sys$exit.
2224
2225    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2226    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2227    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2228    with condition codes C$_SIG0+nsig*8, catching the exception on the
2229    target process and resignaling with appropriate arguments.
2230
2231    But we don't have that VMS 7.0+ exception handler, so if you
2232    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2233
2234    Also note that SIGTERM is listed in the docs as being "unimplemented",
2235    yet always seems to be signaled with a VMS condition code of 4 (and
2236    correctly handled for that code).  So we hardwire it in.
2237
2238    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2239    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2240    than signalling with an unrecognized (and unhandled by CRTL) code.
2241 */
2242
2243 #define _MY_SIG_MAX 28
2244
2245 static unsigned int
2246 Perl_sig_to_vmscondition_int(int sig)
2247 {
2248     static unsigned int sig_code[_MY_SIG_MAX+1] =
2249     {
2250         0,                  /*  0 ZERO     */
2251         SS$_HANGUP,         /*  1 SIGHUP   */
2252         SS$_CONTROLC,       /*  2 SIGINT   */
2253         SS$_CONTROLY,       /*  3 SIGQUIT  */
2254         SS$_RADRMOD,        /*  4 SIGILL   */
2255         SS$_BREAK,          /*  5 SIGTRAP  */
2256         SS$_OPCCUS,         /*  6 SIGABRT  */
2257         SS$_COMPAT,         /*  7 SIGEMT   */
2258 #ifdef __VAX
2259         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2260 #else
2261         SS$_HPARITH,        /*  8 SIGFPE AXP */
2262 #endif
2263         SS$_ABORT,          /*  9 SIGKILL  */
2264         SS$_ACCVIO,         /* 10 SIGBUS   */
2265         SS$_ACCVIO,         /* 11 SIGSEGV  */
2266         SS$_BADPARAM,       /* 12 SIGSYS   */
2267         SS$_NOMBX,          /* 13 SIGPIPE  */
2268         SS$_ASTFLT,         /* 14 SIGALRM  */
2269         4,                  /* 15 SIGTERM  */
2270         0,                  /* 16 SIGUSR1  */
2271         0,                  /* 17 SIGUSR2  */
2272         0,                  /* 18 */
2273         0,                  /* 19 */
2274         0,                  /* 20 SIGCHLD  */
2275         0,                  /* 21 SIGCONT  */
2276         0,                  /* 22 SIGSTOP  */
2277         0,                  /* 23 SIGTSTP  */
2278         0,                  /* 24 SIGTTIN  */
2279         0,                  /* 25 SIGTTOU  */
2280         0,                  /* 26 */
2281         0,                  /* 27 */
2282         0                   /* 28 SIGWINCH  */
2283     };
2284
2285     static int initted = 0;
2286     if (!initted) {
2287         initted = 1;
2288         sig_code[16] = C$_SIGUSR1;
2289         sig_code[17] = C$_SIGUSR2;
2290         sig_code[20] = C$_SIGCHLD;
2291 #if __CRTL_VER >= 70300000
2292         sig_code[28] = C$_SIGWINCH;
2293 #endif
2294     }
2295
2296     if (sig < _SIG_MIN) return 0;
2297     if (sig > _MY_SIG_MAX) return 0;
2298     return sig_code[sig];
2299 }
2300
2301 unsigned int
2302 Perl_sig_to_vmscondition(int sig)
2303 {
2304 #ifdef SS$_DEBUG
2305     if (vms_debug_on_exception != 0)
2306         lib$signal(SS$_DEBUG);
2307 #endif
2308     return Perl_sig_to_vmscondition_int(sig);
2309 }
2310
2311
2312 #define sys$sigprc SYS$SIGPRC
2313 #ifdef __cplusplus
2314 extern "C" {
2315 #endif
2316 int sys$sigprc(unsigned int *pidadr,
2317                struct dsc$descriptor_s *prcname,
2318                unsigned int code);
2319 #ifdef __cplusplus
2320 }
2321 #endif
2322
2323 int
2324 Perl_my_kill(int pid, int sig)
2325 {
2326     int iss;
2327     unsigned int code;
2328
2329      /* sig 0 means validate the PID */
2330     /*------------------------------*/
2331     if (sig == 0) {
2332         const unsigned long int jpicode = JPI$_PID;
2333         pid_t ret_pid;
2334         int status;
2335         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2336         if ($VMS_STATUS_SUCCESS(status))
2337            return 0;
2338         switch (status) {
2339         case SS$_NOSUCHNODE:
2340         case SS$_UNREACHABLE:
2341         case SS$_NONEXPR:
2342            errno = ESRCH;
2343            break;
2344         case SS$_NOPRIV:
2345            errno = EPERM;
2346            break;
2347         default:
2348            errno = EVMSERR;
2349         }
2350         vaxc$errno=status;
2351         return -1;
2352     }
2353
2354     code = Perl_sig_to_vmscondition_int(sig);
2355
2356     if (!code) {
2357         SETERRNO(EINVAL, SS$_BADPARAM);
2358         return -1;
2359     }
2360
2361     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2362      * signals are to be sent to multiple processes.
2363      *  pid = 0 - all processes in group except ones that the system exempts
2364      *  pid = -1 - all processes except ones that the system exempts
2365      *  pid = -n - all processes in group (abs(n)) except ...
2366      * For now, just report as not supported.
2367      */
2368
2369     if (pid <= 0) {
2370         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2371         return -1;
2372     }
2373
2374     iss = sys$sigprc((unsigned int *)&pid,0,code);
2375     if (iss&1) return 0;
2376
2377     switch (iss) {
2378       case SS$_NOPRIV:
2379         set_errno(EPERM);  break;
2380       case SS$_NONEXPR:
2381       case SS$_NOSUCHNODE:
2382       case SS$_UNREACHABLE:
2383         set_errno(ESRCH);  break;
2384       case SS$_INSFMEM:
2385         set_errno(ENOMEM); break;
2386       default:
2387         _ckvmssts_noperl(iss);
2388         set_errno(EVMSERR);
2389     }
2390     set_vaxc_errno(iss);
2391
2392     return -1;
2393 }
2394 #endif
2395
2396 /* Routine to convert a VMS status code to a UNIX status code.
2397 ** More tricky than it appears because of conflicting conventions with
2398 ** existing code.
2399 **
2400 ** VMS status codes are a bit mask, with the least significant bit set for
2401 ** success.
2402 **
2403 ** Special UNIX status of EVMSERR indicates that no translation is currently
2404 ** available, and programs should check the VMS status code.
2405 **
2406 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2407 ** decoding.
2408 */
2409
2410 #ifndef C_FACILITY_NO
2411 #define C_FACILITY_NO 0x350000
2412 #endif
2413 #ifndef DCL_IVVERB
2414 #define DCL_IVVERB 0x38090
2415 #endif
2416
2417 int
2418 Perl_vms_status_to_unix(int vms_status, int child_flag)
2419 {
2420   int facility;
2421   int fac_sp;
2422   int msg_no;
2423   int msg_status;
2424   int unix_status;
2425
2426   /* Assume the best or the worst */
2427   if (vms_status & STS$M_SUCCESS)
2428     unix_status = 0;
2429   else
2430     unix_status = EVMSERR;
2431
2432   msg_status = vms_status & ~STS$M_CONTROL;
2433
2434   facility = vms_status & STS$M_FAC_NO;
2435   fac_sp = vms_status & STS$M_FAC_SP;
2436   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2437
2438   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2439     switch(msg_no) {
2440     case SS$_NORMAL:
2441         unix_status = 0;
2442         break;
2443     case SS$_ACCVIO:
2444         unix_status = EFAULT;
2445         break;
2446     case SS$_DEVOFFLINE:
2447         unix_status = EBUSY;
2448         break;
2449     case SS$_CLEARED:
2450         unix_status = ENOTCONN;
2451         break;
2452     case SS$_IVCHAN:
2453     case SS$_IVLOGNAM:
2454     case SS$_BADPARAM:
2455     case SS$_IVLOGTAB:
2456     case SS$_NOLOGNAM:
2457     case SS$_NOLOGTAB:
2458     case SS$_INVFILFOROP:
2459     case SS$_INVARG:
2460     case SS$_NOSUCHID:
2461     case SS$_IVIDENT:
2462         unix_status = EINVAL;
2463         break;
2464     case SS$_UNSUPPORTED:
2465         unix_status = ENOTSUP;
2466         break;
2467     case SS$_FILACCERR:
2468     case SS$_NOGRPPRV:
2469     case SS$_NOSYSPRV:
2470         unix_status = EACCES;
2471         break;
2472     case SS$_DEVICEFULL:
2473         unix_status = ENOSPC;
2474         break;
2475     case SS$_NOSUCHDEV:
2476         unix_status = ENODEV;
2477         break;
2478     case SS$_NOSUCHFILE:
2479     case SS$_NOSUCHOBJECT:
2480         unix_status = ENOENT;
2481         break;
2482     case SS$_ABORT:                                 /* Fatal case */
2483     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2484     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2485         unix_status = EINTR;
2486         break;
2487     case SS$_BUFFEROVF:
2488         unix_status = E2BIG;
2489         break;
2490     case SS$_INSFMEM:
2491         unix_status = ENOMEM;
2492         break;
2493     case SS$_NOPRIV:
2494         unix_status = EPERM;
2495         break;
2496     case SS$_NOSUCHNODE:
2497     case SS$_UNREACHABLE:
2498         unix_status = ESRCH;
2499         break;
2500     case SS$_NONEXPR:
2501         unix_status = ECHILD;
2502         break;
2503     default:
2504         if ((facility == 0) && (msg_no < 8)) {
2505           /* These are not real VMS status codes so assume that they are
2506           ** already UNIX status codes
2507           */
2508           unix_status = msg_no;
2509           break;
2510         }
2511     }
2512   }
2513   else {
2514     /* Translate a POSIX exit code to a UNIX exit code */
2515     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2516         unix_status = (msg_no & 0x07F8) >> 3;
2517     }
2518     else {
2519
2520          /* Documented traditional behavior for handling VMS child exits */
2521         /*--------------------------------------------------------------*/
2522         if (child_flag != 0) {
2523
2524              /* Success / Informational return 0 */
2525             /*----------------------------------*/
2526             if (msg_no & STS$K_SUCCESS)
2527                 return 0;
2528
2529              /* Warning returns 1 */
2530             /*-------------------*/
2531             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2532                 return 1;
2533
2534              /* Everything else pass through the severity bits */
2535             /*------------------------------------------------*/
2536             return (msg_no & STS$M_SEVERITY);
2537         }
2538
2539          /* Normal VMS status to ERRNO mapping attempt */
2540         /*--------------------------------------------*/
2541         switch(msg_status) {
2542         /* case RMS$_EOF: */ /* End of File */
2543         case RMS$_FNF:  /* File Not Found */
2544         case RMS$_DNF:  /* Dir Not Found */
2545                 unix_status = ENOENT;
2546                 break;
2547         case RMS$_RNF:  /* Record Not Found */
2548                 unix_status = ESRCH;
2549                 break;
2550         case RMS$_DIR:
2551                 unix_status = ENOTDIR;
2552                 break;
2553         case RMS$_DEV:
2554                 unix_status = ENODEV;
2555                 break;
2556         case RMS$_IFI:
2557         case RMS$_FAC:
2558         case RMS$_ISI:
2559                 unix_status = EBADF;
2560                 break;
2561         case RMS$_FEX:
2562                 unix_status = EEXIST;
2563                 break;
2564         case RMS$_SYN:
2565         case RMS$_FNM:
2566         case LIB$_INVSTRDES:
2567         case LIB$_INVARG:
2568         case LIB$_NOSUCHSYM:
2569         case LIB$_INVSYMNAM:
2570         case DCL_IVVERB:
2571                 unix_status = EINVAL;
2572                 break;
2573         case CLI$_BUFOVF:
2574         case RMS$_RTB:
2575         case CLI$_TKNOVF:
2576         case CLI$_RSLOVF:
2577                 unix_status = E2BIG;
2578                 break;
2579         case RMS$_PRV:  /* No privilege */
2580         case RMS$_ACC:  /* ACP file access failed */
2581         case RMS$_WLK:  /* Device write locked */
2582                 unix_status = EACCES;
2583                 break;
2584         case RMS$_MKD:  /* Failed to mark for delete */
2585                 unix_status = EPERM;
2586                 break;
2587         /* case RMS$_NMF: */  /* No more files */
2588         }
2589     }
2590   }
2591
2592   return unix_status;
2593 }
2594
2595 /* Try to guess at what VMS error status should go with a UNIX errno
2596  * value.  This is hard to do as there could be many possible VMS
2597  * error statuses that caused the errno value to be set.
2598  */
2599
2600 int
2601 Perl_unix_status_to_vms(int unix_status)
2602 {
2603     int test_unix_status;
2604
2605      /* Trivial cases first */
2606     /*---------------------*/
2607     if (unix_status == EVMSERR)
2608         return vaxc$errno;
2609
2610      /* Is vaxc$errno sane? */
2611     /*---------------------*/
2612     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2613     if (test_unix_status == unix_status)
2614         return vaxc$errno;
2615
2616      /* If way out of range, must be VMS code already */
2617     /*-----------------------------------------------*/
2618     if (unix_status > EVMSERR)
2619         return unix_status;
2620
2621      /* If out of range, punt */
2622     /*-----------------------*/
2623     if (unix_status > __ERRNO_MAX)
2624         return SS$_ABORT;
2625
2626
2627      /* Ok, now we have to do it the hard way. */
2628     /*----------------------------------------*/
2629     switch(unix_status) {
2630     case 0:     return SS$_NORMAL;
2631     case EPERM: return SS$_NOPRIV;
2632     case ENOENT: return SS$_NOSUCHOBJECT;
2633     case ESRCH: return SS$_UNREACHABLE;
2634     case EINTR: return SS$_ABORT;
2635     /* case EIO: */
2636     /* case ENXIO:  */
2637     case E2BIG: return SS$_BUFFEROVF;
2638     /* case ENOEXEC */
2639     case EBADF: return RMS$_IFI;
2640     case ECHILD: return SS$_NONEXPR;
2641     /* case EAGAIN */
2642     case ENOMEM: return SS$_INSFMEM;
2643     case EACCES: return SS$_FILACCERR;
2644     case EFAULT: return SS$_ACCVIO;
2645     /* case ENOTBLK */
2646     case EBUSY: return SS$_DEVOFFLINE;
2647     case EEXIST: return RMS$_FEX;
2648     /* case EXDEV */
2649     case ENODEV: return SS$_NOSUCHDEV;
2650     case ENOTDIR: return RMS$_DIR;
2651     /* case EISDIR */
2652     case EINVAL: return SS$_INVARG;
2653     /* case ENFILE */
2654     /* case EMFILE */
2655     /* case ENOTTY */
2656     /* case ETXTBSY */
2657     /* case EFBIG */
2658     case ENOSPC: return SS$_DEVICEFULL;
2659     case ESPIPE: return LIB$_INVARG;
2660     /* case EROFS: */
2661     /* case EMLINK: */
2662     /* case EPIPE: */
2663     /* case EDOM */
2664     case ERANGE: return LIB$_INVARG;
2665     /* case EWOULDBLOCK */
2666     /* case EINPROGRESS */
2667     /* case EALREADY */
2668     /* case ENOTSOCK */
2669     /* case EDESTADDRREQ */
2670     /* case EMSGSIZE */
2671     /* case EPROTOTYPE */
2672     /* case ENOPROTOOPT */
2673     /* case EPROTONOSUPPORT */
2674     /* case ESOCKTNOSUPPORT */
2675     /* case EOPNOTSUPP */
2676     /* case EPFNOSUPPORT */
2677     /* case EAFNOSUPPORT */
2678     /* case EADDRINUSE */
2679     /* case EADDRNOTAVAIL */
2680     /* case ENETDOWN */
2681     /* case ENETUNREACH */
2682     /* case ENETRESET */
2683     /* case ECONNABORTED */
2684     /* case ECONNRESET */
2685     /* case ENOBUFS */
2686     /* case EISCONN */
2687     case ENOTCONN: return SS$_CLEARED;
2688     /* case ESHUTDOWN */
2689     /* case ETOOMANYREFS */
2690     /* case ETIMEDOUT */
2691     /* case ECONNREFUSED */
2692     /* case ELOOP */
2693     /* case ENAMETOOLONG */
2694     /* case EHOSTDOWN */
2695     /* case EHOSTUNREACH */
2696     /* case ENOTEMPTY */
2697     /* case EPROCLIM */
2698     /* case EUSERS  */
2699     /* case EDQUOT  */
2700     /* case ENOMSG  */
2701     /* case EIDRM */
2702     /* case EALIGN */
2703     /* case ESTALE */
2704     /* case EREMOTE */
2705     /* case ENOLCK */
2706     /* case ENOSYS */
2707     /* case EFTYPE */
2708     /* case ECANCELED */
2709     /* case EFAIL */
2710     /* case EINPROG */
2711     case ENOTSUP:
2712         return SS$_UNSUPPORTED;
2713     /* case EDEADLK */
2714     /* case ENWAIT */
2715     /* case EILSEQ */
2716     /* case EBADCAT */
2717     /* case EBADMSG */
2718     /* case EABANDONED */
2719     default:
2720         return SS$_ABORT; /* punt */
2721     }
2722 }
2723
2724
2725 /* default piping mailbox size */
2726 #ifdef __VAX
2727 #  define PERL_BUFSIZ        512
2728 #else
2729 #  define PERL_BUFSIZ        8192
2730 #endif
2731
2732
2733 static void
2734 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2735 {
2736   unsigned long int mbxbufsiz;
2737   static unsigned long int syssize = 0;
2738   unsigned long int dviitm = DVI$_DEVNAM;
2739   char csize[LNM$C_NAMLENGTH+1];
2740   int sts;
2741
2742   if (!syssize) {
2743     unsigned long syiitm = SYI$_MAXBUF;
2744     /*
2745      * Get the SYSGEN parameter MAXBUF
2746      *
2747      * If the logical 'PERL_MBX_SIZE' is defined
2748      * use the value of the logical instead of PERL_BUFSIZ, but
2749      * keep the size between 128 and MAXBUF.
2750      *
2751      */
2752     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2753   }
2754
2755   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2756       mbxbufsiz = atoi(csize);
2757   } else {
2758       mbxbufsiz = PERL_BUFSIZ;
2759   }
2760   if (mbxbufsiz < 128) mbxbufsiz = 128;
2761   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2762
2763   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2764
2765   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2766   _ckvmssts_noperl(sts);
2767   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2768
2769 }  /* end of create_mbx() */
2770
2771
2772 /*{{{  my_popen and my_pclose*/
2773
2774 typedef struct _iosb           IOSB;
2775 typedef struct _iosb*         pIOSB;
2776 typedef struct _pipe           Pipe;
2777 typedef struct _pipe*         pPipe;
2778 typedef struct pipe_details    Info;
2779 typedef struct pipe_details*  pInfo;
2780 typedef struct _srqp            RQE;
2781 typedef struct _srqp*          pRQE;
2782 typedef struct _tochildbuf      CBuf;
2783 typedef struct _tochildbuf*    pCBuf;
2784
2785 struct _iosb {
2786     unsigned short status;
2787     unsigned short count;
2788     unsigned long  dvispec;
2789 };
2790
2791 #pragma member_alignment save
2792 #pragma nomember_alignment quadword
2793 struct _srqp {          /* VMS self-relative queue entry */
2794     unsigned long qptr[2];
2795 };
2796 #pragma member_alignment restore
2797 static RQE  RQE_ZERO = {0,0};
2798
2799 struct _tochildbuf {
2800     RQE             q;
2801     int             eof;
2802     unsigned short  size;
2803     char            *buf;
2804 };
2805
2806 struct _pipe {
2807     RQE            free;
2808     RQE            wait;
2809     int            fd_out;
2810     unsigned short chan_in;
2811     unsigned short chan_out;
2812     char          *buf;
2813     unsigned int   bufsize;
2814     IOSB           iosb;
2815     IOSB           iosb2;
2816     int           *pipe_done;
2817     int            retry;
2818     int            type;
2819     int            shut_on_empty;
2820     int            need_wake;
2821     pPipe         *home;
2822     pInfo          info;
2823     pCBuf          curr;
2824     pCBuf          curr2;
2825 #if defined(PERL_IMPLICIT_CONTEXT)
2826     void            *thx;           /* Either a thread or an interpreter */
2827                                     /* pointer, depending on how we're built */
2828 #endif
2829 };
2830
2831
2832 struct pipe_details
2833 {
2834     pInfo           next;
2835     PerlIO *fp;  /* file pointer to pipe mailbox */
2836     int useFILE; /* using stdio, not perlio */
2837     int pid;   /* PID of subprocess */
2838     int mode;  /* == 'r' if pipe open for reading */
2839     int done;  /* subprocess has completed */
2840     int waiting; /* waiting for completion/closure */
2841     int             closing;        /* my_pclose is closing this pipe */
2842     unsigned long   completion;     /* termination status of subprocess */
2843     pPipe           in;             /* pipe in to sub */
2844     pPipe           out;            /* pipe out of sub */
2845     pPipe           err;            /* pipe of sub's sys$error */
2846     int             in_done;        /* true when in pipe finished */
2847     int             out_done;
2848     int             err_done;
2849     unsigned short  xchan;          /* channel to debug xterm */
2850     unsigned short  xchan_valid;    /* channel is assigned */
2851 };
2852
2853 struct exit_control_block
2854 {
2855     struct exit_control_block *flink;
2856     unsigned long int (*exit_routine)(void);
2857     unsigned long int arg_count;
2858     unsigned long int *status_address;
2859     unsigned long int exit_status;
2860 };
2861
2862 typedef struct _closed_pipes    Xpipe;
2863 typedef struct _closed_pipes*  pXpipe;
2864
2865 struct _closed_pipes {
2866     int             pid;            /* PID of subprocess */
2867     unsigned long   completion;     /* termination status of subprocess */
2868 };
2869 #define NKEEPCLOSED 50
2870 static Xpipe closed_list[NKEEPCLOSED];
2871 static int   closed_index = 0;
2872 static int   closed_num = 0;
2873
2874 #define RETRY_DELAY     "0 ::0.20"
2875 #define MAX_RETRY              50
2876
2877 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2878 static unsigned long mypid;
2879 static unsigned long delaytime[2];
2880
2881 static pInfo open_pipes = NULL;
2882 static $DESCRIPTOR(nl_desc, "NL:");
2883
2884 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2885
2886
2887
2888 static unsigned long int
2889 pipe_exit_routine(void)
2890 {
2891     pInfo info;
2892     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2893     int sts, did_stuff, j;
2894
2895    /*
2896     * Flush any pending i/o, but since we are in process run-down, be
2897     * careful about referencing PerlIO structures that may already have
2898     * been deallocated.  We may not even have an interpreter anymore.
2899     */
2900     info = open_pipes;
2901     while (info) {
2902         if (info->fp) {
2903 #if defined(PERL_IMPLICIT_CONTEXT)
2904            /* We need to use the Perl context of the thread that created */
2905            /* the pipe. */
2906            pTHX;
2907            if (info->err)
2908                aTHX = info->err->thx;
2909            else if (info->out)
2910                aTHX = info->out->thx;
2911            else if (info->in)
2912                aTHX = info->in->thx;
2913 #endif
2914            if (!info->useFILE
2915 #if defined(USE_ITHREADS)
2916              && my_perl
2917 #endif
2918 #ifdef USE_PERLIO
2919              && PL_perlio_fd_refcnt
2920 #endif
2921               )
2922                PerlIO_flush(info->fp);
2923            else
2924                fflush((FILE *)info->fp);
2925         }
2926         info = info->next;
2927     }
2928
2929     /*
2930      next we try sending an EOF...ignore if doesn't work, make sure we
2931      don't hang
2932     */
2933     did_stuff = 0;
2934     info = open_pipes;
2935
2936     while (info) {
2937       _ckvmssts_noperl(sys$setast(0));
2938       if (info->in && !info->in->shut_on_empty) {
2939         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2940                                  0, 0, 0, 0, 0, 0));
2941         info->waiting = 1;
2942         did_stuff = 1;
2943       }
2944       _ckvmssts_noperl(sys$setast(1));
2945       info = info->next;
2946     }
2947
2948     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2949
2950     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2951         int nwait = 0;
2952
2953         info = open_pipes;
2954         while (info) {
2955           _ckvmssts_noperl(sys$setast(0));
2956           if (info->waiting && info->done)
2957                 info->waiting = 0;
2958           nwait += info->waiting;
2959           _ckvmssts_noperl(sys$setast(1));
2960           info = info->next;
2961         }
2962         if (!nwait) break;
2963         sleep(1);
2964     }
2965
2966     did_stuff = 0;
2967     info = open_pipes;
2968     while (info) {
2969       _ckvmssts_noperl(sys$setast(0));
2970       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2971         sts = sys$forcex(&info->pid,0,&abort);
2972         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2973         did_stuff = 1;
2974       }
2975       _ckvmssts_noperl(sys$setast(1));
2976       info = info->next;
2977     }
2978
2979     /* again, wait for effect */
2980
2981     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2982         int nwait = 0;
2983
2984         info = open_pipes;
2985         while (info) {
2986           _ckvmssts_noperl(sys$setast(0));
2987           if (info->waiting && info->done)
2988                 info->waiting = 0;
2989           nwait += info->waiting;
2990           _ckvmssts_noperl(sys$setast(1));
2991           info = info->next;
2992         }
2993         if (!nwait) break;
2994         sleep(1);
2995     }
2996
2997     info = open_pipes;
2998     while (info) {
2999       _ckvmssts_noperl(sys$setast(0));
3000       if (!info->done) {  /* We tried to be nice . . . */
3001         sts = sys$delprc(&info->pid,0);
3002         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3003         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3004       }
3005       _ckvmssts_noperl(sys$setast(1));
3006       info = info->next;
3007     }
3008
3009     while(open_pipes) {
3010
3011 #if defined(PERL_IMPLICIT_CONTEXT)
3012       /* We need to use the Perl context of the thread that created */
3013       /* the pipe. */
3014       pTHX;
3015       if (open_pipes->err)
3016           aTHX = open_pipes->err->thx;
3017       else if (open_pipes->out)
3018           aTHX = open_pipes->out->thx;
3019       else if (open_pipes->in)
3020           aTHX = open_pipes->in->thx;
3021 #endif
3022       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3023       else if (!(sts & 1)) retsts = sts;
3024     }
3025     return retsts;
3026 }
3027
3028 static struct exit_control_block pipe_exitblock =
3029        {(struct exit_control_block *) 0,
3030         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3031
3032 static void pipe_mbxtofd_ast(pPipe p);
3033 static void pipe_tochild1_ast(pPipe p);
3034 static void pipe_tochild2_ast(pPipe p);
3035
3036 static void
3037 popen_completion_ast(pInfo info)
3038 {
3039   pInfo i = open_pipes;
3040   int iss;
3041
3042   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3043   closed_list[closed_index].pid = info->pid;
3044   closed_list[closed_index].completion = info->completion;
3045   closed_index++;
3046   if (closed_index == NKEEPCLOSED)
3047     closed_index = 0;
3048   closed_num++;
3049
3050   while (i) {
3051     if (i == info) break;
3052     i = i->next;
3053   }
3054   if (!i) return;       /* unlinked, probably freed too */
3055
3056   info->done = TRUE;
3057
3058 /*
3059     Writing to subprocess ...
3060             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3061
3062             chan_out may be waiting for "done" flag, or hung waiting
3063             for i/o completion to child...cancel the i/o.  This will
3064             put it into "snarf mode" (done but no EOF yet) that discards
3065             input.
3066
3067     Output from subprocess (stdout, stderr) needs to be flushed and
3068     shut down.   We try sending an EOF, but if the mbx is full the pipe
3069     routine should still catch the "shut_on_empty" flag, telling it to
3070     use immediate-style reads so that "mbx empty" -> EOF.
3071
3072
3073 */
3074   if (info->in && !info->in_done) {               /* only for mode=w */
3075         if (info->in->shut_on_empty && info->in->need_wake) {
3076             info->in->need_wake = FALSE;
3077             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3078         } else {
3079             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3080         }
3081   }
3082
3083   if (info->out && !info->out_done) {             /* were we also piping output? */
3084       info->out->shut_on_empty = TRUE;
3085       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3086       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3087       _ckvmssts_noperl(iss);
3088   }
3089
3090   if (info->err && !info->err_done) {        /* we were piping stderr */
3091         info->err->shut_on_empty = TRUE;
3092         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3093         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3094         _ckvmssts_noperl(iss);
3095   }
3096   _ckvmssts_noperl(sys$setef(pipe_ef));
3097
3098 }
3099
3100 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3101 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3102 static void pipe_infromchild_ast(pPipe p);
3103
3104 /*
3105     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3106     inside an AST routine without worrying about reentrancy and which Perl
3107     memory allocator is being used.
3108
3109     We read data and queue up the buffers, then spit them out one at a
3110     time to the output mailbox when the output mailbox is ready for one.
3111
3112 */
3113 #define INITIAL_TOCHILDQUEUE  2
3114
3115 static pPipe
3116 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3117 {
3118     pPipe p;
3119     pCBuf b;
3120     char mbx1[64], mbx2[64];
3121     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3122                                       DSC$K_CLASS_S, mbx1},
3123                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3124                                       DSC$K_CLASS_S, mbx2};
3125     unsigned int dviitm = DVI$_DEVBUFSIZ;
3126     int j, n;
3127
3128     n = sizeof(Pipe);
3129     _ckvmssts_noperl(lib$get_vm(&n, &p));
3130
3131     create_mbx(&p->chan_in , &d_mbx1);
3132     create_mbx(&p->chan_out, &d_mbx2);
3133     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3134
3135     p->buf           = 0;
3136     p->shut_on_empty = FALSE;
3137     p->need_wake     = FALSE;
3138     p->type          = 0;
3139     p->retry         = 0;
3140     p->iosb.status   = SS$_NORMAL;
3141     p->iosb2.status  = SS$_NORMAL;
3142     p->free          = RQE_ZERO;
3143     p->wait          = RQE_ZERO;
3144     p->curr          = 0;
3145     p->curr2         = 0;
3146     p->info          = 0;
3147 #ifdef PERL_IMPLICIT_CONTEXT
3148     p->thx           = aTHX;
3149 #endif
3150
3151     n = sizeof(CBuf) + p->bufsize;
3152
3153     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3154         _ckvmssts_noperl(lib$get_vm(&n, &b));
3155         b->buf = (char *) b + sizeof(CBuf);
3156         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3157     }
3158
3159     pipe_tochild2_ast(p);
3160     pipe_tochild1_ast(p);
3161     strcpy(wmbx, mbx1);
3162     strcpy(rmbx, mbx2);
3163     return p;
3164 }
3165
3166 /*  reads the MBX Perl is writing, and queues */
3167
3168 static void
3169 pipe_tochild1_ast(pPipe p)
3170 {
3171     pCBuf b = p->curr;
3172     int iss = p->iosb.status;
3173     int eof = (iss == SS$_ENDOFFILE);
3174     int sts;
3175 #ifdef PERL_IMPLICIT_CONTEXT
3176     pTHX = p->thx;
3177 #endif
3178
3179     if (p->retry) {
3180         if (eof) {
3181             p->shut_on_empty = TRUE;
3182             b->eof     = TRUE;
3183             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3184         } else  {
3185             _ckvmssts_noperl(iss);
3186         }
3187
3188         b->eof  = eof;
3189         b->size = p->iosb.count;
3190         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3191         if (p->need_wake) {
3192             p->need_wake = FALSE;
3193             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3194         }
3195     } else {
3196         p->retry = 1;   /* initial call */
3197     }
3198
3199     if (eof) {                  /* flush the free queue, return when done */
3200         int n = sizeof(CBuf) + p->bufsize;
3201         while (1) {
3202             iss = lib$remqti(&p->free, &b);
3203             if (iss == LIB$_QUEWASEMP) return;
3204             _ckvmssts_noperl(iss);
3205             _ckvmssts_noperl(lib$free_vm(&n, &b));
3206         }
3207     }
3208
3209     iss = lib$remqti(&p->free, &b);
3210     if (iss == LIB$_QUEWASEMP) {
3211         int n = sizeof(CBuf) + p->bufsize;
3212         _ckvmssts_noperl(lib$get_vm(&n, &b));
3213         b->buf = (char *) b + sizeof(CBuf);
3214     } else {
3215        _ckvmssts_noperl(iss);
3216     }
3217
3218     p->curr = b;
3219     iss = sys$qio(0,p->chan_in,
3220              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3221              &p->iosb,
3222              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3223     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3224     _ckvmssts_noperl(iss);
3225 }
3226
3227
3228 /* writes queued buffers to output, waits for each to complete before
3229    doing the next */
3230
3231 static void
3232 pipe_tochild2_ast(pPipe p)
3233 {
3234     pCBuf b = p->curr2;
3235     int iss = p->iosb2.status;
3236     int n = sizeof(CBuf) + p->bufsize;
3237     int done = (p->info && p->info->done) ||
3238               iss == SS$_CANCEL || iss == SS$_ABORT;
3239 #if defined(PERL_IMPLICIT_CONTEXT)
3240     pTHX = p->thx;
3241 #endif
3242
3243     do {
3244         if (p->type) {         /* type=1 has old buffer, dispose */
3245             if (p->shut_on_empty) {
3246                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3247             } else {
3248                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3249             }
3250             p->type = 0;
3251         }
3252
3253         iss = lib$remqti(&p->wait, &b);
3254         if (iss == LIB$_QUEWASEMP) {
3255             if (p->shut_on_empty) {
3256                 if (done) {
3257                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3258                     *p->pipe_done = TRUE;
3259                     _ckvmssts_noperl(sys$setef(pipe_ef));
3260                 } else {
3261                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3262                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3263                 }
3264                 return;
3265             }
3266             p->need_wake = TRUE;
3267             return;
3268         }
3269         _ckvmssts_noperl(iss);
3270         p->type = 1;
3271     } while (done);
3272
3273
3274     p->curr2 = b;
3275     if (b->eof) {
3276         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3277             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3278     } else {
3279         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3280             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3281     }
3282
3283     return;
3284
3285 }
3286
3287
3288 static pPipe
3289 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3290 {
3291     pPipe p;
3292     char mbx1[64], mbx2[64];
3293     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3294                                       DSC$K_CLASS_S, mbx1},
3295                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3296                                       DSC$K_CLASS_S, mbx2};
3297     unsigned int dviitm = DVI$_DEVBUFSIZ;
3298
3299     int n = sizeof(Pipe);
3300     _ckvmssts_noperl(lib$get_vm(&n, &p));
3301     create_mbx(&p->chan_in , &d_mbx1);
3302     create_mbx(&p->chan_out, &d_mbx2);
3303
3304     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3305     n = p->bufsize * sizeof(char);
3306     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3307     p->shut_on_empty = FALSE;
3308     p->info   = 0;
3309     p->type   = 0;
3310     p->iosb.status = SS$_NORMAL;
3311 #if defined(PERL_IMPLICIT_CONTEXT)
3312     p->thx = aTHX;
3313 #endif
3314     pipe_infromchild_ast(p);
3315
3316     strcpy(wmbx, mbx1);
3317     strcpy(rmbx, mbx2);
3318     return p;
3319 }
3320
3321 static void
3322 pipe_infromchild_ast(pPipe p)
3323 {
3324     int iss = p->iosb.status;
3325     int eof = (iss == SS$_ENDOFFILE);
3326     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3327     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3328 #if defined(PERL_IMPLICIT_CONTEXT)
3329     pTHX = p->thx;
3330 #endif
3331
3332     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3333         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3334         p->chan_out = 0;
3335     }
3336
3337     /* read completed:
3338             input shutdown if EOF from self (done or shut_on_empty)
3339             output shutdown if closing flag set (my_pclose)
3340             send data/eof from child or eof from self
3341             otherwise, re-read (snarf of data from child)
3342     */
3343
3344     if (p->type == 1) {
3345         p->type = 0;
3346         if (myeof && p->chan_in) {                  /* input shutdown */
3347             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3348             p->chan_in = 0;
3349         }
3350
3351         if (p->chan_out) {
3352             if (myeof || kideof) {      /* pass EOF to parent */
3353                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3354                                          pipe_infromchild_ast, p,
3355                                          0, 0, 0, 0, 0, 0));
3356                 return;
3357             } else if (eof) {       /* eat EOF --- fall through to read*/
3358
3359             } else {                /* transmit data */
3360                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3361                                          pipe_infromchild_ast,p,
3362                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3363                 return;
3364             }
3365         }
3366     }
3367
3368     /*  everything shut? flag as done */
3369
3370     if (!p->chan_in && !p->chan_out) {
3371         *p->pipe_done = TRUE;
3372         _ckvmssts_noperl(sys$setef(pipe_ef));
3373         return;
3374     }
3375
3376     /* write completed (or read, if snarfing from child)
3377             if still have input active,
3378                queue read...immediate mode if shut_on_empty so we get EOF if empty
3379             otherwise,
3380                check if Perl reading, generate EOFs as needed
3381     */
3382
3383     if (p->type == 0) {
3384         p->type = 1;
3385         if (p->chan_in) {
3386             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3387                           pipe_infromchild_ast,p,
3388                           p->buf, p->bufsize, 0, 0, 0, 0);
3389             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3390             _ckvmssts_noperl(iss);
3391         } else {           /* send EOFs for extra reads */
3392             p->iosb.status = SS$_ENDOFFILE;
3393             p->iosb.dvispec = 0;
3394             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3395                                      0, 0, 0,
3396                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3397         }
3398     }
3399 }
3400
3401 static pPipe
3402 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3403 {
3404     pPipe p;
3405     char mbx[64];
3406     unsigned long dviitm = DVI$_DEVBUFSIZ;
3407     struct stat s;
3408     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3409                                       DSC$K_CLASS_S, mbx};
3410     int n = sizeof(Pipe);
3411
3412     /* things like terminals and mbx's don't need this filter */
3413     if (fd && fstat(fd,&s) == 0) {
3414         unsigned long devchar;
3415         char device[65];
3416         unsigned short dev_len;
3417         struct dsc$descriptor_s d_dev;
3418         char * cptr;
3419         struct item_list_3 items[3];
3420         int status;
3421         unsigned short dvi_iosb[4];
3422
3423         cptr = getname(fd, out, 1);
3424         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3425         d_dev.dsc$a_pointer = out;
3426         d_dev.dsc$w_length = strlen(out);
3427         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3428         d_dev.dsc$b_class = DSC$K_CLASS_S;
3429
3430         items[0].len = 4;
3431         items[0].code = DVI$_DEVCHAR;
3432         items[0].bufadr = &devchar;
3433         items[0].retadr = NULL;
3434         items[1].len = 64;
3435         items[1].code = DVI$_FULLDEVNAM;
3436         items[1].bufadr = device;
3437         items[1].retadr = &dev_len;
3438         items[2].len = 0;
3439         items[2].code = 0;
3440
3441         status = sys$getdviw
3442                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3443         _ckvmssts_noperl(status);
3444         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3445             device[dev_len] = 0;
3446
3447             if (!(devchar & DEV$M_DIR)) {
3448                 strcpy(out, device);
3449                 return 0;
3450             }
3451         }
3452     }
3453
3454     _ckvmssts_noperl(lib$get_vm(&n, &p));
3455     p->fd_out = dup(fd);
3456     create_mbx(&p->chan_in, &d_mbx);
3457     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3458     n = (p->bufsize+1) * sizeof(char);
3459     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3460     p->shut_on_empty = FALSE;
3461     p->retry = 0;
3462     p->info  = 0;
3463     strcpy(out, mbx);
3464
3465     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3466                              pipe_mbxtofd_ast, p,
3467                              p->buf, p->bufsize, 0, 0, 0, 0));
3468
3469     return p;
3470 }
3471
3472 static void
3473 pipe_mbxtofd_ast(pPipe p)
3474 {
3475     int iss = p->iosb.status;
3476     int done = p->info->done;
3477     int iss2;
3478     int eof = (iss == SS$_ENDOFFILE);
3479     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3480     int err = !(iss&1) && !eof;
3481 #if defined(PERL_IMPLICIT_CONTEXT)
3482     pTHX = p->thx;
3483 #endif
3484
3485     if (done && myeof) {               /* end piping */
3486         close(p->fd_out);
3487         sys$dassgn(p->chan_in);
3488         *p->pipe_done = TRUE;
3489         _ckvmssts_noperl(sys$setef(pipe_ef));
3490         return;
3491     }
3492
3493     if (!err && !eof) {             /* good data to send to file */
3494         p->buf[p->iosb.count] = '\n';
3495         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3496         if (iss2 < 0) {
3497             p->retry++;
3498             if (p->retry < MAX_RETRY) {
3499                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3500                 return;
3501             }
3502         }
3503         p->retry = 0;
3504     } else if (err) {
3505         _ckvmssts_noperl(iss);
3506     }
3507
3508
3509     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3510           pipe_mbxtofd_ast, p,
3511           p->buf, p->bufsize, 0, 0, 0, 0);
3512     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3513     _ckvmssts_noperl(iss);
3514 }
3515
3516
3517 typedef struct _pipeloc     PLOC;
3518 typedef struct _pipeloc*   pPLOC;
3519
3520 struct _pipeloc {
3521     pPLOC   next;
3522     char    dir[NAM$C_MAXRSS+1];
3523 };
3524 static pPLOC  head_PLOC = 0;
3525
3526 void
3527 free_pipelocs(pTHX_ void *head)
3528 {
3529     pPLOC p, pnext;
3530     pPLOC *pHead = (pPLOC *)head;
3531
3532     p = *pHead;
3533     while (p) {
3534         pnext = p->next;
3535         PerlMem_free(p);
3536         p = pnext;
3537     }
3538     *pHead = 0;
3539 }
3540
3541 static void
3542 store_pipelocs(pTHX)
3543 {
3544     int    i;
3545     pPLOC  p;
3546     AV    *av = 0;
3547     SV    *dirsv;
3548     char  *dir, *x;
3549     char  *unixdir;
3550     char  temp[NAM$C_MAXRSS+1];
3551     STRLEN n_a;
3552
3553     if (head_PLOC)
3554         free_pipelocs(aTHX_ &head_PLOC);
3555
3556 /*  the . directory from @INC comes last */
3557
3558     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3559     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3560     p->next = head_PLOC;
3561     head_PLOC = p;
3562     strcpy(p->dir,"./");
3563
3564 /*  get the directory from $^X */
3565
3566     unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3567     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3568
3569 #ifdef PERL_IMPLICIT_CONTEXT
3570     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3571 #else
3572     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3573 #endif
3574         my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3575         x = strrchr(temp,']');
3576         if (x == NULL) {
3577         x = strrchr(temp,'>');
3578           if (x == NULL) {
3579             /* It could be a UNIX path */
3580             x = strrchr(temp,'/');
3581           }
3582         }
3583         if (x)
3584           x[1] = '\0';
3585         else {
3586           /* Got a bare name, so use default directory */
3587           temp[0] = '.';
3588           temp[1] = '\0';
3589         }
3590
3591         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3592             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3593             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3594             p->next = head_PLOC;
3595             head_PLOC = p;
3596             my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3597         }
3598     }
3599
3600 /*  reverse order of @INC entries, skip "." since entered above */
3601
3602 #ifdef PERL_IMPLICIT_CONTEXT
3603     if (aTHX)
3604 #endif
3605     if (PL_incgv) av = GvAVn(PL_incgv);
3606
3607     for (i = 0; av && i <= AvFILL(av); i++) {
3608         dirsv = *av_fetch(av,i,TRUE);
3609
3610         if (SvROK(dirsv)) continue;
3611         dir = SvPVx(dirsv,n_a);
3612         if (strcmp(dir,".") == 0) continue;
3613         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3614             continue;
3615
3616         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3617         p->next = head_PLOC;
3618         head_PLOC = p;
3619         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3620     }
3621
3622 /* most likely spot (ARCHLIB) put first in the list */
3623
3624 #ifdef ARCHLIB_EXP
3625     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3626         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3627         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3628         p->next = head_PLOC;
3629         head_PLOC = p;
3630         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3631     }
3632 #endif
3633     PerlMem_free(unixdir);
3634 }
3635
3636 static I32 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective,
3637                                   const char *fname, int opts);
3638 #if !defined(PERL_IMPLICIT_CONTEXT)
3639 #define cando_by_name_int               Perl_cando_by_name_int
3640 #else
3641 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3642 #endif
3643
3644 static char *
3645 find_vmspipe(pTHX)
3646 {
3647     static int   vmspipe_file_status = 0;
3648     static char  vmspipe_file[NAM$C_MAXRSS+1];
3649
3650     /* already found? Check and use ... need read+execute permission */
3651
3652     if (vmspipe_file_status == 1) {
3653         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3654          && cando_by_name_int
3655            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3656             return vmspipe_file;
3657         }
3658         vmspipe_file_status = 0;
3659     }
3660
3661     /* scan through stored @INC, $^X */
3662
3663     if (vmspipe_file_status == 0) {
3664         char file[NAM$C_MAXRSS+1];
3665         pPLOC  p = head_PLOC;
3666
3667         while (p) {
3668             char * exp_res;
3669             int dirlen;
3670             dirlen = my_strlcpy(file, p->dir, sizeof(file));
3671             my_strlcat(file, "vmspipe.com", sizeof(file));
3672             p = p->next;
3673
3674             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3675             if (!exp_res) continue;
3676
3677             if (cando_by_name_int
3678                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3679              && cando_by_name_int
3680                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3681                 vmspipe_file_status = 1;
3682                 return vmspipe_file;
3683             }
3684         }
3685         vmspipe_file_status = -1;   /* failed, use tempfiles */
3686     }
3687
3688     return 0;
3689 }
3690
3691 static FILE *
3692 vmspipe_tempfile(pTHX)
3693 {
3694     char file[NAM$C_MAXRSS+1];
3695     FILE *fp;
3696     static int index = 0;
3697     Stat_t s0, s1;
3698     int cmp_result;
3699
3700     /* create a tempfile */
3701
3702     /* we can't go from   W, shr=get to  R, shr=get without
3703        an intermediate vulnerable state, so don't bother trying...
3704
3705        and lib$spawn doesn't shr=put, so have to close the write
3706
3707        So... match up the creation date/time and the FID to
3708        make sure we're dealing with the same file
3709
3710     */
3711
3712     index++;
3713     if (!decc_filename_unix_only) {
3714       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3715       fp = fopen(file,"w");
3716       if (!fp) {
3717         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3718         fp = fopen(file,"w");
3719         if (!fp) {
3720             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3721             fp = fopen(file,"w");
3722         }
3723       }
3724      }
3725      else {
3726       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3727       fp = fopen(file,"w");
3728       if (!fp) {
3729         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3730         fp = fopen(file,"w");
3731         if (!fp) {
3732           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3733           fp = fopen(file,"w");
3734         }
3735       }
3736     }
3737     if (!fp) return 0;  /* we're hosed */
3738
3739     fprintf(fp,"$! 'f$verify(0)'\n");
3740     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3741     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3742     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3743     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3744     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3745     fprintf(fp,"$ perl_del    = \"delete\"\n");
3746     fprintf(fp,"$ pif         = \"if\"\n");
3747     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3748     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3749     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3750     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3751     fprintf(fp,"$!  --- build command line to get max possible length\n");
3752     fprintf(fp,"$c=perl_popen_cmd0\n");
3753     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3754     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3755     fprintf(fp,"$x=perl_popen_cmd3\n");
3756     fprintf(fp,"$c=c+x\n");
3757     fprintf(fp,"$ perl_on\n");
3758     fprintf(fp,"$ 'c'\n");
3759     fprintf(fp,"$ perl_status = $STATUS\n");
3760     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3761     fprintf(fp,"$ perl_exit 'perl_status'\n");
3762     fsync(fileno(fp));
3763
3764     fgetname(fp, file, 1);
3765     fstat(fileno(fp), &s0.crtl_stat);
3766     fclose(fp);
3767
3768     if (decc_filename_unix_only)
3769         int_tounixspec(file, file, NULL);
3770     fp = fopen(file,"r","shr=get");
3771     if (!fp) return 0;
3772     fstat(fileno(fp), &s1.crtl_stat);
3773
3774     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3775     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3776         fclose(fp);
3777         return 0;
3778     }
3779
3780     return fp;
3781 }
3782
3783
3784 static int
3785 vms_is_syscommand_xterm(void)
3786 {
3787     const static struct dsc$descriptor_s syscommand_dsc =
3788       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3789
3790     const static struct dsc$descriptor_s decwdisplay_dsc =
3791       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3792
3793     struct item_list_3 items[2];
3794     unsigned short dvi_iosb[4];
3795     unsigned long devchar;
3796     unsigned long devclass;
3797     int status;
3798
3799     /* Very simple check to guess if sys$command is a decterm? */
3800     /* First see if the DECW$DISPLAY: device exists */
3801     items[0].len = 4;
3802     items[0].code = DVI$_DEVCHAR;
3803     items[0].bufadr = &devchar;
3804     items[0].retadr = NULL;
3805     items[1].len = 0;
3806     items[1].code = 0;
3807
3808     status = sys$getdviw
3809         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3810
3811     if ($VMS_STATUS_SUCCESS(status)) {
3812         status = dvi_iosb[0];
3813     }
3814
3815     if (!$VMS_STATUS_SUCCESS(status)) {
3816         SETERRNO(EVMSERR, status);
3817         return -1;
3818     }
3819
3820     /* If it does, then for now assume that we are on a workstation */
3821     /* Now verify that SYS$COMMAND is a terminal */
3822     /* for creating the debugger DECTerm */
3823
3824     items[0].len = 4;
3825     items[0].code = DVI$_DEVCLASS;
3826     items[0].bufadr = &devclass;
3827     items[0].retadr = NULL;
3828     items[1].len = 0;
3829     items[1].code = 0;
3830
3831     status = sys$getdviw
3832         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3833
3834     if ($VMS_STATUS_SUCCESS(status)) {
3835         status = dvi_iosb[0];
3836     }
3837
3838     if (!$VMS_STATUS_SUCCESS(status)) {
3839         SETERRNO(EVMSERR, status);
3840         return -1;
3841     }
3842     else {
3843         if (devclass == DC$_TERM) {
3844             return 0;
3845         }
3846     }
3847     return -1;
3848 }
3849
3850 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3851 static PerlIO*
3852 create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3853 {
3854     int status;
3855     int ret_stat;
3856     char * ret_char;
3857     char device_name[65];
3858     unsigned short device_name_len;
3859     struct dsc$descriptor_s customization_dsc;
3860     struct dsc$descriptor_s device_name_dsc;
3861     const char * cptr;
3862     char customization[200];
3863     char title[40];
3864     pInfo info = NULL;
3865     char mbx1[64];
3866     unsigned short p_chan;
3867     int n;
3868     unsigned short iosb[4];
3869     const char * cust_str =
3870         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3871     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3872                                           DSC$K_CLASS_S, mbx1};
3873
3874      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3875     /*---------------------------------------*/
3876     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3877
3878
3879     /* Make sure that this is from the Perl debugger */
3880     ret_char = strstr(cmd," xterm ");
3881     if (ret_char == NULL)
3882         return NULL;
3883     cptr = ret_char + 7;
3884     ret_char = strstr(cmd,"tty");
3885     if (ret_char == NULL)
3886         return NULL;
3887     ret_char = strstr(cmd,"sleep");
3888     if (ret_char == NULL)
3889         return NULL;
3890
3891     if (decw_term_port == 0) {
3892         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3893         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3894         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3895
3896        status = lib$find_image_symbol
3897                                (&filename1_dsc,
3898                                 &decw_term_port_dsc,
3899                                 (void *)&decw_term_port,
3900                                 NULL,
3901                                 0);
3902
3903         /* Try again with the other image name */
3904         if (!$VMS_STATUS_SUCCESS(status)) {
3905
3906            status = lib$find_image_symbol
3907                                (&filename2_dsc,
3908                                 &decw_term_port_dsc,
3909                                 (void *)&decw_term_port,
3910                                 NULL,
3911                                 0);
3912
3913         }
3914
3915     }
3916
3917
3918     /* No decw$term_port, give it up */
3919     if (!$VMS_STATUS_SUCCESS(status))
3920         return NULL;
3921
3922     /* Are we on a workstation? */
3923     /* to do: capture the rows / columns and pass their properties */
3924     ret_stat = vms_is_syscommand_xterm();
3925     if (ret_stat < 0)
3926         return NULL;
3927
3928     /* Make the title: */
3929     ret_char = strstr(cptr,"-title");
3930     if (ret_char != NULL) {
3931         while ((*cptr != 0) && (*cptr != '\"')) {
3932             cptr++;
3933         }
3934         if (*cptr == '\"')
3935             cptr++;
3936         n = 0;
3937         while ((*cptr != 0) && (*cptr != '\"')) {
3938             title[n] = *cptr;
3939             n++;
3940             if (n == 39) {
3941                 title[39] = 0;
3942                 break;
3943             }
3944             cptr++;
3945         }
3946         title[n] = 0;
3947     }
3948     else {
3949             /* Default title */
3950             strcpy(title,"Perl Debug DECTerm");
3951     }
3952     sprintf(customization, cust_str, title);
3953
3954     customization_dsc.dsc$a_pointer = customization;
3955     customization_dsc.dsc$w_length = strlen(customization);
3956     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3957     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3958
3959     device_name_dsc.dsc$a_pointer = device_name;
3960     device_name_dsc.dsc$w_length = sizeof device_name -1;
3961     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3962     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3963
3964     device_name_len = 0;
3965
3966     /* Try to create the window */
3967      status = (*decw_term_port)
3968        (NULL,
3969         NULL,
3970         &customization_dsc,
3971         &device_name_dsc,
3972         &device_name_len,
3973         NULL,
3974         NULL,
3975         NULL);
3976     if (!$VMS_STATUS_SUCCESS(status)) {
3977         SETERRNO(EVMSERR, status);
3978         return NULL;
3979     }
3980
3981     device_name[device_name_len] = '\0';
3982
3983     /* Need to set this up to look like a pipe for cleanup */
3984     n = sizeof(Info);
3985     status = lib$get_vm(&n, &info);
3986     if (!$VMS_STATUS_SUCCESS(status)) {
3987         SETERRNO(ENOMEM, status);
3988         return NULL;
3989     }
3990
3991     info->mode = *mode;
3992     info->done = FALSE;
3993     info->completion = 0;
3994     info->closing    = FALSE;
3995     info->in         = 0;
3996     info->out        = 0;
3997     info->err        = 0;
3998     info->fp         = NULL;
3999     info->useFILE    = 0;
4000     info->waiting    = 0;
4001     info->in_done    = TRUE;
4002     info->out_done   = TRUE;
4003     info->err_done   = TRUE;
4004
4005     /* Assign a channel on this so that it will persist, and not login */
4006     /* We stash this channel in the info structure for reference. */
4007     /* The created xterm self destructs when the last channel is removed */
4008     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4009     /* So leave this assigned. */
4010     device_name_dsc.dsc$w_length = device_name_len;
4011     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4012     if (!$VMS_STATUS_SUCCESS(status)) {
4013         SETERRNO(EVMSERR, status);
4014         return NULL;
4015     }
4016     info->xchan_valid = 1;
4017
4018     /* Now create a mailbox to be read by the application */
4019
4020     create_mbx(&p_chan, &d_mbx1);
4021
4022     /* write the name of the created terminal to the mailbox */
4023     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4024             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4025
4026     if (!$VMS_STATUS_SUCCESS(status)) {
4027         SETERRNO(EVMSERR, status);
4028         return NULL;
4029     }
4030
4031     info->fp  = PerlIO_open(mbx1, mode);
4032
4033     /* Done with this channel */
4034     sys$dassgn(p_chan);
4035
4036     /* If any errors, then clean up */
4037     if (!info->fp) {
4038         n = sizeof(Info);
4039         _ckvmssts_noperl(lib$free_vm(&n, &info));
4040         return NULL;
4041         }
4042
4043     /* All done */
4044     return info->fp;
4045 }
4046
4047 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4048
4049 static PerlIO *
4050 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4051 {
4052     static int handler_set_up = FALSE;
4053     PerlIO * ret_fp;
4054     unsigned long int sts, flags = CLI$M_NOWAIT;
4055     /* The use of a GLOBAL table (as was done previously) rendered
4056      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4057      * environment.  Hence we've switched to LOCAL symbol table.
4058      */
4059     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4060     int j, wait = 0, n;
4061     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4062     char *in, *out, *err, mbx[512];
4063     FILE *tpipe = 0;
4064     char tfilebuf[NAM$C_MAXRSS+1];
4065     pInfo info = NULL;
4066     char cmd_sym_name[20];
4067     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4068                                       DSC$K_CLASS_S, symbol};
4069     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4070                                       DSC$K_CLASS_S, 0};
4071     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4072                                       DSC$K_CLASS_S, cmd_sym_name};
4073     struct dsc$descriptor_s *vmscmd;
4074     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4075     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4076     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4077
4078     /* Check here for Xterm create request.  This means looking for
4079      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4080      *  is possible to create an xterm.
4081      */
4082     if (*in_mode == 'r') {
4083         PerlIO * xterm_fd;
4084
4085 #if defined(PERL_IMPLICIT_CONTEXT)
4086         /* Can not fork an xterm with a NULL context */
4087         /* This probably could never happen */
4088         xterm_fd = NULL;
4089         if (aTHX != NULL)
4090 #endif
4091         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4092         if (xterm_fd != NULL)
4093             return xterm_fd;
4094     }
4095
4096     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4097
4098     /* once-per-program initialization...
4099        note that the SETAST calls and the dual test of pipe_ef
4100        makes sure that only the FIRST thread through here does
4101        the initialization...all other threads wait until it's
4102        done.
4103
4104        Yeah, uglier than a pthread call, it's got all the stuff inline
4105        rather than in a separate routine.
4106     */
4107
4108     if (!pipe_ef) {
4109         _ckvmssts_noperl(sys$setast(0));
4110         if (!pipe_ef) {
4111             unsigned long int pidcode = JPI$_PID;
4112             $DESCRIPTOR(d_delay, RETRY_DELAY);
4113             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4114             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4115             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4116         }
4117         if (!handler_set_up) {
4118           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4119           handler_set_up = TRUE;
4120         }
4121         _ckvmssts_noperl(sys$setast(1));
4122     }
4123
4124     /* see if we can find a VMSPIPE.COM */
4125
4126     tfilebuf[0] = '@';
4127     vmspipe = find_vmspipe(aTHX);
4128     if (vmspipe) {
4129         vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4130     } else {        /* uh, oh...we're in tempfile hell */
4131         tpipe = vmspipe_tempfile(aTHX);
4132         if (!tpipe) {       /* a fish popular in Boston */
4133             if (ckWARN(WARN_PIPE)) {
4134                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4135             }
4136         return NULL;
4137         }
4138         fgetname(tpipe,tfilebuf+1,1);
4139         vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4140     }
4141     vmspipedsc.dsc$a_pointer = tfilebuf;
4142
4143     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4144     if (!(sts & 1)) {
4145       switch (sts) {
4146         case RMS$_FNF:  case RMS$_DNF:
4147           set_errno(ENOENT); break;
4148         case RMS$_DIR:
4149           set_errno(ENOTDIR); break;
4150         case RMS$_DEV:
4151           set_errno(ENODEV); break;
4152         case RMS$_PRV:
4153           set_errno(EACCES); break;
4154         case RMS$_SYN:
4155           set_errno(EINVAL); break;
4156         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4157           set_errno(E2BIG); break;
4158         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4159           _ckvmssts_noperl(sts); /* fall through */
4160         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4161           set_errno(EVMSERR);
4162       }
4163       set_vaxc_errno(sts);
4164       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4165         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4166       }
4167       *psts = sts;
4168       return NULL;
4169     }
4170     n = sizeof(Info);
4171     _ckvmssts_noperl(lib$get_vm(&n, &info));
4172
4173     my_strlcpy(mode, in_mode, sizeof(mode));
4174     info->mode = *mode;
4175     info->done = FALSE;
4176     info->completion = 0;
4177     info->closing    = FALSE;
4178     info->in         = 0;
4179     info->out        = 0;
4180     info->err        = 0;
4181     info->fp         = NULL;
4182     info->useFILE    = 0;
4183     info->waiting    = 0;
4184     info->in_done    = TRUE;
4185     info->out_done   = TRUE;
4186     info->err_done   = TRUE;
4187     info->xchan      = 0;
4188     info->xchan_valid = 0;
4189
4190     in = (char *)PerlMem_malloc(VMS_MAXRSS);
4191     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4192     out = (char *)PerlMem_malloc(VMS_MAXRSS);
4193     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4194     err = (char *)PerlMem_malloc(VMS_MAXRSS);
4195     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4196
4197     in[0] = out[0] = err[0] = '\0';
4198
4199     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4200         info->useFILE = 1;
4201         strcpy(p,p+1);
4202     }
4203     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4204         wait = 1;
4205         strcpy(p,p+1);
4206     }
4207
4208     if (*mode == 'r') {             /* piping from subroutine */
4209
4210         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4211         if (info->out) {
4212             info->out->pipe_done = &info->out_done;
4213             info->out_done = FALSE;
4214             info->out->info = info;
4215         }
4216         if (!info->useFILE) {
4217             info->fp  = PerlIO_open(mbx, mode);
4218         } else {
4219             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4220             vmssetuserlnm("SYS$INPUT", mbx);
4221         }
4222
4223         if (!info->fp && info->out) {
4224             sys$cancel(info->out->chan_out);
4225
4226             while (!info->out_done) {
4227                 int done;
4228                 _ckvmssts_noperl(sys$setast(0));
4229                 done = info->out_done;
4230                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4231                 _ckvmssts_noperl(sys$setast(1));
4232                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4233             }
4234
4235             if (info->out->buf) {
4236                 n = info->out->bufsize * sizeof(char);
4237                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4238             }
4239             n = sizeof(Pipe);
4240             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4241             n = sizeof(Info);
4242             _ckvmssts_noperl(lib$free_vm(&n, &info));
4243             *psts = RMS$_FNF;
4244             return NULL;
4245         }
4246
4247         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4248         if (info->err) {
4249             info->err->pipe_done = &info->err_done;
4250             info->err_done = FALSE;
4251             info->err->info = info;
4252         }
4253
4254     } else if (*mode == 'w') {      /* piping to subroutine */
4255
4256         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4257         if (info->out) {
4258             info->out->pipe_done = &info->out_done;
4259             info->out_done = FALSE;
4260             info->out->info = info;
4261         }
4262
4263         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4264         if (info->err) {
4265             info->err->pipe_done = &info->err_done;
4266             info->err_done = FALSE;
4267             info->err->info = info;
4268         }
4269
4270         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4271         if (!info->useFILE) {
4272             info->fp  = PerlIO_open(mbx, mode);
4273         } else {
4274             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4275             vmssetuserlnm("SYS$OUTPUT", mbx);
4276         }
4277
4278         if (info->in) {
4279             info->in->pipe_done = &info->in_done;
4280             info->in_done = FALSE;
4281             info->in->info = info;
4282         }
4283
4284         /* error cleanup */
4285         if (!info->fp && info->in) {
4286             info->done = TRUE;
4287             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4288                                       0, 0, 0, 0, 0, 0, 0, 0));
4289
4290             while (!info->in_done) {
4291                 int done;
4292                 _ckvmssts_noperl(sys$setast(0));
4293                 done = info->in_done;
4294                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4295                 _ckvmssts_noperl(sys$setast(1));
4296                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4297             }
4298
4299             if (info->in->buf) {
4300                 n = info->in->bufsize * sizeof(char);
4301                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4302             }
4303             n = sizeof(Pipe);
4304             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4305             n = sizeof(Info);
4306             _ckvmssts_noperl(lib$free_vm(&n, &info));
4307             *psts = RMS$_FNF;
4308             return NULL;
4309         }
4310
4311
4312     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4313         /* Let the child inherit standard input, unless it's a directory. */
4314         Stat_t st;
4315         if (my_trnlnm("SYS$INPUT", in, 0)) {
4316             if (flex_stat(in, &st) != 0 || S_ISDIR(st.st_mode))
4317                 *in = '\0';
4318         }
4319
4320         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4321         if (info->out) {
4322             info->out->pipe_done = &info->out_done;
4323             info->out_done = FALSE;
4324             info->out->info = info;
4325         }
4326
4327         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4328         if (info->err) {
4329             info->err->pipe_done = &info->err_done;
4330             info->err_done = FALSE;
4331             info->err->info = info;
4332         }
4333     }
4334
4335     d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4336     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4337
4338     d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4339     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4340
4341     d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4342     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4343
4344     /* Done with the names for the pipes */
4345     PerlMem_free(err);
4346     PerlMem_free(out);
4347     PerlMem_free(in);
4348
4349     p = vmscmd->dsc$a_pointer;
4350     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4351     if (*p == '$') p++;                         /* remove leading $ */
4352     while (*p == ' ' || *p == '\t') p++;
4353
4354     for (j = 0; j < 4; j++) {
4355         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4356         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4357
4358     d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4359     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4360
4361         if (strlen(p) > MAX_DCL_SYMBOL) {
4362             p += MAX_DCL_SYMBOL;
4363         } else {
4364             p += strlen(p);
4365         }
4366     }
4367     _ckvmssts_noperl(sys$setast(0));
4368     info->next=open_pipes;  /* prepend to list */
4369     open_pipes=info;
4370     _ckvmssts_noperl(sys$setast(1));
4371     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4372      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4373      * have SYS$COMMAND if we need it.
4374      */
4375     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4376                       0, &info->pid, &info->completion,
4377                       0, popen_completion_ast,info,0,0,0));
4378
4379     /* if we were using a tempfile, close it now */
4380
4381     if (tpipe) fclose(tpipe);
4382
4383     /* once the subprocess is spawned, it has copied the symbols and
4384        we can get rid of ours */
4385
4386     for (j = 0; j < 4; j++) {
4387         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4388         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4389     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4390     }
4391     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4392     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4393     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4394     vms_execfree(vmscmd);
4395
4396 #ifdef PERL_IMPLICIT_CONTEXT
4397     if (aTHX)
4398 #endif
4399     PL_forkprocess = info->pid;
4400
4401     ret_fp = info->fp;
4402     if (wait) {
4403          dSAVEDERRNO;
4404          int done = 0;
4405          while (!done) {
4406              _ckvmssts_noperl(sys$setast(0));
4407              done = info->done;
4408              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4409              _ckvmssts_noperl(sys$setast(1));
4410              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4411          }
4412         *psts = info->completion;
4413 /* Caller thinks it is open and tries to close it. */
4414 /* This causes some problems, as it changes the error status */
4415 /*        my_pclose(info->fp); */
4416
4417          /* If we did not have a file pointer open, then we have to */
4418          /* clean up here or eventually we will run out of something */
4419          SAVE_ERRNO;
4420          if (info->fp == NULL) {
4421              my_pclose_pinfo(aTHX_ info);
4422          }
4423          RESTORE_ERRNO;
4424
4425     } else {
4426         *psts = info->pid;
4427     }
4428     return ret_fp;
4429 }  /* end of safe_popen */
4430
4431
4432 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4433 PerlIO *
4434 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4435 {
4436     int sts;
4437     TAINT_ENV();
4438     TAINT_PROPER("popen");
4439     PERL_FLUSHALL_FOR_CHILD;
4440     return safe_popen(aTHX_ cmd,mode,&sts);
4441 }
4442
4443 /*}}}*/
4444
4445
4446 /* Routine to close and cleanup a pipe info structure */
4447
4448 static I32
4449 my_pclose_pinfo(pTHX_ pInfo info) {
4450
4451     unsigned long int retsts;
4452     int done, n;
4453     pInfo next, last;
4454
4455     /* If we were writing to a subprocess, insure that someone reading from
4456      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4457      * produce an EOF record in the mailbox.
4458      *
4459      *  well, at least sometimes it *does*, so we have to watch out for
4460      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4461      */
4462      if (info->fp) {
4463         if (!info->useFILE
4464 #if defined(USE_ITHREADS)
4465           && my_perl
4466 #endif
4467 #ifdef USE_PERLIO
4468           && PL_perlio_fd_refcnt
4469 #endif
4470            )
4471             PerlIO_flush(info->fp);
4472         else
4473             fflush((FILE *)info->fp);
4474     }
4475
4476     _ckvmssts(sys$setast(0));
4477      info->closing = TRUE;
4478      done = info->done && info->in_done && info->out_done && info->err_done;
4479      /* hanging on write to Perl's input? cancel it */
4480      if (info->mode == 'r' && info->out && !info->out_done) {
4481         if (info->out->chan_out) {
4482             _ckvmssts(sys$cancel(info->out->chan_out));
4483             if (!info->out->chan_in) {   /* EOF generation, need AST */
4484                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4485             }
4486         }
4487      }
4488      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4489          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4490                            0, 0, 0, 0, 0, 0));
4491     _ckvmssts(sys$setast(1));
4492     if (info->fp) {
4493      if (!info->useFILE
4494 #if defined(USE_ITHREADS)
4495          && my_perl
4496 #endif
4497 #ifdef USE_PERLIO
4498          && PL_perlio_fd_refcnt
4499 #endif
4500         )
4501         PerlIO_close(info->fp);
4502      else
4503         fclose((FILE *)info->fp);
4504     }
4505      /*
4506         we have to wait until subprocess completes, but ALSO wait until all
4507         the i/o completes...otherwise we'll be freeing the "info" structure
4508         that the i/o ASTs could still be using...
4509      */
4510
4511      while (!done) {
4512          _ckvmssts(sys$setast(0));
4513          done = info->done && info->in_done && info->out_done && info->err_done;
4514          if (!done) _ckvmssts(sys$clref(pipe_ef));
4515          _ckvmssts(sys$setast(1));
4516          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4517      }
4518      retsts = info->completion;
4519
4520     /* remove from list of open pipes */
4521     _ckvmssts(sys$setast(0));
4522     last = NULL;
4523     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4524         if (next == info)
4525             break;
4526     }
4527
4528     if (last)
4529         last->next = info->next;
4530     else
4531         open_pipes = info->next;
4532     _ckvmssts(sys$setast(1));
4533
4534     /* free buffers and structures */
4535
4536     if (info->in) {
4537         if (info->in->buf) {
4538             n = info->in->bufsize * sizeof(char);
4539             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4540         }
4541         n = sizeof(Pipe);
4542         _ckvmssts(lib$free_vm(&n, &info->in));
4543     }
4544     if (info->out) {
4545         if (info->out->buf) {
4546             n = info->out->bufsize * sizeof(char);
4547             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4548         }
4549         n = sizeof(Pipe);
4550         _ckvmssts(lib$free_vm(&n, &info->out));
4551     }
4552     if (info->err) {
4553         if (info->err->buf) {
4554             n = info->err->bufsize * sizeof(char);
4555             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4556         }
4557         n = sizeof(Pipe);
4558         _ckvmssts(lib$free_vm(&n, &info->err));
4559     }
4560     n = sizeof(Info);
4561     _ckvmssts(lib$free_vm(&n, &info));
4562
4563     return retsts;
4564 }
4565
4566
4567 /*{{{  I32 my_pclose(PerlIO *fp)*/
4568 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4569 {
4570     pInfo info, last = NULL;
4571     I32 ret_status;
4572
4573     /* Fixme - need ast and mutex protection here */
4574     for (info = open_pipes; info != NULL; last = info, info = info->next)
4575         if (info->fp == fp) break;
4576
4577     if (info == NULL) {  /* no such pipe open */
4578       set_errno(ECHILD); /* quoth POSIX */
4579       set_vaxc_errno(SS$_NONEXPR);
4580       return -1;
4581     }
4582
4583     ret_status = my_pclose_pinfo(aTHX_ info);
4584
4585     return ret_status;
4586
4587 }  /* end of my_pclose() */
4588
4589 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4590   /* Roll our own prototype because we want this regardless of whether
4591    * _VMS_WAIT is defined.
4592    */
4593
4594 #ifdef __cplusplus
4595 extern "C" {
4596 #endif
4597   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4598 #ifdef __cplusplus
4599 }
4600 #endif
4601
4602 #endif
4603 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4604    created with popen(); otherwise partially emulate waitpid() unless
4605    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4606    Also check processes not considered by the CRTL waitpid().
4607  */
4608 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4609 Pid_t
4610 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4611 {
4612     pInfo info;
4613     int done;
4614     int sts;
4615     int j;
4616
4617     if (statusp) *statusp = 0;
4618
4619     for (info = open_pipes; info != NULL; info = info->next)
4620         if (info->pid == pid) break;
4621
4622     if (info != NULL) {  /* we know about this child */
4623       while (!info->done) {
4624           _ckvmssts(sys$setast(0));
4625           done = info->done;
4626           if (!done) _ckvmssts(sys$clref(pipe_ef));
4627           _ckvmssts(sys$setast(1));
4628           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4629       }
4630
4631       if (statusp) *statusp = info->completion;
4632       return pid;
4633     }
4634
4635     /* child that already terminated? */
4636
4637     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4638         if (closed_list[j].pid == pid) {
4639             if (statusp) *statusp = closed_list[j].completion;
4640             return pid;
4641         }
4642     }
4643
4644     /* fall through if this child is not one of our own pipe children */
4645
4646 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4647
4648       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4649        * in 7.2 did we get a version that fills in the VMS completion
4650        * status as Perl has always tried to do.
4651        */
4652
4653       sts = __vms_waitpid( pid, statusp, flags );
4654
4655       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4656          return sts;
4657
4658       /* If the real waitpid tells us the child does not exist, we
4659        * fall through here to implement waiting for a child that
4660        * was created by some means other than exec() (say, spawned
4661        * from DCL) or to wait for a process that is not a subprocess
4662        * of the current process.
4663        */
4664
4665 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4666
4667     {
4668       $DESCRIPTOR(intdsc,"0 00:00:01");
4669       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4670       unsigned long int pidcode = JPI$_PID, mypid;
4671       unsigned long int interval[2];
4672       unsigned int jpi_iosb[2];
4673       struct itmlst_3 jpilist[2] = {
4674           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4675           {                      0,         0,                 0, 0}
4676       };
4677
4678       if (pid <= 0) {
4679         /* Sorry folks, we don't presently implement rooting around for
4680            the first child we can find, and we definitely don't want to
4681            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4682          */
4683         set_errno(ENOTSUP);
4684         return -1;
4685       }
4686
4687       /* Get the owner of the child so I can warn if it's not mine. If the
4688        * process doesn't exist or I don't have the privs to look at it,
4689        * I can go home early.
4690        */
4691       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4692       if (sts & 1) sts = jpi_iosb[0];
4693       if (!(sts & 1)) {
4694         switch (sts) {
4695             case SS$_NONEXPR:
4696                 set_errno(ECHILD);
4697                 break;
4698             case SS$_NOPRIV:
4699                 set_errno(EACCES);
4700                 break;
4701             default:
4702                 _ckvmssts(sts);
4703         }
4704         set_vaxc_errno(sts);
4705         return -1;
4706       }
4707
4708       if (ckWARN(WARN_EXEC)) {
4709         /* remind folks they are asking for non-standard waitpid behavior */
4710         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4711         if (ownerpid != mypid)
4712           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4713                       "waitpid: process %x is not a child of process %x",
4714                       pid,mypid);
4715       }
4716
4717       /* simply check on it once a second until it's not there anymore. */
4718
4719       _ckvmssts(sys$bintim(&intdsc,interval));
4720       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4721             _ckvmssts(sys$schdwk(0,0,interval,0));
4722             _ckvmssts(sys$hiber());
4723       }
4724       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4725
4726       _ckvmssts(sts);
4727       return pid;
4728     }
4729 }  /* end of waitpid() */
4730 /*}}}*/
4731 /*}}}*/
4732 /*}}}*/
4733
4734 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4735 char *
4736 my_gconvert(double val, int ndig, int trail, char *buf)
4737 {
4738   static char __gcvtbuf[DBL_DIG+1];
4739   char *loc;
4740
4741   loc = buf ? buf : __gcvtbuf;
4742
4743   if (val) {
4744     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4745     return gcvt(val,ndig,loc);
4746   }
4747   else {
4748     loc[0] = '0'; loc[1] = '\0';
4749     return loc;
4750   }
4751
4752 }
4753 /*}}}*/
4754
4755 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4756 static int
4757 rms_free_search_context(struct FAB * fab)
4758 {
4759     struct NAM * nam;
4760
4761     nam = fab->fab$l_nam;
4762     nam->nam$b_nop |= NAM$M_SYNCHK;
4763     nam->nam$l_rlf = NULL;
4764     fab->fab$b_dns = 0;
4765     return sys$parse(fab, NULL, NULL);
4766 }
4767
4768 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4769 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4770 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4771 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4772 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4773 #define rms_nam_esll(nam) nam.nam$b_esl
4774 #define rms_nam_esl(nam) nam.nam$b_esl
4775 #define rms_nam_name(nam) nam.nam$l_name
4776 #define rms_nam_namel(nam) nam.nam$l_name
4777 #define rms_nam_type(nam) nam.nam$l_type
4778 #define rms_nam_typel(nam) nam.nam$l_type
4779 #define rms_nam_ver(nam) nam.nam$l_ver
4780 #define rms_nam_verl(nam) nam.nam$l_ver
4781 #define rms_nam_rsll(nam) nam.nam$b_rsl
4782 #define rms_nam_rsl(nam) nam.nam$b_rsl
4783 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4784 #define rms_set_fna(fab, nam, name, size) \
4785         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4786 #define rms_get_fna(fab, nam) fab.fab$l_fna
4787 #define rms_set_dna(fab, nam, name, size) \
4788         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4789 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4790 #define rms_set_esa(nam, name, size) \
4791         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4792 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4793         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4794 #define rms_set_rsa(nam, name, size) \
4795         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4796 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4797         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4798 #define rms_nam_name_type_l_size(nam) \
4799         (nam.nam$b_name + nam.nam$b_type)
4800 #else
4801 static int
4802 rms_free_search_context(struct FAB * fab)
4803 {
4804     struct NAML * nam;
4805
4806     nam = fab->fab$l_naml;
4807     nam->naml$b_nop |= NAM$M_SYNCHK;
4808     nam->naml$l_rlf = NULL;
4809     nam->naml$l_long_defname_size = 0;
4810
4811     fab->fab$b_dns = 0;
4812     return sys$parse(fab, NULL, NULL);
4813 }
4814
4815 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4816 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4817 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4818 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4819 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4820 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4821 #define rms_nam_esl(nam) nam.naml$b_esl
4822 #define rms_nam_name(nam) nam.naml$l_name
4823 #define rms_nam_namel(nam) nam.naml$l_long_name
4824 #define rms_nam_type(nam) nam.naml$l_type
4825 #define rms_nam_typel(nam) nam.naml$l_long_type
4826 #define rms_nam_ver(nam) nam.naml$l_ver
4827 #define rms_nam_verl(nam) nam.naml$l_long_ver
4828 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4829 #define rms_nam_rsl(nam) nam.naml$b_rsl
4830 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4831 #define rms_set_fna(fab, nam, name, size) \
4832         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4833         nam.naml$l_long_filename_size = size; \
4834         nam.naml$l_long_filename = name;}
4835 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4836 #define rms_set_dna(fab, nam, name, size) \
4837         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4838         nam.naml$l_long_defname_size = size; \
4839         nam.naml$l_long_defname = name; }
4840 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4841 #define rms_set_esa(nam, name, size) \
4842         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4843         nam.naml$l_long_expand_alloc = size; \
4844         nam.naml$l_long_expand = name; }
4845 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4846         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4847         nam.naml$l_long_expand = l_name; \
4848         nam.naml$l_long_expand_alloc = l_size; }
4849 #define rms_set_rsa(nam, name, size) \
4850         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4851         nam.naml$l_long_result = name; \
4852         nam.naml$l_long_result_alloc = size; }
4853 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4854         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4855         nam.naml$l_long_result = l_name; \
4856         nam.naml$l_long_result_alloc = l_size; }
4857 #define rms_nam_name_type_l_size(nam) \
4858         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4859 #endif
4860
4861
4862 /* rms_erase
4863  * The CRTL for 8.3 and later can create symbolic links in any mode,
4864  * however in 8.3 the unlink/remove/delete routines will only properly handle
4865  * them if one of the PCP modes is active.
4866  */
4867 static int
4868 rms_erase(const char * vmsname)
4869 {
4870   int status;
4871   struct FAB myfab = cc$rms_fab;
4872   rms_setup_nam(mynam);
4873
4874   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4875   rms_bind_fab_nam(myfab, mynam);
4876
4877 #ifdef NAML$M_OPEN_SPECIAL
4878   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4879 #endif
4880
4881   status = sys$erase(&myfab, 0, 0);
4882
4883   return status;
4884 }
4885
4886
4887 static int
4888 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4889                     const struct dsc$descriptor_s * vms_dst_dsc,
4890                     unsigned long flags)
4891 {
4892     /*  VMS and UNIX handle file permissions differently and the
4893      * the same ACL trick may be needed for renaming files,
4894      * especially if they are directories.
4895      */
4896
4897    /* todo: get kill_file and rename to share common code */
4898    /* I can not find online documentation for $change_acl
4899     * it appears to be replaced by $set_security some time ago */
4900
4901     const unsigned int access_mode = 0;
4902     $DESCRIPTOR(obj_file_dsc,"FILE");
4903     char *vmsname;
4904     char *rslt;
4905     unsigned long int jpicode = JPI$_UIC;
4906     int aclsts, fndsts, rnsts = -1;
4907     unsigned int ctx = 0;
4908     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4909     struct dsc$descriptor_s * clean_dsc;
4910
4911     struct myacedef {
4912         unsigned char myace$b_length;
4913         unsigned char myace$b_type;
4914         unsigned short int myace$w_flags;
4915         unsigned long int myace$l_access;
4916         unsigned long int myace$l_ident;
4917     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4918              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4919              0},
4920              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4921
4922     struct item_list_3
4923         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4924                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4925                       {0,0,0,0}},
4926         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4927         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4928                      {0,0,0,0}};
4929
4930
4931     /* Expand the input spec using RMS, since we do not want to put
4932      * ACLs on the target of a symbolic link */
4933     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
4934     if (vmsname == NULL)
4935         return SS$_INSFMEM;
4936
4937     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4938                         vmsname,
4939                         PERL_RMSEXPAND_M_SYMLINK);
4940     if (rslt == NULL) {
4941         PerlMem_free(vmsname);
4942         return SS$_INSFMEM;
4943     }
4944
4945     /* So we get our own UIC to use as a rights identifier,
4946      * and the insert an ACE at the head of the ACL which allows us
4947      * to delete the file.
4948      */
4949     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4950
4951     fildsc.dsc$w_length = strlen(vmsname);
4952     fildsc.dsc$a_pointer = vmsname;
4953     ctx = 0;
4954     newace.myace$l_ident = oldace.myace$l_ident;
4955     rnsts = SS$_ABORT;
4956
4957     /* Grab any existing ACEs with this identifier in case we fail */
4958     clean_dsc = &fildsc;
4959     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4960                                &fildsc,
4961                                NULL,
4962                                OSS$M_WLOCK,
4963                                findlst,
4964                                &ctx,
4965                                &access_mode);
4966
4967     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4968         /* Add the new ACE . . . */
4969
4970         /* if the sys$get_security succeeded, then ctx is valid, and the
4971          * object/file descriptors will be ignored.  But otherwise they
4972          * are needed
4973          */
4974         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4975                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4976         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4977             set_errno(EVMSERR);
4978             set_vaxc_errno(aclsts);
4979             PerlMem_free(vmsname);
4980             return aclsts;
4981         }
4982
4983         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4984                                 NULL, NULL,
4985                                 &flags,
4986                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4987
4988         if ($VMS_STATUS_SUCCESS(rnsts)) {
4989             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4990         }
4991
4992         /* Put things back the way they were. */
4993         ctx = 0;
4994         aclsts = sys$get_security(&obj_file_dsc,
4995                                   clean_dsc,
4996                                   NULL,
4997                                   OSS$M_WLOCK,
4998                                   findlst,
4999                                   &ctx,
5000                                   &access_mode);
5001
5002         if ($VMS_STATUS_SUCCESS(aclsts)) {
5003         int sec_flags;
5004
5005             sec_flags = 0;
5006             if (!$VMS_STATUS_SUCCESS(fndsts))
5007                 sec_flags = OSS$M_RELCTX;
5008
5009             /* Get rid of the new ACE */
5010             aclsts = sys$set_security(NULL, NULL, NULL,
5011                                   sec_flags, dellst, &ctx, &access_mode);
5012
5013             /* If there was an old ACE, put it back */
5014             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5015                 addlst[0].bufadr = &oldace;
5016                 aclsts = sys$set_security(NULL, NULL, NULL,
5017                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5018                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5019                     set_errno(EVMSERR);
5020                     set_vaxc_errno(aclsts);
5021                     rnsts = aclsts;
5022                 }
5023             } else {
5024             int aclsts2;
5025
5026                 /* Try to clear the lock on the ACL list */
5027                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5028                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5029
5030                 /* Rename errors are most important */
5031                 if (!$VMS_STATUS_SUCCESS(rnsts))
5032                     aclsts = rnsts;
5033                 set_errno(EVMSERR);
5034                 set_vaxc_errno(aclsts);
5035                 rnsts = aclsts;
5036             }
5037         }
5038         else {
5039             if (aclsts != SS$_ACLEMPTY)
5040                 rnsts = aclsts;
5041         }
5042     }
5043     else
5044         rnsts = fndsts;
5045
5046     PerlMem_free(vmsname);
5047     return rnsts;
5048 }
5049
5050
5051 /*{{{int rename(const char *, const char * */
5052 /* Not exactly what X/Open says to do, but doing it absolutely right
5053  * and efficiently would require a lot more work.  This should be close
5054  * enough to pass all but the most strict X/Open compliance test.
5055  */
5056 int
5057 Perl_rename(pTHX_ const char *src, const char * dst)
5058 {
5059     int retval;
5060     int pre_delete = 0;
5061     int src_sts;
5062     int dst_sts;
5063     Stat_t src_st;
5064     Stat_t dst_st;
5065
5066     /* Validate the source file */
5067     src_sts = flex_lstat(src, &src_st);
5068     if (src_sts != 0) {
5069
5070         /* No source file or other problem */
5071         return src_sts;
5072     }
5073     if (src_st.st_devnam[0] == 0)  {
5074         /* This may be possible so fail if it is seen. */
5075         errno = EIO;
5076         return -1;
5077     }
5078
5079     dst_sts = flex_lstat(dst, &dst_st);
5080     if (dst_sts == 0) {
5081
5082         if (dst_st.st_dev != src_st.st_dev) {
5083             /* Must be on the same device */
5084             errno = EXDEV;
5085             return -1;
5086         }
5087
5088         /* VMS_INO_T_COMPARE is true if the inodes are different
5089          * to match the output of memcmp
5090          */
5091
5092         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5093             /* That was easy, the files are the same! */
5094             return 0;
5095         }
5096
5097         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5098             /* If source is a directory, so must be dest */
5099                 errno = EISDIR;
5100                 return -1;
5101         }
5102
5103     }
5104
5105
5106     if ((dst_sts == 0) &&
5107         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5108
5109         /* We have issues here if vms_unlink_all_versions is set
5110          * If the destination exists, and is not a directory, then
5111          * we must delete in advance.
5112          *
5113          * If the src is a directory, then we must always pre-delete
5114          * the destination.
5115          *
5116          * If we successfully delete the dst in advance, and the rename fails
5117          * X/Open requires that errno be EIO.
5118          *
5119          */
5120
5121         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5122             int d_sts;
5123             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5124                                      S_ISDIR(dst_st.st_mode));
5125
5126            /* Need to delete all versions ? */
5127            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5128                 int i = 0;
5129
5130                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5131                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5132                     if (d_sts != 0)
5133                         break;
5134                     i++;
5135
5136                     /* Make sure that we do not loop forever */
5137                     if (i > 32767) {
5138                         errno = EIO;
5139                         d_sts = -1;
5140                         break;
5141                     }
5142                 }
5143            }
5144
5145             if (d_sts != 0)
5146                 return d_sts;
5147
5148             /* We killed the destination, so only errno now is EIO */
5149             pre_delete = 1;
5150         }
5151     }
5152
5153     /* Originally the idea was to call the CRTL rename() and only
5154      * try the lib$rename_file if it failed.
5155      * It turns out that there are too many variants in what the
5156      * the CRTL rename might do, so only use lib$rename_file
5157      */
5158     retval = -1;
5159
5160     {
5161         /* Is the source and dest both in VMS format */
5162         /* if the source is a directory, then need to fileify */
5163         /*  and dest must be a directory or non-existent. */
5164
5165         char * vms_dst;
5166         int sts;
5167         char * ret_str;
5168         unsigned long flags;
5169         struct dsc$descriptor_s old_file_dsc;
5170         struct dsc$descriptor_s new_file_dsc;
5171
5172         /* We need to modify the src and dst depending
5173          * on if one or more of them are directories.
5174          */
5175
5176         vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
5177         if (vms_dst == NULL)
5178             _ckvmssts_noperl(SS$_INSFMEM);
5179
5180         if (S_ISDIR(src_st.st_mode)) {
5181         char * ret_str;
5182         char * vms_dir_file;
5183
5184             vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
5185             if (vms_dir_file == NULL)
5186                 _ckvmssts_noperl(SS$_INSFMEM);
5187
5188             /* If the dest is a directory, we must remove it */
5189             if (dst_sts == 0) {
5190                 int d_sts;
5191                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5192                 if (d_sts != 0) {
5193                     PerlMem_free(vms_dst);
5194                     errno = EIO;
5195                     return d_sts;
5196                 }
5197
5198                 pre_delete = 1;
5199             }
5200
5201            /* The dest must be a VMS file specification */
5202            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5203            if (ret_str == NULL) {
5204                 PerlMem_free(vms_dst);
5205                 errno = EIO;
5206                 return -1;
5207            }
5208
5209             /* The source must be a file specification */
5210             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5211             if (ret_str == NULL) {
5212                 PerlMem_free(vms_dst);
5213                 PerlMem_free(vms_dir_file);
5214                 errno = EIO;
5215                 return -1;
5216             }
5217             PerlMem_free(vms_dst);
5218             vms_dst = vms_dir_file;
5219
5220         } else {
5221             /* File to file or file to new dir */
5222
5223             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5224                 /* VMS pathify a dir target */
5225                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5226                 if (ret_str == NULL) {
5227                     PerlMem_free(vms_dst);
5228                     errno = EIO;
5229                     return -1;
5230                 }
5231             } else {
5232                 char * v_spec, * r_spec, * d_spec, * n_spec;
5233                 char * e_spec, * vs_spec;
5234                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5235
5236                 /* fileify a target VMS file specification */
5237                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5238                 if (ret_str == NULL) {
5239                     PerlMem_free(vms_dst);
5240                     errno = EIO;
5241                     return -1;
5242                 }
5243
5244                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5245                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5246                              &e_len, &vs_spec, &vs_len);
5247                 if (sts == 0) {
5248                      if (e_len == 0) {
5249                          /* Get rid of the version */
5250                          if (vs_len != 0) {
5251                              *vs_spec = '\0';
5252                          }
5253                          /* Need to specify a '.' so that the extension */
5254                          /* is not inherited */
5255                          strcat(vms_dst,".");
5256                      }
5257                 }
5258             }
5259         }
5260
5261         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5262         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5263         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5264         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5265
5266         new_file_dsc.dsc$a_pointer = vms_dst;
5267         new_file_dsc.dsc$w_length = strlen(vms_dst);
5268         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5269         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5270
5271         flags = 0;
5272 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5273         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5274 #endif
5275
5276         sts = lib$rename_file(&old_file_dsc,
5277                               &new_file_dsc,
5278                               NULL, NULL,
5279                               &flags,
5280                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5281         if (!$VMS_STATUS_SUCCESS(sts)) {
5282
5283            /* We could have failed because VMS style permissions do not
5284             * permit renames that UNIX will allow.  Just like the hack
5285             * in for kill_file.
5286             */
5287            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5288         }
5289
5290         PerlMem_free(vms_dst);
5291         if (!$VMS_STATUS_SUCCESS(sts)) {
5292             errno = EIO;
5293             return -1;
5294         }
5295         retval = 0;
5296     }
5297
5298     if (vms_unlink_all_versions) {
5299         /* Now get rid of any previous versions of the source file that
5300          * might still exist
5301          */
5302         int i = 0;
5303         dSAVEDERRNO;
5304         SAVE_ERRNO;
5305         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5306                                    S_ISDIR(src_st.st_mode));
5307         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5308              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5309                                        S_ISDIR(src_st.st_mode));
5310              if (src_sts != 0)
5311                  break;
5312              i++;
5313
5314              /* Make sure that we do not loop forever */
5315              if (i > 32767) {
5316                  src_sts = -1;
5317                  break;
5318              }
5319         }
5320         RESTORE_ERRNO;
5321     }
5322
5323     /* We deleted the destination, so must force the error to be EIO */
5324     if ((retval != 0) && (pre_delete != 0))
5325         errno = EIO;
5326
5327     return retval;
5328 }
5329 /*}}}*/
5330
5331
5332 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5333 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5334  * to expand file specification.  Allows for a single default file
5335  * specification and a simple mask of options.  If outbuf is non-NULL,
5336  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5337  * the resultant file specification is placed.  If outbuf is NULL, the
5338  * resultant file specification is placed into a static buffer.
5339  * The third argument, if non-NULL, is taken to be a default file
5340  * specification string.  The fourth argument is unused at present.
5341  * rmesexpand() returns the address of the resultant string if
5342  * successful, and NULL on error.
5343  *
5344  * New functionality for previously unused opts value:
5345  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5346  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5347  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5348  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5349  */
5350 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5351
5352 static char *
5353 int_rmsexpand
5354    (const char *filespec,
5355     char *outbuf,
5356     const char *defspec,
5357     unsigned opts,
5358     int * fs_utf8,
5359     int * dfs_utf8)
5360 {
5361   char * ret_spec;
5362   const char * in_spec;
5363   char * spec_buf;
5364   const char * def_spec;
5365   char * vmsfspec, *vmsdefspec;
5366   char * esa;
5367   char * esal = NULL;
5368   char * outbufl;
5369   struct FAB myfab = cc$rms_fab;
5370   rms_setup_nam(mynam);
5371   STRLEN speclen;
5372   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5373   int sts;
5374
5375   /* temp hack until UTF8 is actually implemented */
5376   if (fs_utf8 != NULL)
5377     *fs_utf8 = 0;
5378
5379   if (!filespec || !*filespec) {
5380     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5381     return NULL;
5382   }
5383
5384   vmsfspec = NULL;
5385   vmsdefspec = NULL;
5386   outbufl = NULL;
5387
5388   in_spec = filespec;
5389   isunix = 0;
5390   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5391       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5392       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5393
5394       /* If this is a UNIX file spec, convert it to VMS */
5395       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5396                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5397                            &e_len, &vs_spec, &vs_len);
5398       if (sts != 0) {
5399           isunix = 1;
5400           char * ret_spec;
5401
5402           vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5403           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5404           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5405           if (ret_spec == NULL) {
5406               PerlMem_free(vmsfspec);
5407               return NULL;
5408           }
5409           in_spec = (const char *)vmsfspec;
5410
5411           /* Unless we are forcing to VMS format, a UNIX input means
5412            * UNIX output, and that requires long names to be used
5413            */
5414           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5415 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5416               opts |= PERL_RMSEXPAND_M_LONG;
5417 #else
5418               NOOP;
5419 #endif
5420           else
5421               isunix = 0;
5422       }
5423
5424   }
5425
5426   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5427   rms_bind_fab_nam(myfab, mynam);
5428
5429   /* Process the default file specification if present */
5430   def_spec = defspec;
5431   if (defspec && *defspec) {
5432     int t_isunix;
5433     t_isunix = is_unix_filespec(defspec);
5434     if (t_isunix) {
5435       vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5436       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5437       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5438
5439       if (ret_spec == NULL) {
5440           /* Clean up and bail */
5441           PerlMem_free(vmsdefspec);
5442           if (vmsfspec != NULL)
5443               PerlMem_free(vmsfspec);
5444               return NULL;
5445           }
5446           def_spec = (const char *)vmsdefspec;
5447       }
5448       rms_set_dna(myfab, mynam,
5449                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5450   }
5451
5452   /* Now we need the expansion buffers */
5453   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
5454   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5455 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5456   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
5457   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5458 #endif
5459   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5460
5461   /* If a NAML block is used RMS always writes to the long and short
5462    * addresses unless you suppress the short name.
5463    */
5464 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5465   outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
5466   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5467 #endif
5468    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5469
5470 #ifdef NAM$M_NO_SHORT_UPCASE
5471   if (decc_efs_case_preserve)
5472     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5473 #endif
5474
5475    /* We may not want to follow symbolic links */
5476 #ifdef NAML$M_OPEN_SPECIAL
5477   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5478     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5479 #endif
5480
5481   /* First attempt to parse as an existing file */
5482   retsts = sys$parse(&myfab,0,0);
5483   if (!(retsts & STS$K_SUCCESS)) {
5484
5485     /* Could not find the file, try as syntax only if error is not fatal */
5486     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5487     if (retsts == RMS$_DNF ||
5488         retsts == RMS$_DIR ||
5489         retsts == RMS$_DEV ||
5490         retsts == RMS$_PRV) {
5491       retsts = sys$parse(&myfab,0,0);
5492       if (retsts & STS$K_SUCCESS) goto int_expanded;
5493     }
5494
5495      /* Still could not parse the file specification */
5496     /*----------------------------------------------*/
5497     sts = rms_free_search_context(&myfab); /* Free search context */
5498     if (vmsdefspec != NULL)
5499         PerlMem_free(vmsdefspec);
5500     if (vmsfspec != NULL)
5501         PerlMem_free(vmsfspec);
5502     if (outbufl != NULL)
5503         PerlMem_free(outbufl);
5504     PerlMem_free(esa);
5505     if (esal != NULL)
5506         PerlMem_free(esal);
5507     set_vaxc_errno(retsts);
5508     if      (retsts == RMS$_PRV) set_errno(EACCES);
5509     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5510     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5511     else                         set_errno(EVMSERR);
5512     return NULL;
5513   }
5514   retsts = sys$search(&myfab,0,0);
5515   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5516     sts = rms_free_search_context(&myfab); /* Free search context */
5517     if (vmsdefspec != NULL)
5518         PerlMem_free(vmsdefspec);
5519     if (vmsfspec != NULL)
5520         PerlMem_free(vmsfspec);
5521     if (outbufl != NULL)
5522         PerlMem_free(outbufl);
5523     PerlMem_free(esa);
5524     if (esal != NULL)
5525         PerlMem_free(esal);
5526     set_vaxc_errno(retsts);
5527     if      (retsts == RMS$_PRV) set_errno(EACCES);
5528     else                         set_errno(EVMSERR);
5529     return NULL;
5530   }
5531
5532   /* If the input filespec contained any lowercase characters,
5533    * downcase the result for compatibility with Unix-minded code. */
5534 int_expanded:
5535   if (!decc_efs_case_preserve) {
5536     char * tbuf;
5537     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5538       if (islower(*tbuf)) { haslower = 1; break; }
5539   }
5540
5541    /* Is a long or a short name expected */
5542   /*------------------------------------*/
5543   spec_buf = NULL;
5544 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5545   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5546     if (rms_nam_rsll(mynam)) {
5547         spec_buf = outbufl;
5548         speclen = rms_nam_rsll(mynam);
5549     }
5550     else {
5551         spec_buf = esal; /* Not esa */
5552         speclen = rms_nam_esll(mynam);
5553     }
5554   }
5555   else {
5556 #endif
5557     if (rms_nam_rsl(mynam)) {
5558         spec_buf = outbuf;
5559         speclen = rms_nam_rsl(mynam);
5560     }
5561     else {
5562         spec_buf = esa; /* Not esal */
5563         speclen = rms_nam_esl(mynam);
5564     }
5565 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5566   }
5567 #endif
5568   spec_buf[speclen] = '\0';
5569
5570   /* Trim off null fields added by $PARSE
5571    * If type > 1 char, must have been specified in original or default spec
5572    * (not true for version; $SEARCH may have added version of existing file).
5573    */
5574   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5575   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5576     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5577              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5578   }
5579   else {
5580     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5581              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5582   }
5583   if (trimver || trimtype) {
5584     if (defspec && *defspec) {
5585       char *defesal = NULL;
5586       char *defesa = NULL;
5587       defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5588       if (defesa != NULL) {
5589         struct FAB deffab = cc$rms_fab;
5590 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5591         defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5592         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5593 #endif
5594         rms_setup_nam(defnam);
5595
5596         rms_bind_fab_nam(deffab, defnam);
5597
5598         /* Cast ok */
5599         rms_set_fna
5600             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5601
5602         /* RMS needs the esa/esal as a work area if wildcards are involved */
5603         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5604
5605         rms_clear_nam_nop(defnam);
5606         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5607 #ifdef NAM$M_NO_SHORT_UPCASE
5608         if (decc_efs_case_preserve)
5609           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5610 #endif
5611 #ifdef NAML$M_OPEN_SPECIAL
5612         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5613           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5614 #endif
5615         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5616           if (trimver) {
5617              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5618           }
5619           if (trimtype) {
5620             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5621           }
5622         }
5623         if (defesal != NULL)
5624             PerlMem_free(defesal);
5625         PerlMem_free(defesa);
5626       } else {
5627           _ckvmssts_noperl(SS$_INSFMEM);
5628       }
5629     }
5630     if (trimver) {
5631       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5632         if (*(rms_nam_verl(mynam)) != '\"')
5633           speclen = rms_nam_verl(mynam) - spec_buf;
5634       }
5635       else {
5636         if (*(rms_nam_ver(mynam)) != '\"')
5637           speclen = rms_nam_ver(mynam) - spec_buf;
5638       }
5639     }
5640     if (trimtype) {
5641       /* If we didn't already trim version, copy down */
5642       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5643         if (speclen > rms_nam_verl(mynam) - spec_buf)
5644           memmove
5645            (rms_nam_typel(mynam),
5646             rms_nam_verl(mynam),
5647             speclen - (rms_nam_verl(mynam) - spec_buf));
5648           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5649       }
5650       else {
5651         if (speclen > rms_nam_ver(mynam) - spec_buf)
5652           memmove
5653            (rms_nam_type(mynam),
5654             rms_nam_ver(mynam),
5655             speclen - (rms_nam_ver(mynam) - spec_buf));
5656           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5657       }
5658     }
5659   }
5660
5661    /* Done with these copies of the input files */
5662   /*-------------------------------------------*/
5663   if (vmsfspec != NULL)
5664         PerlMem_free(vmsfspec);
5665   if (vmsdefspec != NULL)
5666         PerlMem_free(vmsdefspec);
5667
5668   /* If we just had a directory spec on input, $PARSE "helpfully"
5669    * adds an empty name and type for us */
5670 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5671   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5672     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5673         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5674         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5675       speclen = rms_nam_namel(mynam) - spec_buf;
5676   }
5677   else
5678 #endif
5679   {
5680     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5681         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5682         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5683       speclen = rms_nam_name(mynam) - spec_buf;
5684   }
5685
5686   /* Posix format specifications must have matching quotes */
5687   if (speclen < (VMS_MAXRSS - 1)) {
5688     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5689       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5690         spec_buf[speclen] = '\"';
5691         speclen++;
5692       }
5693     }
5694   }
5695   spec_buf[speclen] = '\0';
5696   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5697
5698   /* Have we been working with an expanded, but not resultant, spec? */
5699   /* Also, convert back to Unix syntax if necessary. */
5700   {
5701   int rsl;
5702
5703 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5704     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5705       rsl = rms_nam_rsll(mynam);
5706     } else
5707 #endif
5708     {
5709       rsl = rms_nam_rsl(mynam);
5710     }
5711     if (!rsl) {
5712       /* rsl is not present, it means that spec_buf is either */
5713       /* esa or esal, and needs to be copied to outbuf */
5714       /* convert to Unix if desired */
5715       if (isunix) {
5716         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5717       } else {
5718         /* VMS file specs are not in UTF-8 */
5719         if (fs_utf8 != NULL)
5720             *fs_utf8 = 0;
5721         my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5722         ret_spec = outbuf;
5723       }
5724     }
5725     else {
5726       /* Now spec_buf is either outbuf or outbufl */
5727       /* We need the result into outbuf */
5728       if (isunix) {
5729            /* If we need this in UNIX, then we need another buffer */
5730            /* to keep things in order */
5731            char * src;
5732            char * new_src = NULL;
5733            if (spec_buf == outbuf) {
5734                new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
5735                my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5736            } else {
5737                src = spec_buf;
5738            }
5739            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5740            if (new_src) {
5741                PerlMem_free(new_src);
5742            }
5743       } else {
5744            /* VMS file specs are not in UTF-8 */
5745            if (fs_utf8 != NULL)
5746                *fs_utf8 = 0;
5747
5748            /* Copy the buffer if needed */
5749            if (outbuf != spec_buf)
5750                my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5751            ret_spec = outbuf;
5752       }
5753     }
5754   }
5755
5756   /* Need to clean up the search context */
5757   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5758   sts = rms_free_search_context(&myfab); /* Free search context */
5759
5760   /* Clean up the extra buffers */
5761   if (esal != NULL)
5762       PerlMem_free(esal);
5763   PerlMem_free(esa);
5764   if (outbufl != NULL)
5765      PerlMem_free(outbufl);
5766
5767   /* Return the result */
5768   return ret_spec;
5769 }
5770
5771 /* Common simple case - Expand an already VMS spec */
5772 static char *
5773 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5774     opts |= PERL_RMSEXPAND_M_VMS_IN;
5775     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5776 }
5777
5778 /* Common simple case - Expand to a VMS spec */
5779 static char *
5780 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5781     opts |= PERL_RMSEXPAND_M_VMS;
5782     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5783 }
5784
5785
5786 /* Entry point used by perl routines */
5787 static char *
5788 mp_do_rmsexpand
5789    (pTHX_ const char *filespec,
5790     char *outbuf,
5791     int ts,
5792     const char *defspec,
5793     unsigned opts,
5794     int * fs_utf8,
5795     int * dfs_utf8)
5796 {
5797     static char __rmsexpand_retbuf[VMS_MAXRSS];
5798     char * expanded, *ret_spec, *ret_buf;
5799
5800     expanded = NULL;
5801     ret_buf = outbuf;
5802     if (ret_buf == NULL) {
5803         if (ts) {
5804             Newx(expanded, VMS_MAXRSS, char);
5805             if (expanded == NULL)
5806                 _ckvmssts(SS$_INSFMEM);
5807             ret_buf = expanded;
5808         } else {
5809             ret_buf = __rmsexpand_retbuf;
5810         }
5811     }
5812
5813
5814     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5815                              opts, fs_utf8,  dfs_utf8);
5816
5817     if (ret_spec == NULL) {
5818        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5819        if (expanded)
5820            Safefree(expanded);
5821     }
5822
5823     return ret_spec;
5824 }
5825 /*}}}*/
5826 /* External entry points */
5827 char *
5828 Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5829 {
5830     return do_rmsexpand(spec, buf, 0, def, opt, NULL, NULL);
5831 }
5832
5833 char *
5834 Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5835 {
5836     return do_rmsexpand(spec, buf, 1, def, opt, NULL, NULL);
5837 }
5838
5839 char *
5840 Perl_rmsexpand_utf8(pTHX_ const char *spec, char *buf, const char *def,
5841                     unsigned opt, int * fs_utf8, int * dfs_utf8)
5842 {
5843     return do_rmsexpand(spec, buf, 0, def, opt, fs_utf8, dfs_utf8);
5844 }
5845
5846 char *
5847 Perl_rmsexpand_utf8_ts(pTHX_ const char *spec, char *buf, const char *def,
5848                        unsigned opt, int * fs_utf8, int * dfs_utf8)
5849 {
5850     return do_rmsexpand(spec, buf, 1, def, opt, fs_utf8, dfs_utf8);
5851 }
5852
5853
5854 /*
5855 ** The following routines are provided to make life easier when
5856 ** converting among VMS-style and Unix-style directory specifications.
5857 ** All will take input specifications in either VMS or Unix syntax. On
5858 ** failure, all return NULL.  If successful, the routines listed below
5859 ** return a pointer to a buffer containing the appropriately
5860 ** reformatted spec (and, therefore, subsequent calls to that routine
5861 ** will clobber the result), while the routines of the same names with
5862 ** a _ts suffix appended will return a pointer to a mallocd string
5863 ** containing the appropriately reformatted spec.
5864 ** In all cases, only explicit syntax is altered; no check is made that
5865 ** the resulting string is valid or that the directory in question
5866 ** actually exists.
5867 **
5868 **   fileify_dirspec() - convert a directory spec into the name of the
5869 **     directory file (i.e. what you can stat() to see if it's a dir).
5870 **     The style (VMS or Unix) of the result is the same as the style
5871 **     of the parameter passed in.
5872 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5873 **     what you prepend to a filename to indicate what directory it's in).
5874 **     The style (VMS or Unix) of the result is the same as the style
5875 **     of the parameter passed in.
5876 **   tounixpath() - convert a directory spec into a Unix-style path.
5877 **   tovmspath() - convert a directory spec into a VMS-style path.
5878 **   tounixspec() - convert any file spec into a Unix-style file spec.
5879 **   tovmsspec() - convert any file spec into a VMS-style spec.
5880 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5881 **
5882 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5883 ** Permission is given to distribute this code as part of the Perl
5884 ** standard distribution under the terms of the GNU General Public
5885 ** License or the Perl Artistic License.  Copies of each may be
5886 ** found in the Perl standard distribution.
5887  */
5888
5889 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5890 static char *
5891 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5892 {
5893     unsigned long int dirlen, retlen, hasfilename = 0;
5894     char *cp1, *cp2, *lastdir;
5895     char *trndir, *vmsdir;
5896     unsigned short int trnlnm_iter_count;
5897     int sts;
5898     if (utf8_fl != NULL)
5899         *utf8_fl = 0;
5900
5901     if (!dir || !*dir) {
5902       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5903     }
5904     dirlen = strlen(dir);
5905     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5906     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5907       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5908         dir = "/sys$disk";
5909         dirlen = 9;
5910       }
5911       else
5912         dirlen = 1;
5913     }
5914     if (dirlen > (VMS_MAXRSS - 1)) {
5915       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5916       return NULL;
5917     }
5918     trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5919     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5920     if (!strpbrk(dir+1,"/]>:")  &&
5921         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5922       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5923       trnlnm_iter_count = 0;
5924       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
5925         trnlnm_iter_count++;
5926         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5927       }
5928       dirlen = strlen(trndir);
5929     }
5930     else {
5931       memcpy(trndir, dir, dirlen);
5932       trndir[dirlen] = '\0';
5933     }
5934
5935     /* At this point we are done with *dir and use *trndir which is a
5936      * copy that can be modified.  *dir must not be modified.
5937      */
5938
5939     /* If we were handed a rooted logical name or spec, treat it like a
5940      * simple directory, so that
5941      *    $ Define myroot dev:[dir.]
5942      *    ... do_fileify_dirspec("myroot",buf,1) ...
5943      * does something useful.
5944      */
5945     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5946       trndir[--dirlen] = '\0';
5947       trndir[dirlen-1] = ']';
5948     }
5949     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5950       trndir[--dirlen] = '\0';
5951       trndir[dirlen-1] = '>';
5952     }
5953
5954     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5955       /* If we've got an explicit filename, we can just shuffle the string. */
5956       if (*(cp1+1)) hasfilename = 1;
5957       /* Similarly, we can just back up a level if we've got multiple levels
5958          of explicit directories in a VMS spec which ends with directories. */
5959       else {
5960         for (cp2 = cp1; cp2 > trndir; cp2--) {
5961           if (*cp2 == '.') {
5962             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5963 /* fix-me, can not scan EFS file specs backward like this */
5964               *cp2 = *cp1; *cp1 = '\0';
5965               hasfilename = 1;
5966               break;
5967             }
5968           }
5969           if (*cp2 == '[' || *cp2 == '<') break;
5970         }
5971       }
5972     }
5973
5974     vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5975     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5976     cp1 = strpbrk(trndir,"]:>");
5977     if (cp1 && *(cp1+1) == ':')   /* DECNet node spec with :: */
5978         cp1 = strpbrk(cp1+2,"]:>");
5979
5980     if (hasfilename || !cp1) { /* filename present or not VMS */
5981
5982       if (trndir[0] == '.') {
5983         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5984           PerlMem_free(trndir);
5985           PerlMem_free(vmsdir);
5986           return int_fileify_dirspec("[]", buf, NULL);
5987         }
5988         else if (trndir[1] == '.' &&
5989                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5990           PerlMem_free(trndir);
5991           PerlMem_free(vmsdir);
5992           return int_fileify_dirspec("[-]", buf, NULL);
5993         }
5994       }
5995       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5996         dirlen -= 1;                 /* to last element */
5997         lastdir = strrchr(trndir,'/');
5998       }
5999       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6000         /* If we have "/." or "/..", VMSify it and let the VMS code
6001          * below expand it, rather than repeating the code to handle
6002          * relative components of a filespec here */
6003         do {
6004           if (*(cp1+2) == '.') cp1++;
6005           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6006             char * ret_chr;
6007             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6008                 PerlMem_free(trndir);
6009                 PerlMem_free(vmsdir);
6010                 return NULL;
6011             }
6012             if (strchr(vmsdir,'/') != NULL) {
6013               /* If int_tovmsspec() returned it, it must have VMS syntax
6014                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6015                * the time to check this here only so we avoid a recursion
6016                * loop; otherwise, gigo.
6017                */
6018               PerlMem_free(trndir);
6019               PerlMem_free(vmsdir);
6020               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6021               return NULL;
6022             }
6023             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6024                 PerlMem_free(trndir);
6025                 PerlMem_free(vmsdir);
6026                 return NULL;
6027             }
6028             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6029             PerlMem_free(trndir);
6030             PerlMem_free(vmsdir);
6031             return ret_chr;
6032           }
6033           cp1++;
6034         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6035         lastdir = strrchr(trndir,'/');
6036       }
6037       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6038         char * ret_chr;
6039         /* Ditto for specs that end in an MFD -- let the VMS code
6040          * figure out whether it's a real device or a rooted logical. */
6041
6042         /* This should not happen any more.  Allowing the fake /000000
6043          * in a UNIX pathname causes all sorts of problems when trying
6044          * to run in UNIX emulation.  So the VMS to UNIX conversions
6045          * now remove the fake /000000 directories.
6046          */
6047
6048         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6049         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6050             PerlMem_free(trndir);
6051             PerlMem_free(vmsdir);
6052             return NULL;
6053         }
6054         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6055             PerlMem_free(trndir);
6056             PerlMem_free(vmsdir);
6057             return NULL;
6058         }
6059         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6060         PerlMem_free(trndir);
6061         PerlMem_free(vmsdir);
6062         return ret_chr;
6063       }
6064       else {
6065
6066         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6067              !(lastdir = cp1 = strrchr(trndir,']')) &&
6068              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6069
6070         cp2 = strrchr(cp1,'.');
6071         if (cp2) {
6072             int e_len, vs_len = 0;
6073             int is_dir = 0;
6074             char * cp3;
6075             cp3 = strchr(cp2,';');
6076             e_len = strlen(cp2);
6077             if (cp3) {
6078                 vs_len = strlen(cp3);
6079                 e_len = e_len - vs_len;
6080             }
6081             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6082             if (!is_dir) {
6083                 if (!decc_efs_charset) {
6084                     /* If this is not EFS, then not a directory */
6085                     PerlMem_free(trndir);
6086                     PerlMem_free(vmsdir);
6087                     set_errno(ENOTDIR);
6088                     set_vaxc_errno(RMS$_DIR);
6089                     return NULL;
6090                 }
6091             } else {
6092                 /* Ok, here we have an issue, technically if a .dir shows */
6093                 /* from inside a directory, then we should treat it as */
6094                 /* xxx^.dir.dir.  But we do not have that context at this */
6095                 /* point unless this is totally restructured, so we remove */
6096                 /* The .dir for now, and fix this better later */
6097                 dirlen = cp2 - trndir;
6098             }
6099             if (decc_efs_charset && !strchr(trndir,'/')) {
6100                 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6101                 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6102
6103                 for (; cp4 > cp1; cp4--) {
6104                     if (*cp4 == '.') {
6105                         if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6106                             memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6107                             *cp4 = '^';
6108                             dirlen++;
6109                         }
6110                     }
6111                 }
6112             }
6113         }
6114
6115       }
6116
6117       retlen = dirlen + 6;
6118       memcpy(buf, trndir, dirlen);
6119       buf[dirlen] = '\0';
6120
6121       /* We've picked up everything up to the directory file name.
6122          Now just add the type and version, and we're set. */
6123       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6124           strcat(buf,".dir");
6125       else
6126           strcat(buf,".DIR");
6127       if (!decc_filename_unix_no_version)
6128           strcat(buf,";1");
6129       PerlMem_free(trndir);
6130       PerlMem_free(vmsdir);
6131       return buf;
6132     }
6133     else {  /* VMS-style directory spec */
6134
6135       char *esa, *esal, term, *cp;
6136       char *my_esa;
6137       int my_esa_len;
6138       unsigned long int cmplen, haslower = 0;
6139       struct FAB dirfab = cc$rms_fab;
6140       rms_setup_nam(savnam);
6141       rms_setup_nam(dirnam);
6142
6143       esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
6144       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6145       esal = NULL;
6146 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6147       esal = (char *)PerlMem_malloc(VMS_MAXRSS);
6148       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6149 #endif
6150       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6151       rms_bind_fab_nam(dirfab, dirnam);
6152       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6153       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6154 #ifdef NAM$M_NO_SHORT_UPCASE
6155       if (decc_efs_case_preserve)
6156         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6157 #endif
6158
6159       for (cp = trndir; *cp; cp++)
6160         if (islower(*cp)) { haslower = 1; break; }
6161       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6162         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6163             (dirfab.fab$l_sts == RMS$_DNF) ||
6164             (dirfab.fab$l_sts == RMS$_PRV)) {
6165             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6166             sts = sys$parse(&dirfab);
6167         }
6168         if (!sts) {
6169           PerlMem_free(esa);
6170           if (esal != NULL)
6171               PerlMem_free(esal);
6172           PerlMem_free(trndir);
6173           PerlMem_free(vmsdir);
6174           set_errno(EVMSERR);
6175           set_vaxc_errno(dirfab.fab$l_sts);
6176           return NULL;
6177         }
6178       }
6179       else {
6180         savnam = dirnam;
6181         /* Does the file really exist? */
6182         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6183           /* Yes; fake the fnb bits so we'll check type below */
6184           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6185         }
6186         else { /* No; just work with potential name */
6187           if (dirfab.fab$l_sts    == RMS$_FNF
6188               || dirfab.fab$l_sts == RMS$_DNF
6189               || dirfab.fab$l_sts == RMS$_FND)
6190                 dirnam = savnam;
6191           else {
6192             int fab_sts;
6193             fab_sts = dirfab.fab$l_sts;
6194             sts = rms_free_search_context(&dirfab);
6195             PerlMem_free(esa);
6196             if (esal != NULL)
6197                 PerlMem_free(esal);
6198             PerlMem_free(trndir);
6199             PerlMem_free(vmsdir);
6200             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6201             return NULL;
6202           }
6203         }
6204       }
6205
6206       /* Make sure we are using the right buffer */
6207 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6208       if (esal != NULL) {
6209         my_esa = esal;
6210         my_esa_len = rms_nam_esll(dirnam);
6211       } else {
6212 #endif
6213         my_esa = esa;
6214         my_esa_len = rms_nam_esl(dirnam);
6215 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6216       }
6217 #endif
6218       my_esa[my_esa_len] = '\0';
6219       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6220         cp1 = strchr(my_esa,']');
6221         if (!cp1) cp1 = strchr(my_esa,'>');
6222         if (cp1) {  /* Should always be true */
6223           my_esa_len -= cp1 - my_esa - 1;
6224           memmove(my_esa, cp1 + 1, my_esa_len);
6225         }
6226       }
6227       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6228         /* Yep; check version while we're at it, if it's there. */
6229         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6230         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6231           /* Something other than .DIR[;1].  Bzzt. */
6232           sts = rms_free_search_context(&dirfab);
6233           PerlMem_free(esa);
6234           if (esal != NULL)
6235              PerlMem_free(esal);
6236           PerlMem_free(trndir);
6237           PerlMem_free(vmsdir);
6238           set_errno(ENOTDIR);
6239           set_vaxc_errno(RMS$_DIR);
6240           return NULL;
6241         }
6242       }
6243
6244       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6245         /* They provided at least the name; we added the type, if necessary, */
6246         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6247         sts = rms_free_search_context(&dirfab);
6248         PerlMem_free(trndir);
6249         PerlMem_free(esa);
6250         if (esal != NULL)
6251             PerlMem_free(esal);
6252         PerlMem_free(vmsdir);
6253         return buf;
6254       }
6255       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6256         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6257         *cp1 = '\0';
6258         my_esa_len -= 9;
6259       }
6260       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6261       if (cp1 == NULL) { /* should never happen */
6262         sts = rms_free_search_context(&dirfab);
6263         PerlMem_free(trndir);
6264         PerlMem_free(esa);
6265         if (esal != NULL)
6266             PerlMem_free(esal);
6267         PerlMem_free(vmsdir);
6268         return NULL;
6269       }
6270       term = *cp1;
6271       *cp1 = '\0';
6272       retlen = strlen(my_esa);
6273       cp1 = strrchr(my_esa,'.');
6274       /* ODS-5 directory specifications can have extra "." in them. */
6275       /* Fix-me, can not scan EFS file specifications backwards */
6276       while (cp1 != NULL) {
6277         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6278           break;
6279         else {
6280            cp1--;
6281            while ((cp1 > my_esa) && (*cp1 != '.'))
6282              cp1--;
6283         }
6284         if (cp1 == my_esa)
6285           cp1 = NULL;
6286       }
6287
6288       if ((cp1) != NULL) {
6289         /* There's more than one directory in the path.  Just roll back. */
6290         *cp1 = term;
6291         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6292       }
6293       else {
6294         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6295           /* Go back and expand rooted logical name */
6296           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6297 #ifdef NAM$M_NO_SHORT_UPCASE
6298           if (decc_efs_case_preserve)
6299             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6300 #endif
6301           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6302             sts = rms_free_search_context(&dirfab);
6303             PerlMem_free(esa);
6304             if (esal != NULL)
6305                 PerlMem_free(esal);
6306             PerlMem_free(trndir);
6307             PerlMem_free(vmsdir);
6308             set_errno(EVMSERR);
6309             set_vaxc_errno(dirfab.fab$l_sts);
6310             return NULL;
6311           }
6312
6313           /* This changes the length of the string of course */
6314           if (esal != NULL) {
6315               my_esa_len = rms_nam_esll(dirnam);
6316           } else {
6317               my_esa_len = rms_nam_esl(dirnam);
6318           }
6319
6320           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6321           cp1 = strstr(my_esa,"][");
6322           if (!cp1) cp1 = strstr(my_esa,"]<");
6323           dirlen = cp1 - my_esa;
6324           memcpy(buf, my_esa, dirlen);
6325           if (!strncmp(cp1+2,"000000]",7)) {
6326             buf[dirlen-1] = '\0';
6327             /* fix-me Not full ODS-5, just extra dots in directories for now */
6328             cp1 = buf + dirlen - 1;
6329             while (cp1 > buf)
6330             {
6331               if (*cp1 == '[')
6332                 break;
6333               if (*cp1 == '.') {
6334                 if (*(cp1-1) != '^')
6335                   break;
6336               }
6337               cp1--;
6338             }
6339             if (*cp1 == '.') *cp1 = ']';
6340             else {
6341               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6342               memmove(cp1+1,"000000]",7);
6343             }
6344           }
6345           else {
6346             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6347             buf[retlen] = '\0';
6348             /* Convert last '.' to ']' */
6349             cp1 = buf+retlen-1;
6350             while (*cp != '[') {
6351               cp1--;
6352               if (*cp1 == '.') {
6353                 /* Do not trip on extra dots in ODS-5 directories */
6354                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6355                 break;
6356               }
6357             }
6358             if (*cp1 == '.') *cp1 = ']';
6359             else {
6360               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6361               memmove(cp1+1,"000000]",7);
6362             }
6363           }
6364         }
6365         else {  /* This is a top-level dir.  Add the MFD to the path. */
6366           cp1 = strrchr(my_esa, ':');
6367           assert(cp1);
6368           memmove(buf, my_esa, cp1 - my_esa + 1);
6369           memmove(buf + (cp1 - my_esa) + 1, "[000000]", 8);
6370           memmove(buf + (cp1 - my_esa) + 9, cp1 + 2, retlen - (cp1 - my_esa + 2));
6371           buf[retlen + 7] = '\0';  /* We've inserted '000000]' */
6372         }
6373       }
6374       sts = rms_free_search_context(&dirfab);
6375       /* We've set up the string up through the filename.  Add the
6376          type and version, and we're done. */
6377       strcat(buf,".DIR;1");
6378
6379       /* $PARSE may have upcased filespec, so convert output to lower
6380        * case if input contained any lowercase characters. */
6381       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6382       PerlMem_free(trndir);
6383       PerlMem_free(esa);
6384       if (esal != NULL)
6385         PerlMem_free(esal);
6386       PerlMem_free(vmsdir);
6387       return buf;
6388     }
6389 }  /* end of int_fileify_dirspec() */
6390
6391
6392 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6393 static char *
6394 mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6395 {
6396     static char __fileify_retbuf[VMS_MAXRSS];
6397     char * fileified, *ret_spec, *ret_buf;
6398
6399     fileified = NULL;
6400     ret_buf = buf;
6401     if (ret_buf == NULL) {
6402         if (ts) {
6403             Newx(fileified, VMS_MAXRSS, char);
6404             if (fileified == NULL)
6405                 _ckvmssts(SS$_INSFMEM);
6406             ret_buf = fileified;
6407         } else {
6408             ret_buf = __fileify_retbuf;
6409         }
6410     }
6411
6412     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6413
6414     if (ret_spec == NULL) {
6415        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6416        if (fileified)
6417            Safefree(fileified);
6418     }
6419
6420     return ret_spec;
6421 }  /* end of do_fileify_dirspec() */
6422 /*}}}*/
6423
6424 /* External entry points */
6425 char *
6426 Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6427 {
6428     return do_fileify_dirspec(dir, buf, 0, NULL);
6429 }
6430
6431 char *
6432 Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6433 {
6434     return do_fileify_dirspec(dir, buf, 1, NULL);
6435 }
6436
6437 char *
6438 Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6439 {
6440     return do_fileify_dirspec(dir, buf, 0, utf8_fl);
6441 }
6442
6443 char *
6444 Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6445 {
6446     return do_fileify_dirspec(dir, buf, 1, utf8_fl);
6447 }
6448
6449 static char *
6450 int_pathify_dirspec_simple(const char * dir, char * buf,
6451     char * v_spec, int v_len, char * r_spec, int r_len,
6452     char * d_spec, int d_len, char * n_spec, int n_len,
6453     char * e_spec, int e_len, char * vs_spec, int vs_len)
6454 {
6455
6456     /* VMS specification - Try to do this the simple way */
6457     if ((v_len + r_len > 0) || (d_len > 0)) {
6458         int is_dir;
6459
6460         /* No name or extension component, already a directory */
6461         if ((n_len + e_len + vs_len) == 0) {
6462             strcpy(buf, dir);
6463             return buf;
6464         }
6465
6466         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6467         /* This results from catfile() being used instead of catdir() */
6468         /* So even though it should not work, we need to allow it */
6469
6470         /* If this is .DIR;1 then do a simple conversion */
6471         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6472         if (is_dir || (e_len == 0) && (d_len > 0)) {
6473              int len;
6474              len = v_len + r_len + d_len - 1;
6475              char dclose = d_spec[d_len - 1];
6476              memcpy(buf, dir, len);
6477              buf[len] = '.';
6478              len++;
6479              memcpy(&buf[len], n_spec, n_len);
6480              len += n_len;
6481              buf[len] = dclose;
6482              buf[len + 1] = '\0';
6483              return buf;
6484         }
6485
6486 #ifdef HAS_SYMLINK
6487         else if (d_len > 0) {
6488             /* In the olden days, a directory needed to have a .DIR */
6489             /* extension to be a valid directory, but now it could  */
6490             /* be a symbolic link */
6491             int len;
6492             len = v_len + r_len + d_len - 1;
6493             char dclose = d_spec[d_len - 1];
6494             memcpy(buf, dir, len);
6495             buf[len] = '.';
6496             len++;
6497             memcpy(&buf[len], n_spec, n_len);
6498             len += n_len;
6499             if (e_len > 0) {
6500                 if (decc_efs_charset) {
6501                     if (e_len == 4
6502                         && (toupper(e_spec[1]) == 'D')
6503                         && (toupper(e_spec[2]) == 'I')
6504                         && (toupper(e_spec[3]) == 'R')) {
6505
6506                         /* Corner case: directory spec with invalid version.
6507                          * Valid would have followed is_dir path above.
6508                          */
6509                         SETERRNO(ENOTDIR, RMS$_DIR);
6510                         return NULL;
6511                     }
6512                     else {
6513                         buf[len] = '^';
6514                         len++;
6515                         memcpy(&buf[len], e_spec, e_len);
6516                         len += e_len;
6517                     }
6518                 }
6519                 else {
6520                     SETERRNO(ENOTDIR, RMS$_DIR);
6521                     return NULL;
6522                 }
6523             }
6524             buf[len] = dclose;
6525             buf[len + 1] = '\0';
6526             return buf;
6527         }
6528 #else
6529         else {
6530             set_vaxc_errno(RMS$_DIR);
6531             set_errno(ENOTDIR);
6532             return NULL;
6533         }
6534 #endif
6535     }
6536     set_vaxc_errno(RMS$_DIR);
6537     set_errno(ENOTDIR);
6538     return NULL;
6539 }
6540
6541
6542 /* Internal routine to make sure or convert a directory to be in a */
6543 /* path specification.  No utf8 flag because it is not changed or used */
6544 static char *
6545 int_pathify_dirspec(const char *dir, char *buf)
6546 {
6547     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6548     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6549     char * exp_spec, *ret_spec;
6550     char * trndir;
6551     unsigned short int trnlnm_iter_count;
6552     STRLEN trnlen;
6553     int need_to_lower;
6554
6555     if (vms_debug_fileify) {
6556         if (dir == NULL)
6557             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6558         else
6559             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6560     }
6561
6562     /* We may need to lower case the result if we translated  */
6563     /* a logical name or got the current working directory */
6564     need_to_lower = 0;
6565
6566     if (!dir || !*dir) {
6567       set_errno(EINVAL);
6568       set_vaxc_errno(SS$_BADPARAM);
6569       return NULL;
6570     }
6571
6572     trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
6573     if (trndir == NULL)
6574         _ckvmssts_noperl(SS$_INSFMEM);
6575
6576     /* If no directory specified use the current default */
6577     if (*dir)
6578         my_strlcpy(trndir, dir, VMS_MAXRSS);
6579     else {
6580         getcwd(trndir, VMS_MAXRSS - 1);
6581         need_to_lower = 1;
6582     }
6583
6584     /* now deal with bare names that could be logical names */
6585     trnlnm_iter_count = 0;
6586     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6587            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6588         trnlnm_iter_count++;
6589         need_to_lower = 1;
6590         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6591             break;
6592         trnlen = strlen(trndir);
6593
6594         /* Trap simple rooted lnms, and return lnm:[000000] */
6595         if (!strcmp(trndir+trnlen-2,".]")) {
6596             my_strlcpy(buf, dir, VMS_MAXRSS);
6597             strcat(buf, ":[000000]");
6598             PerlMem_free(trndir);
6599
6600             if (vms_debug_fileify) {
6601                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6602             }
6603             return buf;
6604         }
6605     }
6606
6607     /* At this point we do not work with *dir, but the copy in  *trndir */
6608
6609     if (need_to_lower && !decc_efs_case_preserve) {
6610         /* Legacy mode, lower case the returned value */
6611         __mystrtolower(trndir);
6612     }
6613
6614
6615     /* Some special cases, '..', '.' */
6616     sts = 0;
6617     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6618        /* Force UNIX filespec */
6619        sts = 1;
6620
6621     } else {
6622         /* Is this Unix or VMS format? */
6623         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6624                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6625                              &e_len, &vs_spec, &vs_len);
6626         if (sts == 0) {
6627
6628             /* Just a filename? */
6629             if ((v_len + r_len + d_len) == 0) {
6630
6631                 /* Now we have a problem, this could be Unix or VMS */
6632                 /* We have to guess.  .DIR usually means VMS */
6633
6634                 /* In UNIX report mode, the .DIR extension is removed */
6635                 /* if one shows up, it is for a non-directory or a directory */
6636                 /* in EFS charset mode */
6637
6638                 /* So if we are in Unix report mode, assume that this */
6639                 /* is a relative Unix directory specification */
6640
6641                 sts = 1;
6642                 if (!decc_filename_unix_report && decc_efs_charset) {
6643                     int is_dir;
6644                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6645
6646                     if (is_dir) {
6647                         /* Traditional mode, assume .DIR is directory */
6648                         buf[0] = '[';
6649                         buf[1] = '.';
6650                         memcpy(&buf[2], n_spec, n_len);
6651                         buf[n_len + 2] = ']';
6652                         buf[n_len + 3] = '\0';
6653                         PerlMem_free(trndir);
6654                         if (vms_debug_fileify) {
6655                             fprintf(stderr,
6656                                     "int_pathify_dirspec: buf = %s\n",
6657                                     buf);
6658                         }
6659                         return buf;
6660                     }
6661                 }
6662             }
6663         }
6664     }
6665     if (sts == 0) {
6666         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6667             v_spec, v_len, r_spec, r_len,
6668             d_spec, d_len, n_spec, n_len,
6669             e_spec, e_len, vs_spec, vs_len);
6670
6671         if (ret_spec != NULL) {
6672             PerlMem_free(trndir);
6673             if (vms_debug_fileify) {
6674                 fprintf(stderr,
6675                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6676             }
6677             return ret_spec;
6678         }
6679
6680         /* Simple way did not work, which means that a logical name */
6681         /* was present for the directory specification.             */
6682         /* Need to use an rmsexpand variant to decode it completely */
6683         exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
6684         if (exp_spec == NULL)
6685             _ckvmssts_noperl(SS$_INSFMEM);
6686
6687         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6688         if (ret_spec != NULL) {
6689             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6690                                  &r_spec, &r_len, &d_spec, &d_len,
6691                                  &n_spec, &n_len, &e_spec,
6692                                  &e_len, &vs_spec, &vs_len);
6693             if (sts == 0) {
6694                 ret_spec = int_pathify_dirspec_simple(
6695                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6696                     d_spec, d_len, n_spec, n_len,
6697                     e_spec, e_len, vs_spec, vs_len);
6698
6699                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6700                     /* Legacy mode, lower case the returned value */
6701                     __mystrtolower(ret_spec);
6702                 }
6703             } else {
6704                 set_vaxc_errno(RMS$_DIR);
6705                 set_errno(ENOTDIR);
6706                 ret_spec = NULL;
6707             }
6708         }
6709         PerlMem_free(exp_spec);
6710         PerlMem_free(trndir);
6711         if (vms_debug_fileify) {
6712             if (ret_spec == NULL)
6713                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6714             else
6715                 fprintf(stderr,
6716                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6717         }
6718         return ret_spec;
6719
6720     } else {
6721         /* Unix specification, Could be trivial conversion, */
6722         /* but have to deal with trailing '.dir' or extra '.' */
6723
6724         char * lastdot;
6725         char * lastslash;
6726         int is_dir;
6727         STRLEN dir_len = strlen(trndir);
6728
6729         lastslash = strrchr(trndir, '/');
6730         if (lastslash == NULL)
6731             lastslash = trndir;
6732         else
6733             lastslash++;
6734
6735         lastdot = NULL;
6736
6737         /* '..' or '.' are valid directory components */
6738         is_dir = 0;
6739         if (lastslash[0] == '.') {
6740             if (lastslash[1] == '\0') {
6741                is_dir = 1;
6742             } else if (lastslash[1] == '.') {
6743                 if (lastslash[2] == '\0') {
6744                     is_dir = 1;
6745                 } else {
6746                     /* And finally allow '...' */
6747                     if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6748                         is_dir = 1;
6749                     }
6750                 }
6751             }
6752         }
6753
6754         if (!is_dir) {
6755            lastdot = strrchr(lastslash, '.');
6756         }
6757         if (lastdot != NULL) {
6758             STRLEN e_len;
6759              /* '.dir' is discarded, and any other '.' is invalid */
6760             e_len = strlen(lastdot);
6761
6762             is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6763
6764             if (is_dir) {
6765                 dir_len = dir_len - 4;
6766             }
6767         }
6768
6769         my_strlcpy(buf, trndir, VMS_MAXRSS);
6770         if (buf[dir_len - 1] != '/') {
6771             buf[dir_len] = '/';
6772             buf[dir_len + 1] = '\0';
6773         }
6774
6775         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6776         if (!decc_efs_charset) {
6777              int dir_start = 0;
6778              char * str = buf;
6779              if (str[0] == '.') {
6780                  char * dots = str;
6781                  int cnt = 1;
6782                  while ((dots[cnt] == '.') && (cnt < 3))
6783                      cnt++;
6784                  if (cnt <= 3) {
6785                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6786                          dir_start = 1;
6787                          str += cnt;
6788                      }
6789                  }
6790              }
6791              for (; *str; ++str) {
6792                  while (*str == '/') {
6793                      dir_start = 1;
6794                      *str++;
6795                  }
6796                  if (dir_start) {
6797
6798                      /* Have to skip up to three dots which could be */
6799                      /* directories, 3 dots being a VMS extension for Perl */
6800                      char * dots = str;
6801                      int cnt = 0;
6802                      while ((dots[cnt] == '.') && (cnt < 3)) {
6803                          cnt++;
6804                      }
6805                      if (dots[cnt] == '\0')
6806                          break;
6807                      if ((cnt > 1) && (dots[cnt] != '/')) {
6808                          dir_start = 0;
6809                      } else {
6810                          str += cnt;
6811                      }
6812
6813                      /* too many dots? */
6814                      if ((cnt == 0) || (cnt > 3)) {
6815                          dir_start = 0;
6816                      }
6817                  }
6818                  if (!dir_start && (*str == '.')) {
6819                      *str = '_';
6820                  }
6821              }
6822         }
6823         PerlMem_free(trndir);
6824         ret_spec = buf;
6825         if (vms_debug_fileify) {
6826             if (ret_spec == NULL)
6827                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6828             else
6829                 fprintf(stderr,
6830                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6831         }
6832         return ret_spec;
6833     }
6834 }
6835
6836 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6837 static char *
6838 mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6839 {
6840     static char __pathify_retbuf[VMS_MAXRSS];
6841     char * pathified, *ret_spec, *ret_buf;
6842
6843     pathified = NULL;
6844     ret_buf = buf;
6845     if (ret_buf == NULL) {
6846         if (ts) {
6847             Newx(pathified, VMS_MAXRSS, char);
6848             if (pathified == NULL)
6849                 _ckvmssts(SS$_INSFMEM);
6850             ret_buf = pathified;
6851         } else {
6852             ret_buf = __pathify_retbuf;
6853         }
6854     }
6855
6856     ret_spec = int_pathify_dirspec(dir, ret_buf);
6857
6858     if (ret_spec == NULL) {
6859        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6860        if (pathified)
6861            Safefree(pathified);
6862     }
6863
6864     return ret_spec;
6865
6866 }  /* end of do_pathify_dirspec() */
6867
6868
6869 /* External entry points */
6870 char *
6871 Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6872 {
6873     return do_pathify_dirspec(dir, buf, 0, NULL);
6874 }
6875
6876 char *
6877 Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6878 {
6879     return do_pathify_dirspec(dir, buf, 1, NULL);
6880 }
6881
6882 char *
6883 Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6884 {
6885     return do_pathify_dirspec(dir, buf, 0, utf8_fl);
6886 }
6887
6888 char *
6889 Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6890 {
6891     return do_pathify_dirspec(dir, buf, 1, utf8_fl);
6892 }
6893
6894 /* Internal tounixspec routine that does not use a thread context */
6895 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6896 static char *
6897 int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6898 {
6899   char *dirend, *cp1, *cp3, *tmp;
6900   const char *cp2;
6901   int dirlen;
6902   unsigned short int trnlnm_iter_count;
6903   int cmp_rslt, outchars_added;
6904   if (utf8_fl != NULL)
6905     *utf8_fl = 0;
6906
6907   if (vms_debug_fileify) {
6908       if (spec == NULL)
6909           fprintf(stderr, "int_tounixspec: spec = NULL\n");
6910       else
6911           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6912   }
6913
6914
6915   if (spec == NULL) {
6916       set_errno(EINVAL);
6917       set_vaxc_errno(SS$_BADPARAM);
6918       return NULL;
6919   }
6920   if (strlen(spec) > (VMS_MAXRSS-1)) {
6921       set_errno(E2BIG);
6922       set_vaxc_errno(SS$_BUFFEROVF);
6923       return NULL;
6924   }
6925
6926   /* New VMS specific format needs translation
6927    * glob passes filenames with trailing '\n' and expects this preserved.
6928    */
6929   if (decc_posix_compliant_pathnames) {
6930     if (strncmp(spec, "\"^UP^", 5) == 0) {
6931       char * uspec;
6932       char *tunix;
6933       int tunix_len;
6934       int nl_flag;
6935
6936       tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
6937       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6938       tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
6939       nl_flag = 0;
6940       if (tunix[tunix_len - 1] == '\n') {
6941         tunix[tunix_len - 1] = '\"';
6942         tunix[tunix_len] = '\0';
6943         tunix_len--;
6944         nl_flag = 1;
6945       }
6946       uspec = decc$translate_vms(tunix);
6947       PerlMem_free(tunix);
6948       if ((int)uspec > 0) {
6949         my_strlcpy(rslt, uspec, VMS_MAXRSS);
6950         if (nl_flag) {
6951           strcat(rslt,"\n");
6952         }
6953         else {
6954           /* If we can not translate it, makemaker wants as-is */
6955           my_strlcpy(rslt, spec, VMS_MAXRSS);
6956         }
6957         return rslt;
6958       }
6959     }
6960   }
6961
6962   cmp_rslt = 0; /* Presume VMS */
6963   cp1 = strchr(spec, '/');
6964   if (cp1 == NULL)
6965     cmp_rslt = 0;
6966
6967     /* Look for EFS ^/ */
6968     if (decc_efs_charset) {
6969       while (cp1 != NULL) {
6970         cp2 = cp1 - 1;
6971         if (*cp2 != '^') {
6972           /* Found illegal VMS, assume UNIX */
6973           cmp_rslt = 1;
6974           break;
6975         }
6976       cp1++;
6977       cp1 = strchr(cp1, '/');
6978     }
6979   }
6980
6981   /* Look for "." and ".." */
6982   if (decc_filename_unix_report) {
6983     if (spec[0] == '.') {
6984       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6985         cmp_rslt = 1;
6986       }
6987       else {
6988         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6989           cmp_rslt = 1;
6990         }
6991       }
6992     }
6993   }
6994
6995   cp1 = rslt;
6996   cp2 = spec;
6997
6998   /* This is already UNIX or at least nothing VMS understands,
6999    * so all we can reasonably do is unescape extended chars.
7000    */
7001   if (cmp_rslt) {
7002     while (*cp2) {
7003         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7004         cp1 += outchars_added;
7005     }
7006     *cp1 = '\0';
7007     if (vms_debug_fileify) {
7008         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7009     }
7010     return rslt;
7011   }
7012
7013   dirend = strrchr(spec,']');
7014   if (dirend == NULL) dirend = strrchr(spec,'>');
7015   if (dirend == NULL) dirend = strchr(spec,':');
7016   if (dirend == NULL) {
7017     while (*cp2) {
7018         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7019         cp1 += outchars_added;
7020     }
7021     *cp1 = '\0';
7022     if (vms_debug_fileify) {
7023         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7024     }
7025     return rslt;
7026   }
7027
7028   /* Special case 1 - sys$posix_root = / */
7029   if (!decc_disable_posix_root) {
7030     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7031       *cp1 = '/';
7032       cp1++;
7033       cp2 = cp2 + 15;
7034       }
7035   }
7036
7037   /* Special case 2 - Convert NLA0: to /dev/null */
7038   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7039   if (cmp_rslt == 0) {
7040     strcpy(rslt, "/dev/null");
7041     cp1 = cp1 + 9;
7042     cp2 = cp2 + 5;
7043     if (spec[6] != '\0') {
7044       cp1[9] = '/';
7045       cp1++;
7046       cp2++;
7047     }
7048   }
7049
7050    /* Also handle special case "SYS$SCRATCH:" */
7051   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7052   tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
7053   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7054   if (cmp_rslt == 0) {
7055   int islnm;
7056
7057     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7058     if (!islnm) {
7059       strcpy(rslt, "/tmp");
7060       cp1 = cp1 + 4;
7061       cp2 = cp2 + 12;
7062       if (spec[12] != '\0') {
7063         cp1[4] = '/';
7064         cp1++;
7065         cp2++;
7066       }
7067     }
7068   }
7069
7070   if (*cp2 != '[' && *cp2 != '<') {
7071     *(cp1++) = '/';
7072   }
7073   else {  /* the VMS spec begins with directories */
7074     cp2++;
7075     if (*cp2 == ']' || *cp2 == '>') {
7076       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7077       PerlMem_free(tmp);
7078       return rslt;
7079     }
7080     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7081       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7082         PerlMem_free(tmp);
7083         if (vms_debug_fileify) {
7084             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7085         }
7086         return NULL;
7087       }
7088       trnlnm_iter_count = 0;
7089       do {
7090         cp3 = tmp;
7091         while (*cp3 != ':' && *cp3) cp3++;
7092         *(cp3++) = '\0';
7093         if (strchr(cp3,']') != NULL) break;
7094         trnlnm_iter_count++;
7095         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7096       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7097       cp1 = rslt;
7098       cp3 = tmp;
7099       *(cp1++) = '/';
7100       while (*cp3) {
7101         *(cp1++) = *(cp3++);
7102         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7103             PerlMem_free(tmp);
7104             set_errno(ENAMETOOLONG);
7105             set_vaxc_errno(SS$_BUFFEROVF);
7106             if (vms_debug_fileify) {
7107                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7108             }
7109             return NULL; /* No room */
7110         }
7111       }
7112       *(cp1++) = '/';
7113     }
7114     if ((*cp2 == '^')) {
7115         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7116         cp1 += outchars_added;
7117     }
7118     else if ( *cp2 == '.') {
7119       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7120         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7121         cp2 += 3;
7122       }
7123       else cp2++;
7124     }
7125   }
7126   PerlMem_free(tmp);
7127   for (; cp2 <= dirend; cp2++) {
7128     if ((*cp2 == '^')) {
7129         /* EFS file escape -- unescape it. */
7130         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added) - 1;
7131         cp1 += outchars_added;
7132     }
7133     else if (*cp2 == ':') {
7134       *(cp1++) = '/';
7135       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7136     }
7137     else if (*cp2 == ']' || *cp2 == '>') {
7138       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7139     }
7140     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7141       *(cp1++) = '/';
7142       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7143         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7144                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7145         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7146             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7147       }
7148       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7149         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7150         cp2 += 2;
7151       }
7152     }
7153     else if (*cp2 == '-') {
7154       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7155         while (*cp2 == '-') {
7156           cp2++;
7157           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7158         }
7159         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7160                                                          /* filespecs like */
7161           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7162           if (vms_debug_fileify) {
7163               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7164           }
7165           return NULL;
7166         }
7167       }
7168       else *(cp1++) = *cp2;
7169     }
7170     else *(cp1++) = *cp2;
7171   }
7172   /* Translate the rest of the filename. */
7173   while (*cp2) {
7174       int dot_seen = 0;
7175       switch(*cp2) {
7176       /* Fixme - for compatibility with the CRTL we should be removing */
7177       /* spaces from the file specifications, but this may show that */
7178       /* some tests that were appearing to pass are not really passing */
7179       case '%':
7180           cp2++;
7181           *(cp1++) = '?';
7182           break;
7183       case '^':
7184           cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7185           cp1 += outchars_added;
7186           break;
7187       case ';':
7188           if (decc_filename_unix_no_version) {
7189               /* Easy, drop the version */
7190               while (*cp2)
7191                   cp2++;
7192               break;
7193           } else {
7194               /* Punt - passing the version as a dot will probably */
7195               /* break perl in weird ways, but so did passing */
7196               /* through the ; as a version.  Follow the CRTL and */
7197               /* hope for the best. */
7198               cp2++;
7199               *(cp1++) = '.';
7200           }
7201           break;
7202       case '.':
7203           if (dot_seen) {
7204               /* We will need to fix this properly later */
7205               /* As Perl may be installed on an ODS-5 volume, but not */
7206               /* have the EFS_CHARSET enabled, it still may encounter */
7207               /* filenames with extra dots in them, and a precedent got */
7208               /* set which allowed them to work, that we will uphold here */
7209               /* If extra dots are present in a name and no ^ is on them */
7210               /* VMS assumes that the first one is the extension delimiter */
7211               /* the rest have an implied ^. */
7212
7213               /* this is also a conflict as the . is also a version */
7214               /* delimiter in VMS, */
7215
7216               *(cp1++) = *(cp2++);
7217               break;
7218           }
7219           dot_seen = 1;
7220           /* This is an extension */
7221           if (decc_readdir_dropdotnotype) {
7222               cp2++;
7223               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7224                   /* Drop the dot for the extension */
7225                   break;
7226               } else {
7227                   *(cp1++) = '.';
7228               }
7229               break;
7230           }
7231       default:
7232           *(cp1++) = *(cp2++);
7233       }
7234   }
7235   *cp1 = '\0';
7236
7237   /* This still leaves /000000/ when working with a
7238    * VMS device root or concealed root.
7239    */
7240   {
7241       int ulen;
7242       char * zeros;
7243
7244       ulen = strlen(rslt);
7245
7246       /* Get rid of "000000/ in rooted filespecs */
7247       if (ulen > 7) {
7248         zeros = strstr(rslt, "/000000/");
7249         if (zeros != NULL) {
7250           int mlen;
7251           mlen = ulen - (zeros - rslt) - 7;
7252           memmove(zeros, &zeros[7], mlen);
7253           ulen = ulen - 7;
7254           rslt[ulen] = '\0';
7255         }
7256       }
7257   }
7258
7259   if (vms_debug_fileify) {
7260       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7261   }
7262   return rslt;
7263
7264 }  /* end of int_tounixspec() */
7265
7266
7267 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7268 static char *
7269 mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7270 {
7271     static char __tounixspec_retbuf[VMS_MAXRSS];
7272     char * unixspec, *ret_spec, *ret_buf;
7273
7274     unixspec = NULL;
7275     ret_buf = buf;
7276     if (ret_buf == NULL) {
7277         if (ts) {
7278             Newx(unixspec, VMS_MAXRSS, char);
7279             if (unixspec == NULL)
7280                 _ckvmssts(SS$_INSFMEM);
7281             ret_buf = unixspec;
7282         } else {
7283             ret_buf = __tounixspec_retbuf;
7284         }
7285     }
7286
7287     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7288
7289     if (ret_spec == NULL) {
7290        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7291        if (unixspec)
7292            Safefree(unixspec);
7293     }
7294
7295     return ret_spec;
7296
7297 }  /* end of do_tounixspec() */
7298 /*}}}*/
7299 /* External entry points */
7300 char *
7301 Perl_tounixspec(pTHX_ const char *spec, char *buf)
7302 {
7303     return do_tounixspec(spec, buf, 0, NULL);
7304 }
7305
7306 char *
7307 Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7308 {
7309     return do_tounixspec(spec,buf,1, NULL);
7310 }
7311
7312 char *
7313 Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7314 {
7315     return do_tounixspec(spec,buf,0, utf8_fl);
7316 }
7317
7318 char *
7319 Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7320 {
7321     return do_tounixspec(spec,buf,1, utf8_fl);
7322 }
7323
7324 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7325
7326 /*
7327  This procedure is used to identify if a path is based in either
7328  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7329  it returns the OpenVMS format directory for it.
7330
7331  It is expecting specifications of only '/' or '/xxxx/'
7332
7333  If a posix root does not exist, or 'xxxx' is not a directory
7334  in the posix root, it returns a failure.
7335
7336  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7337
7338  It is used only internally by posix_to_vmsspec_hardway().
7339  */
7340
7341 static int
7342 posix_root_to_vms(char *vmspath, int vmspath_len,
7343                   const char *unixpath, const int * utf8_fl)
7344 {
7345   int sts;
7346   struct FAB myfab = cc$rms_fab;
7347   rms_setup_nam(mynam);
7348   struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7349   struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7350   char * esa, * esal, * rsa, * rsal;
7351   int dir_flag;
7352   int unixlen;
7353
7354   dir_flag = 0;
7355   vmspath[0] = '\0';
7356   unixlen = strlen(unixpath);
7357   if (unixlen == 0) {
7358     return RMS$_FNF;
7359   }
7360
7361 #if __CRTL_VER >= 80200000
7362   /* If not a posix spec already, convert it */
7363   if (decc_posix_compliant_pathnames) {
7364     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7365       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7366     }
7367     else {
7368       /* This is already a VMS specification, no conversion */
7369       unixlen--;
7370       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7371     }
7372   }
7373   else
7374 #endif
7375   {
7376      int path_len;
7377      int i,j;
7378
7379      /* Check to see if this is under the POSIX root */
7380      if (decc_disable_posix_root) {
7381         return RMS$_FNF;
7382      }
7383
7384      /* Skip leading / */
7385      if (unixpath[0] == '/') {
7386         unixpath++;
7387         unixlen--;
7388      }
7389
7390
7391      strcpy(vmspath,"SYS$POSIX_ROOT:");
7392
7393      /* If this is only the / , or blank, then... */
7394      if (unixpath[0] == '\0') {
7395         /* by definition, this is the answer */
7396         return SS$_NORMAL;
7397      }
7398
7399      /* Need to look up a directory */
7400      vmspath[15] = '[';
7401      vmspath[16] = '\0';
7402
7403      /* Copy and add '^' escape characters as needed */
7404      j = 16;
7405      i = 0;
7406      while (unixpath[i] != 0) {
7407      int k;
7408
7409         j += copy_expand_unix_filename_escape
7410             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7411         i += k;
7412      }
7413
7414      path_len = strlen(vmspath);
7415      if (vmspath[path_len - 1] == '/')
7416         path_len--;
7417      vmspath[path_len] = ']';
7418      path_len++;
7419      vmspath[path_len] = '\0';
7420
7421   }
7422   vmspath[vmspath_len] = 0;
7423   if (unixpath[unixlen - 1] == '/')
7424   dir_flag = 1;
7425   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7426   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7427   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7428   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7429   rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7430   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7431   rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7432   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7433   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7434   rms_bind_fab_nam(myfab, mynam);
7435   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7436   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7437   if (decc_efs_case_preserve)
7438     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7439 #ifdef NAML$M_OPEN_SPECIAL
7440   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7441 #endif
7442
7443   /* Set up the remaining naml fields */
7444   sts = sys$parse(&myfab);
7445
7446   /* It failed! Try again as a UNIX filespec */
7447   if (!(sts & 1)) {
7448     PerlMem_free(esal);
7449     PerlMem_free(esa);
7450     PerlMem_free(rsal);
7451     PerlMem_free(rsa);
7452     return sts;
7453   }
7454
7455    /* get the Device ID and the FID */
7456    sts = sys$search(&myfab);
7457
7458    /* These are no longer needed */
7459    PerlMem_free(esa);
7460    PerlMem_free(rsal);
7461    PerlMem_free(rsa);
7462
7463    /* on any failure, returned the POSIX ^UP^ filespec */
7464    if (!(sts & 1)) {
7465       PerlMem_free(esal);
7466       return sts;
7467    }
7468    specdsc.dsc$a_pointer = vmspath;
7469    specdsc.dsc$w_length = vmspath_len;
7470
7471    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7472    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7473    sts = lib$fid_to_name
7474       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7475
7476   /* on any failure, returned the POSIX ^UP^ filespec */
7477   if (!(sts & 1)) {
7478      /* This can happen if user does not have permission to read directories */
7479      if (strncmp(unixpath,"\"^UP^",5) != 0)
7480        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7481      else
7482        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7483   }
7484   else {
7485     vmspath[specdsc.dsc$w_length] = 0;
7486
7487     /* Are we expecting a directory? */
7488     if (dir_flag != 0) {
7489     int i;
7490     char *eptr;
7491
7492       eptr = NULL;
7493
7494       i = specdsc.dsc$w_length - 1;
7495       while (i > 0) {
7496       int zercnt;
7497         zercnt = 0;
7498         /* Version must be '1' */
7499         if (vmspath[i--] != '1')
7500           break;
7501         /* Version delimiter is one of ".;" */
7502         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7503           break;
7504         i--;
7505         if (vmspath[i--] != 'R')
7506           break;
7507         if (vmspath[i--] != 'I')
7508           break;
7509         if (vmspath[i--] != 'D')
7510           break;
7511         if (vmspath[i--] != '.')
7512           break;
7513         eptr = &vmspath[i+1];
7514         while (i > 0) {
7515           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7516             if (vmspath[i-1] != '^') {
7517               if (zercnt != 6) {
7518                 *eptr = vmspath[i];
7519                 eptr[1] = '\0';
7520                 vmspath[i] = '.';
7521                 break;
7522               }
7523               else {
7524                 /* Get rid of 6 imaginary zero directory filename */
7525                 vmspath[i+1] = '\0';
7526               }
7527             }
7528           }
7529           if (vmspath[i] == '0')
7530             zercnt++;
7531           else
7532             zercnt = 10;
7533           i--;
7534         }
7535         break;
7536       }
7537     }
7538   }
7539   PerlMem_free(esal);
7540   return sts;
7541 }
7542
7543 /* /dev/mumble needs to be handled special.
7544    /dev/null becomes NLA0:, And there is the potential for other stuff
7545    like /dev/tty which may need to be mapped to something.
7546 */
7547
7548 static int
7549 slash_dev_special_to_vms(const char *unixptr, char *vmspath, int vmspath_len)
7550 {
7551     char * nextslash;
7552     int len;
7553     int cmp;
7554
7555     unixptr += 4;
7556     nextslash = strchr(unixptr, '/');
7557     len = strlen(unixptr);
7558     if (nextslash != NULL)
7559         len = nextslash - unixptr;
7560     cmp = strncmp("null", unixptr, 5);
7561     if (cmp == 0) {
7562         if (vmspath_len >= 6) {
7563             strcpy(vmspath, "_NLA0:");
7564             return SS$_NORMAL;
7565         }
7566     }
7567     return 0;
7568 }
7569
7570
7571 /* The built in routines do not understand perl's special needs, so
7572     doing a manual conversion from UNIX to VMS
7573
7574     If the utf8_fl is not null and points to a non-zero value, then
7575     treat 8 bit characters as UTF-8.
7576
7577     The sequence starting with '$(' and ending with ')' will be passed
7578     through with out interpretation instead of being escaped.
7579
7580   */
7581 static int
7582 posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath,
7583                          int dir_flag, int * utf8_fl)
7584 {
7585
7586   char *esa;
7587   const char *unixptr;
7588   const char *unixend;
7589   char *vmsptr;
7590   const char *lastslash;
7591   const char *lastdot;
7592   int unixlen;
7593   int vmslen;
7594   int dir_start;
7595   int dir_dot;
7596   int quoted;
7597   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7598   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7599
7600   if (utf8_fl != NULL)
7601     *utf8_fl = 0;
7602
7603   unixptr = unixpath;
7604   dir_dot = 0;
7605
7606   /* Ignore leading "/" characters */
7607   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7608     unixptr++;
7609   }
7610   unixlen = strlen(unixptr);
7611
7612   /* Do nothing with blank paths */
7613   if (unixlen == 0) {
7614     vmspath[0] = '\0';
7615     return SS$_NORMAL;
7616   }
7617
7618   quoted = 0;
7619   /* This could have a "^UP^ on the front */
7620   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7621     quoted = 1;
7622     unixptr+= 5;
7623     unixlen-= 5;
7624   }
7625
7626   lastslash = strrchr(unixptr,'/');
7627   lastdot = strrchr(unixptr,'.');
7628   unixend = strrchr(unixptr,'\"');
7629   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7630     unixend = unixptr + unixlen;
7631   }
7632
7633   /* last dot is last dot or past end of string */
7634   if (lastdot == NULL)
7635     lastdot = unixptr + unixlen;
7636
7637   /* if no directories, set last slash to beginning of string */
7638   if (lastslash == NULL) {
7639     lastslash = unixptr;
7640   }
7641   else {
7642     /* Watch out for trailing "." after last slash, still a directory */
7643     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7644       lastslash = unixptr + unixlen;
7645     }
7646
7647     /* Watch out for trailing ".." after last slash, still a directory */
7648     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7649       lastslash = unixptr + unixlen;
7650     }
7651
7652     /* dots in directories are aways escaped */
7653     if (lastdot < lastslash)
7654       lastdot = unixptr + unixlen;
7655   }
7656
7657   /* if (unixptr < lastslash) then we are in a directory */
7658
7659   dir_start = 0;
7660
7661   vmsptr = vmspath;
7662   vmslen = 0;
7663
7664   /* Start with the UNIX path */
7665   if (*unixptr != '/') {
7666     /* relative paths */
7667
7668     /* If allowing logical names on relative pathnames, then handle here */
7669     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7670         !decc_posix_compliant_pathnames) {
7671     char * nextslash;
7672     int seg_len;
7673     char * trn;
7674     int islnm;
7675
7676         /* Find the next slash */
7677         nextslash = strchr(unixptr,'/');
7678
7679         esa = (char *)PerlMem_malloc(vmspath_len);
7680         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7681
7682         trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7683         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7684
7685         if (nextslash != NULL) {
7686
7687             seg_len = nextslash - unixptr;
7688             memcpy(esa, unixptr, seg_len);
7689             esa[seg_len] = 0;
7690         }
7691         else {
7692             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7693         }
7694         /* trnlnm(section) */
7695         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7696
7697         if (islnm) {
7698             /* Now fix up the directory */
7699
7700             /* Split up the path to find the components */
7701             sts = vms_split_path
7702                   (trn,
7703                    &v_spec,
7704                    &v_len,
7705                    &r_spec,
7706                    &r_len,
7707                    &d_spec,
7708                    &d_len,
7709                    &n_spec,
7710                    &n_len,
7711                    &e_spec,
7712                    &e_len,
7713                    &vs_spec,
7714                    &vs_len);
7715
7716             while (sts == 0) {
7717             int cmp;
7718
7719                 /* A logical name must be a directory  or the full
7720                    specification.  It is only a full specification if
7721                    it is the only component */
7722                 if ((unixptr[seg_len] == '\0') ||
7723                     (unixptr[seg_len+1] == '\0')) {
7724
7725                     /* Is a directory being required? */
7726                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7727                         /* Not a logical name */
7728                         break;
7729                     }
7730
7731
7732                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7733                         /* This must be a directory */
7734                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7735                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7736                             vmsptr[vmslen] = ':';
7737                             vmslen++;
7738                             vmsptr[vmslen] = '\0';
7739                             return SS$_NORMAL;
7740                         }
7741                     }
7742
7743                 }
7744
7745
7746                 /* must be dev/directory - ignore version */
7747                 if ((n_len + e_len) != 0)
7748                     break;
7749
7750                 /* transfer the volume */
7751                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7752                     memcpy(vmsptr, v_spec, v_len);
7753                     vmsptr += v_len;
7754                     vmsptr[0] = '\0';
7755                     vmslen += v_len;
7756                 }
7757
7758                 /* unroot the rooted directory */
7759                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7760                     r_spec[0] = '[';
7761                     r_spec[r_len - 1] = ']';
7762
7763                     /* This should not be there, but nothing is perfect */
7764                     if (r_len > 9) {
7765                         cmp = strcmp(&r_spec[1], "000000.");
7766                         if (cmp == 0) {
7767                             r_spec += 7;
7768                             r_spec[7] = '[';
7769                             r_len -= 7;
7770                             if (r_len == 2)
7771                                 r_len = 0;
7772                         }
7773                     }
7774                     if (r_len > 0) {
7775                         memcpy(vmsptr, r_spec, r_len);
7776                         vmsptr += r_len;
7777                         vmslen += r_len;
7778                         vmsptr[0] = '\0';
7779                     }
7780                 }
7781                 /* Bring over the directory. */
7782                 if ((d_len > 0) &&
7783                     ((d_len + vmslen) < vmspath_len)) {
7784                     d_spec[0] = '[';
7785                     d_spec[d_len - 1] = ']';
7786                     if (d_len > 9) {
7787                         cmp = strcmp(&d_spec[1], "000000.");
7788                         if (cmp == 0) {
7789                             d_spec += 7;
7790                             d_spec[7] = '[';
7791                             d_len -= 7;
7792                             if (d_len == 2)
7793                                 d_len = 0;
7794                         }
7795                     }
7796
7797                     if (r_len > 0) {
7798                         /* Remove the redundant root */
7799                         if (r_len > 0) {
7800                             /* remove the ][ */
7801                             vmsptr--;
7802                             vmslen--;
7803                             d_spec++;
7804                             d_len--;
7805                         }
7806                         memcpy(vmsptr, d_spec, d_len);
7807                             vmsptr += d_len;
7808                             vmslen += d_len;
7809                             vmsptr[0] = '\0';
7810                     }
7811                 }
7812                 break;
7813             }
7814         }
7815
7816         PerlMem_free(esa);
7817         PerlMem_free(trn);
7818     }
7819
7820     if (lastslash > unixptr) {
7821     int dotdir_seen;
7822
7823       /* skip leading ./ */
7824       dotdir_seen = 0;
7825       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7826         dotdir_seen = 1;
7827         unixptr++;
7828         unixptr++;
7829       }
7830
7831       /* Are we still in a directory? */
7832       if (unixptr <= lastslash) {
7833         *vmsptr++ = '[';
7834         vmslen = 1;
7835         dir_start = 1;
7836
7837         /* if not backing up, then it is relative forward. */
7838         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7839               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7840           *vmsptr++ = '.';
7841           vmslen++;
7842           dir_dot = 1;
7843           }
7844        }
7845        else {
7846          if (dotdir_seen) {
7847            /* Perl wants an empty directory here to tell the difference
7848             * between a DCL command and a filename
7849             */
7850           *vmsptr++ = '[';
7851           *vmsptr++ = ']';
7852           vmslen = 2;
7853         }
7854       }
7855     }
7856     else {
7857       /* Handle two special files . and .. */
7858       if (unixptr[0] == '.') {
7859         if (&unixptr[1] == unixend) {
7860           *vmsptr++ = '[';
7861           *vmsptr++ = ']';
7862           vmslen += 2;
7863           *vmsptr++ = '\0';
7864           return SS$_NORMAL;
7865         }
7866         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7867           *vmsptr++ = '[';
7868           *vmsptr++ = '-';
7869           *vmsptr++ = ']';
7870           vmslen += 3;
7871           *vmsptr++ = '\0';
7872           return SS$_NORMAL;
7873         }
7874       }
7875     }
7876   }
7877   else {        /* Absolute PATH handling */
7878   int sts;
7879   char * nextslash;
7880   int seg_len;
7881     /* Need to find out where root is */
7882
7883     /* In theory, this procedure should never get an absolute POSIX pathname
7884      * that can not be found on the POSIX root.
7885      * In practice, that can not be relied on, and things will show up
7886      * here that are a VMS device name or concealed logical name instead.
7887      * So to make things work, this procedure must be tolerant.
7888      */
7889     esa = (char *)PerlMem_malloc(vmspath_len);
7890     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7891
7892     sts = SS$_NORMAL;
7893     nextslash = strchr(&unixptr[1],'/');
7894     seg_len = 0;
7895     if (nextslash != NULL) {
7896       int cmp;
7897       seg_len = nextslash - &unixptr[1];
7898       my_strlcpy(vmspath, unixptr, seg_len + 2);
7899       cmp = 1;
7900       if (seg_len == 3) {
7901         cmp = strncmp(vmspath, "dev", 4);
7902         if (cmp == 0) {
7903             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7904             if (sts == SS$_NORMAL)
7905                 return SS$_NORMAL;
7906         }
7907       }
7908       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7909     }
7910
7911     if ($VMS_STATUS_SUCCESS(sts)) {
7912       /* This is verified to be a real path */
7913
7914       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7915       if ($VMS_STATUS_SUCCESS(sts)) {
7916         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
7917         vmsptr = vmspath + vmslen;
7918         unixptr++;
7919         if (unixptr < lastslash) {
7920         char * rptr;
7921           vmsptr--;
7922           *vmsptr++ = '.';
7923           dir_start = 1;
7924           dir_dot = 1;
7925           if (vmslen > 7) {
7926           int cmp;
7927             rptr = vmsptr - 7;
7928             cmp = strcmp(rptr,"000000.");
7929             if (cmp == 0) {
7930               vmslen -= 7;
7931               vmsptr -= 7;
7932               vmsptr[1] = '\0';
7933             } /* removing 6 zeros */
7934           } /* vmslen < 7, no 6 zeros possible */
7935         } /* Not in a directory */
7936       } /* Posix root found */
7937       else {
7938         /* No posix root, fall back to default directory */
7939         strcpy(vmspath, "SYS$DISK:[");
7940         vmsptr = &vmspath[10];
7941         vmslen = 10;
7942         if (unixptr > lastslash) {
7943            *vmsptr = ']';
7944            vmsptr++;
7945            vmslen++;
7946         }
7947         else {
7948            dir_start = 1;
7949         }
7950       }
7951     } /* end of verified real path handling */
7952     else {
7953     int add_6zero;
7954     int islnm;
7955
7956       /* Ok, we have a device or a concealed root that is not in POSIX
7957        * or we have garbage.  Make the best of it.
7958        */
7959
7960       /* Posix to VMS destroyed this, so copy it again */
7961       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
7962       vmslen = strlen(vmspath); /* We know we're truncating. */
7963       vmsptr = &vmsptr[vmslen];
7964       islnm = 0;
7965
7966       /* Now do we need to add the fake 6 zero directory to it? */
7967       add_6zero = 1;
7968       if ((*lastslash == '/') && (nextslash < lastslash)) {
7969         /* No there is another directory */
7970         add_6zero = 0;
7971       }
7972       else {
7973       int trnend;
7974       int cmp;
7975
7976         /* now we have foo:bar or foo:[000000]bar to decide from */
7977         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7978
7979         if (!islnm && !decc_posix_compliant_pathnames) {
7980
7981             cmp = strncmp("bin", vmspath, 4);
7982             if (cmp == 0) {
7983                 /* bin => SYS$SYSTEM: */
7984                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7985             }
7986             else {
7987                 /* tmp => SYS$SCRATCH: */
7988                 cmp = strncmp("tmp", vmspath, 4);
7989                 if (cmp == 0) {
7990                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7991                 }
7992             }
7993         }
7994
7995         trnend = islnm ? islnm - 1 : 0;
7996
7997         /* if this was a logical name, ']' or '>' must be present */
7998         /* if not a logical name, then assume a device and hope. */
7999         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8000
8001         /* if log name and trailing '.' then rooted - treat as device */
8002         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8003
8004         /* Fix me, if not a logical name, a device lookup should be
8005          * done to see if the device is file structured.  If the device
8006          * is not file structured, the 6 zeros should not be put on.
8007          *
8008          * As it is, perl is occasionally looking for dev:[000000]tty.
8009          * which looks a little strange.
8010          *
8011          * Not that easy to detect as "/dev" may be file structured with
8012          * special device files.
8013          */
8014
8015         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
8016             (&nextslash[1] == unixend)) {
8017           /* No real directory present */
8018           add_6zero = 1;
8019         }
8020       }
8021
8022       /* Put the device delimiter on */
8023       *vmsptr++ = ':';
8024       vmslen++;
8025       unixptr = nextslash;
8026       unixptr++;
8027
8028       /* Start directory if needed */
8029       if (!islnm || add_6zero) {
8030         *vmsptr++ = '[';
8031         vmslen++;
8032         dir_start = 1;
8033       }
8034
8035       /* add fake 000000] if needed */
8036       if (add_6zero) {
8037         *vmsptr++ = '0';
8038         *vmsptr++ = '0';
8039         *vmsptr++ = '0';
8040         *vmsptr++ = '0';
8041         *vmsptr++ = '0';
8042         *vmsptr++ = '0';
8043         *vmsptr++ = ']';
8044         vmslen += 7;
8045         dir_start = 0;
8046       }
8047
8048     } /* non-POSIX translation */
8049     PerlMem_free(esa);
8050   } /* End of relative/absolute path handling */
8051
8052   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8053     int dash_flag;
8054     int in_cnt;
8055     int out_cnt;
8056
8057     dash_flag = 0;
8058
8059     if (dir_start != 0) {
8060
8061       /* First characters in a directory are handled special */
8062       while ((*unixptr == '/') ||
8063              ((*unixptr == '.') &&
8064               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8065                 (&unixptr[1]==unixend)))) {
8066       int loop_flag;
8067
8068         loop_flag = 0;
8069
8070         /* Skip redundant / in specification */
8071         while ((*unixptr == '/') && (dir_start != 0)) {
8072           loop_flag = 1;
8073           unixptr++;
8074           if (unixptr == lastslash)
8075             break;
8076         }
8077         if (unixptr == lastslash)
8078           break;
8079
8080         /* Skip redundant ./ characters */
8081         while ((*unixptr == '.') &&
8082                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8083           loop_flag = 1;
8084           unixptr++;
8085           if (unixptr == lastslash)
8086             break;
8087           if (*unixptr == '/')
8088             unixptr++;
8089         }
8090         if (unixptr == lastslash)
8091           break;
8092
8093         /* Skip redundant ../ characters */
8094         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8095              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8096           /* Set the backing up flag */
8097           loop_flag = 1;
8098           dir_dot = 0;
8099           dash_flag = 1;
8100           *vmsptr++ = '-';
8101           vmslen++;
8102           unixptr++; /* first . */
8103           unixptr++; /* second . */
8104           if (unixptr == lastslash)
8105             break;
8106           if (*unixptr == '/') /* The slash */
8107             unixptr++;
8108         }
8109         if (unixptr == lastslash)
8110           break;
8111
8112         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8113         /* Not needed when VMS is pretending to be UNIX. */
8114
8115         /* Is this loop stuck because of too many dots? */
8116         if (loop_flag == 0) {
8117           /* Exit the loop and pass the rest through */
8118           break;
8119         }
8120       }
8121
8122       /* Are we done with directories yet? */
8123       if (unixptr >= lastslash) {
8124
8125         /* Watch out for trailing dots */
8126         if (dir_dot != 0) {
8127             vmslen --;
8128             vmsptr--;
8129         }
8130         *vmsptr++ = ']';
8131         vmslen++;
8132         dash_flag = 0;
8133         dir_start = 0;
8134         if (*unixptr == '/')
8135           unixptr++;
8136       }
8137       else {
8138         /* Have we stopped backing up? */
8139         if (dash_flag) {
8140           *vmsptr++ = '.';
8141           vmslen++;
8142           dash_flag = 0;
8143           /* dir_start continues to be = 1 */
8144         }
8145         if (*unixptr == '-') {
8146           *vmsptr++ = '^';
8147           *vmsptr++ = *unixptr++;
8148           vmslen += 2;
8149           dir_start = 0;
8150
8151           /* Now are we done with directories yet? */
8152           if (unixptr >= lastslash) {
8153
8154             /* Watch out for trailing dots */
8155             if (dir_dot != 0) {
8156               vmslen --;
8157               vmsptr--;
8158             }
8159
8160             *vmsptr++ = ']';
8161             vmslen++;
8162             dash_flag = 0;
8163             dir_start = 0;
8164           }
8165         }
8166       }
8167     }
8168
8169     /* All done? */
8170     if (unixptr >= unixend)
8171       break;
8172
8173     /* Normal characters - More EFS work probably needed */
8174     dir_start = 0;
8175     dir_dot = 0;
8176
8177     switch(*unixptr) {
8178     case '/':
8179         /* remove multiple / */
8180         while (unixptr[1] == '/') {
8181            unixptr++;
8182         }
8183         if (unixptr == lastslash) {
8184           /* Watch out for trailing dots */
8185           if (dir_dot != 0) {
8186             vmslen --;
8187             vmsptr--;
8188           }
8189           *vmsptr++ = ']';
8190         }
8191         else {
8192           dir_start = 1;
8193           *vmsptr++ = '.';
8194           dir_dot = 1;
8195
8196           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8197           /* Not needed when VMS is pretending to be UNIX. */
8198
8199         }
8200         dash_flag = 0;
8201         if (unixptr != unixend)
8202           unixptr++;
8203         vmslen++;
8204         break;
8205     case '.':
8206         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8207             (&unixptr[1] == unixend)) {
8208           *vmsptr++ = '^';
8209           *vmsptr++ = '.';
8210           vmslen += 2;
8211           unixptr++;
8212
8213           /* trailing dot ==> '^..' on VMS */
8214           if (unixptr == unixend) {
8215             *vmsptr++ = '.';
8216             vmslen++;
8217             unixptr++;
8218           }
8219           break;
8220         }
8221
8222         *vmsptr++ = *unixptr++;
8223         vmslen ++;
8224         break;
8225     case '"':
8226         if (quoted && (&unixptr[1] == unixend)) {
8227             unixptr++;
8228             break;
8229         }
8230         in_cnt = copy_expand_unix_filename_escape
8231                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8232         vmsptr += out_cnt;
8233         unixptr += in_cnt;
8234         break;
8235     case '~':
8236     case ';':
8237     case '\\':
8238     case '?':
8239     case ' ':
8240     default:
8241         in_cnt = copy_expand_unix_filename_escape
8242                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8243         vmsptr += out_cnt;
8244         unixptr += in_cnt;
8245         break;
8246     }
8247   }
8248
8249   /* Make sure directory is closed */
8250   if (unixptr == lastslash) {
8251     char *vmsptr2;
8252     vmsptr2 = vmsptr - 1;
8253
8254     if (*vmsptr2 != ']') {
8255       *vmsptr2--;
8256
8257       /* directories do not end in a dot bracket */
8258       if (*vmsptr2 == '.') {
8259         vmsptr2--;
8260
8261         /* ^. is allowed */
8262         if (*vmsptr2 != '^') {
8263           vmsptr--; /* back up over the dot */
8264         }
8265       }
8266       *vmsptr++ = ']';
8267     }
8268   }
8269   else {
8270     char *vmsptr2;
8271     /* Add a trailing dot if a file with no extension */
8272     vmsptr2 = vmsptr - 1;
8273     if ((vmslen > 1) &&
8274         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8275         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8276         *vmsptr++ = '.';
8277         vmslen++;
8278     }
8279   }
8280
8281   *vmsptr = '\0';
8282   return SS$_NORMAL;
8283 }
8284 #endif
8285
8286 /* A convenience macro for copying dots in filenames and escaping
8287  * them when they haven't already been escaped, with guards to
8288  * avoid checking before the start of the buffer or advancing
8289  * beyond the end of it (allowing room for the NUL terminator).
8290  */
8291 #define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
8292     if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8293           || ((vmsefsdot) == (vmsefsbuf))) \
8294          && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
8295        ) { \
8296         *((vmsefsdot)++) = '^'; \
8297     } \
8298     if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8299         *((vmsefsdot)++) = '.'; \
8300 } STMT_END
8301
8302 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8303 static char *
8304 int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag)
8305 {
8306   char *dirend;
8307   char *lastdot;
8308   char *cp1;
8309   const char *cp2;
8310   unsigned long int infront = 0, hasdir = 1;
8311   int rslt_len;
8312   int no_type_seen;
8313   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8314   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8315
8316   if (vms_debug_fileify) {
8317       if (path == NULL)
8318           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8319       else
8320           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8321   }
8322
8323   if (path == NULL) {
8324       /* If we fail, we should be setting errno */
8325       set_errno(EINVAL);
8326       set_vaxc_errno(SS$_BADPARAM);
8327       return NULL;
8328   }
8329   rslt_len = VMS_MAXRSS-1;
8330
8331   /* '.' and '..' are "[]" and "[-]" for a quick check */
8332   if (path[0] == '.') {
8333     if (path[1] == '\0') {
8334       strcpy(rslt,"[]");
8335       if (utf8_flag != NULL)
8336         *utf8_flag = 0;
8337       return rslt;
8338     }
8339     else {
8340       if (path[1] == '.' && path[2] == '\0') {
8341         strcpy(rslt,"[-]");
8342         if (utf8_flag != NULL)
8343            *utf8_flag = 0;
8344         return rslt;
8345       }
8346     }
8347   }
8348
8349    /* Posix specifications are now a native VMS format */
8350   /*--------------------------------------------------*/
8351 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8352   if (decc_posix_compliant_pathnames) {
8353     if (strncmp(path,"\"^UP^",5) == 0) {
8354       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8355       return rslt;
8356     }
8357   }
8358 #endif
8359
8360   /* This is really the only way to see if this is already in VMS format */
8361   sts = vms_split_path
8362        (path,
8363         &v_spec,
8364         &v_len,
8365         &r_spec,
8366         &r_len,
8367         &d_spec,
8368         &d_len,
8369         &n_spec,
8370         &n_len,
8371         &e_spec,
8372         &e_len,
8373         &vs_spec,
8374         &vs_len);
8375   if (sts == 0) {
8376     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8377        replacement, because the above parse just took care of most of
8378        what is needed to do vmspath when the specification is already
8379        in VMS format.
8380
8381        And if it is not already, it is easier to do the conversion as
8382        part of this routine than to call this routine and then work on
8383        the result.
8384      */
8385
8386     /* If VMS punctuation was found, it is already VMS format */
8387     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8388       if (utf8_flag != NULL)
8389         *utf8_flag = 0;
8390       my_strlcpy(rslt, path, VMS_MAXRSS);
8391       if (vms_debug_fileify) {
8392           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8393       }
8394       return rslt;
8395     }
8396     /* Now, what to do with trailing "." cases where there is no
8397        extension?  If this is a UNIX specification, and EFS characters
8398        are enabled, then the trailing "." should be converted to a "^.".
8399        But if this was already a VMS specification, then it should be
8400        left alone.
8401
8402        So in the case of ambiguity, leave the specification alone.
8403      */
8404
8405
8406     /* If there is a possibility of UTF8, then if any UTF8 characters
8407         are present, then they must be converted to VTF-7
8408      */
8409     if (utf8_flag != NULL)
8410       *utf8_flag = 0;
8411     my_strlcpy(rslt, path, VMS_MAXRSS);
8412     if (vms_debug_fileify) {
8413         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8414     }
8415     return rslt;
8416   }
8417
8418   dirend = strrchr(path,'/');
8419
8420   if (dirend == NULL) {
8421      /* If we get here with no Unix directory delimiters, then this is an
8422       * ambiguous file specification, such as a Unix glob specification, a
8423       * shell or make macro, or a filespec that would be valid except for
8424       * unescaped extended characters.  The safest thing if it's a macro
8425       * is to pass it through as-is.
8426       */
8427       if (strstr(path, "$(")) {
8428           my_strlcpy(rslt, path, VMS_MAXRSS);
8429           if (vms_debug_fileify) {
8430               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8431           }
8432           return rslt;
8433       }
8434       hasdir = 0;
8435   }
8436   else if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8437     if (!*(dirend+2)) dirend +=2;
8438     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8439     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8440   }
8441
8442   cp1 = rslt;
8443   cp2 = path;
8444   lastdot = strrchr(cp2,'.');
8445   if (*cp2 == '/') {
8446     char *trndev;
8447     int islnm, rooted;
8448     STRLEN trnend;
8449
8450     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8451     if (!*(cp2+1)) {
8452       if (decc_disable_posix_root) {
8453         strcpy(rslt,"sys$disk:[000000]");
8454       }
8455       else {
8456         strcpy(rslt,"sys$posix_root:[000000]");
8457       }
8458       if (utf8_flag != NULL)
8459         *utf8_flag = 0;
8460       if (vms_debug_fileify) {
8461           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8462       }
8463       return rslt;
8464     }
8465     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8466     *cp1 = '\0';
8467     trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8468     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8469     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8470
8471      /* DECC special handling */
8472     if (!islnm) {
8473       if (strcmp(rslt,"bin") == 0) {
8474         strcpy(rslt,"sys$system");
8475         cp1 = rslt + 10;
8476         *cp1 = 0;
8477         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8478       }
8479       else if (strcmp(rslt,"tmp") == 0) {
8480         strcpy(rslt,"sys$scratch");
8481         cp1 = rslt + 11;
8482         *cp1 = 0;
8483         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8484       }
8485       else if (!decc_disable_posix_root) {
8486         strcpy(rslt, "sys$posix_root");
8487         cp1 = rslt + 14;
8488         *cp1 = 0;
8489         cp2 = path;
8490         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8491         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8492       }
8493       else if (strcmp(rslt,"dev") == 0) {
8494         if (strncmp(cp2,"/null", 5) == 0) {
8495           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8496             strcpy(rslt,"NLA0");
8497             cp1 = rslt + 4;
8498             *cp1 = 0;
8499             cp2 = cp2 + 5;
8500             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8501           }
8502         }
8503       }
8504     }
8505
8506     trnend = islnm ? strlen(trndev) - 1 : 0;
8507     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8508     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8509     /* If the first element of the path is a logical name, determine
8510      * whether it has to be translated so we can add more directories. */
8511     if (!islnm || rooted) {
8512       *(cp1++) = ':';
8513       *(cp1++) = '[';
8514       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8515       else cp2++;
8516     }
8517     else {
8518       if (cp2 != dirend) {
8519         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8520         cp1 = rslt + trnend;
8521         if (*cp2 != 0) {
8522           *(cp1++) = '.';
8523           cp2++;
8524         }
8525       }
8526       else {
8527         if (decc_disable_posix_root) {
8528           *(cp1++) = ':';
8529           hasdir = 0;
8530         }
8531       }
8532     }
8533     PerlMem_free(trndev);
8534   }
8535   else if (hasdir) {
8536     *(cp1++) = '[';
8537     if (*cp2 == '.') {
8538       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8539         cp2 += 2;         /* skip over "./" - it's redundant */
8540         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8541       }
8542       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8543         *(cp1++) = '-';                                 /* "../" --> "-" */
8544         cp2 += 3;
8545       }
8546       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8547                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8548         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8549         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8550         cp2 += 4;
8551       }
8552       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8553         /* Escape the extra dots in EFS file specifications */
8554         *(cp1++) = '^';
8555       }
8556       if (cp2 > dirend) cp2 = dirend;
8557     }
8558     else *(cp1++) = '.';
8559   }
8560   for (; cp2 < dirend; cp2++) {
8561     if (*cp2 == '/') {
8562       if (*(cp2-1) == '/') continue;
8563       if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
8564       infront = 0;
8565     }
8566     else if (!infront && *cp2 == '.') {
8567       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8568       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8569       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8570         if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
8571         else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
8572         else {
8573           *(cp1++) = '-';
8574         }
8575         cp2 += 2;
8576         if (cp2 == dirend) break;
8577       }
8578       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8579                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8580         if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8581         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8582         if (!*(cp2+3)) {
8583           *(cp1++) = '.';  /* Simulate trailing '/' */
8584           cp2 += 2;  /* for loop will incr this to == dirend */
8585         }
8586         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8587       }
8588       else {
8589         if (decc_efs_charset == 0) {
8590           if (cp1 > rslt && *(cp1-1) == '^')
8591             cp1--;         /* remove the escape, if any */
8592           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8593         }
8594         else {
8595           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8596         }
8597       }
8598     }
8599     else {
8600       if (!infront && cp1 > rslt && *(cp1-1) == '-')  *(cp1++) = '.';
8601       if (*cp2 == '.') {
8602         if (decc_efs_charset == 0) {
8603           if (cp1 > rslt && *(cp1-1) == '^')
8604             cp1--;         /* remove the escape, if any */
8605           *(cp1++) = '_';
8606         }
8607         else {
8608           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8609         }
8610       }
8611       else {
8612         int out_cnt;
8613         cp2 += copy_expand_unix_filename_escape(cp1, cp2, &out_cnt, utf8_flag);
8614         cp2--; /* we're in a loop that will increment this */
8615         cp1 += out_cnt;
8616       }
8617       infront = 1;
8618     }
8619   }
8620   if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8621   if (hasdir) *(cp1++) = ']';
8622   if (*cp2 && *cp2 == '/') cp2++;  /* check in case we ended with trailing '/' */
8623   no_type_seen = 0;
8624   if (cp2 > lastdot)
8625     no_type_seen = 1;
8626   while (*cp2) {
8627     switch(*cp2) {
8628     case '?':
8629         if (decc_efs_charset == 0)
8630           *(cp1++) = '%';
8631         else
8632           *(cp1++) = '?';
8633         cp2++;
8634     case ' ':
8635         if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
8636             *(cp1)++ = '^';
8637         *(cp1)++ = '_';
8638         cp2++;
8639         break;
8640     case '.':
8641         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8642             decc_readdir_dropdotnotype) {
8643           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8644           cp2++;
8645
8646           /* trailing dot ==> '^..' on VMS */
8647           if (*cp2 == '\0') {
8648             *(cp1++) = '.';
8649             no_type_seen = 0;
8650           }
8651         }
8652         else {
8653           *(cp1++) = *(cp2++);
8654           no_type_seen = 0;
8655         }
8656         break;
8657     case '$':
8658          /* This could be a macro to be passed through */
8659         *(cp1++) = *(cp2++);
8660         if (*cp2 == '(') {
8661         const char * save_cp2;
8662         char * save_cp1;
8663         int is_macro;
8664
8665             /* paranoid check */
8666             save_cp2 = cp2;
8667             save_cp1 = cp1;
8668             is_macro = 0;
8669
8670             /* Test through */
8671             *(cp1++) = *(cp2++);
8672             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8673                 *(cp1++) = *(cp2++);
8674                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8675                     *(cp1++) = *(cp2++);
8676                 }
8677                 if (*cp2 == ')') {
8678                     *(cp1++) = *(cp2++);
8679                     is_macro = 1;
8680                 }
8681             }
8682             if (is_macro == 0) {
8683                 /* Not really a macro - never mind */
8684                 cp2 = save_cp2;
8685                 cp1 = save_cp1;
8686             }
8687         }
8688         break;
8689     case '\"':
8690     case '~':
8691     case '`':
8692     case '!':
8693     case '#':
8694     case '%':
8695     case '^':
8696         /* Don't escape again if following character is
8697          * already something we escape.
8698          */
8699         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8700             *(cp1++) = *(cp2++);
8701             break;
8702         }
8703         /* But otherwise fall through and escape it. */
8704     case '&':
8705     case '(':
8706     case ')':
8707     case '=':
8708     case '+':
8709     case '\'':
8710     case '@':
8711     case '[':
8712     case ']':
8713     case '{':
8714     case '}':
8715     case ':':
8716     case '\\':
8717     case '|':
8718     case '<':
8719     case '>':
8720         if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */
8721             *(cp1++) = '^';
8722         *(cp1++) = *(cp2++);
8723         break;
8724     case ';':
8725         /* If it doesn't look like the beginning of a version number,
8726          * or we've been promised there are no version numbers, then
8727          * escape it.
8728          */
8729         if (decc_filename_unix_no_version) {
8730           *(cp1++) = '^';
8731         }
8732         else {
8733           size_t all_nums = strspn(cp2+1, "0123456789");
8734           if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0')
8735             *(cp1++) = '^';
8736         }
8737         *(cp1++) = *(cp2++);
8738         break;
8739     default:
8740         *(cp1++) = *(cp2++);
8741     }
8742   }
8743   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8744   char *lcp1;
8745     lcp1 = cp1;
8746     lcp1--;
8747      /* Fix me for "^]", but that requires making sure that you do
8748       * not back up past the start of the filename
8749       */
8750     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8751       *cp1++ = '.';
8752   }
8753   *cp1 = '\0';
8754
8755   if (utf8_flag != NULL)
8756     *utf8_flag = 0;
8757   if (vms_debug_fileify) {
8758       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8759   }
8760   return rslt;
8761
8762 }  /* end of int_tovmsspec() */
8763
8764
8765 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8766 static char *
8767 mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag)
8768 {
8769     static char __tovmsspec_retbuf[VMS_MAXRSS];
8770     char * vmsspec, *ret_spec, *ret_buf;
8771
8772     vmsspec = NULL;
8773     ret_buf = buf;
8774     if (ret_buf == NULL) {
8775         if (ts) {
8776             Newx(vmsspec, VMS_MAXRSS, char);
8777             if (vmsspec == NULL)
8778                 _ckvmssts(SS$_INSFMEM);
8779             ret_buf = vmsspec;
8780         } else {
8781             ret_buf = __tovmsspec_retbuf;
8782         }
8783     }
8784
8785     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8786
8787     if (ret_spec == NULL) {
8788        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8789        if (vmsspec)
8790            Safefree(vmsspec);
8791     }
8792
8793     return ret_spec;
8794
8795 }  /* end of mp_do_tovmsspec() */
8796 /*}}}*/
8797 /* External entry points */
8798 char *
8799 Perl_tovmsspec(pTHX_ const char *path, char *buf)
8800 {
8801     return do_tovmsspec(path, buf, 0, NULL);
8802 }
8803
8804 char *
8805 Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8806 {
8807     return do_tovmsspec(path, buf, 1, NULL);
8808 }
8809
8810 char *
8811 Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8812 {
8813     return do_tovmsspec(path, buf, 0, utf8_fl);
8814 }
8815
8816 char *
8817 Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8818 {
8819     return do_tovmsspec(path, buf, 1, utf8_fl);
8820 }
8821
8822 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8823 /* Internal routine for use with out an explicit context present */
8824 static char *
8825 int_tovmspath(const char *path, char *buf, int * utf8_fl)
8826 {
8827     char * ret_spec, *pathified;
8828
8829     if (path == NULL)
8830         return NULL;
8831
8832     pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8833     if (pathified == NULL)
8834         _ckvmssts_noperl(SS$_INSFMEM);
8835
8836     ret_spec = int_pathify_dirspec(path, pathified);
8837
8838     if (ret_spec == NULL) {
8839         PerlMem_free(pathified);
8840         return NULL;
8841     }
8842
8843     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8844
8845     PerlMem_free(pathified);
8846     return ret_spec;
8847
8848 }
8849
8850 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8851 static char *
8852 mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
8853 {
8854   static char __tovmspath_retbuf[VMS_MAXRSS];
8855   int vmslen;
8856   char *pathified, *vmsified, *cp;
8857
8858   if (path == NULL) return NULL;
8859   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8860   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8861   if (int_pathify_dirspec(path, pathified) == NULL) {
8862     PerlMem_free(pathified);
8863     return NULL;
8864   }
8865
8866   vmsified = NULL;
8867   if (buf == NULL)
8868      Newx(vmsified, VMS_MAXRSS, char);
8869   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8870     PerlMem_free(pathified);
8871     if (vmsified) Safefree(vmsified);
8872     return NULL;
8873   }
8874   PerlMem_free(pathified);
8875   if (buf) {
8876     return buf;
8877   }
8878   else if (ts) {
8879     vmslen = strlen(vmsified);
8880     Newx(cp,vmslen+1,char);
8881     memcpy(cp,vmsified,vmslen);
8882     cp[vmslen] = '\0';
8883     Safefree(vmsified);
8884     return cp;
8885   }
8886   else {
8887     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8888     Safefree(vmsified);
8889     return __tovmspath_retbuf;
8890   }
8891
8892 }  /* end of do_tovmspath() */
8893 /*}}}*/
8894 /* External entry points */
8895 char *
8896 Perl_tovmspath(pTHX_ const char *path, char *buf)
8897 {
8898     return do_tovmspath(path, buf, 0, NULL);
8899 }
8900
8901 char *
8902 Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8903 {
8904     return do_tovmspath(path, buf, 1, NULL);
8905 }
8906
8907 char *
8908 Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8909 {
8910     return do_tovmspath(path, buf, 0, utf8_fl);
8911 }
8912
8913 char *
8914 Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8915 {
8916     return do_tovmspath(path, buf, 1, utf8_fl);
8917 }
8918
8919
8920 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8921 static char *
8922 mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
8923 {
8924   static char __tounixpath_retbuf[VMS_MAXRSS];
8925   int unixlen;
8926   char *pathified, *unixified, *cp;
8927
8928   if (path == NULL) return NULL;
8929   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8930   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8931   if (int_pathify_dirspec(path, pathified) == NULL) {
8932     PerlMem_free(pathified);
8933     return NULL;
8934   }
8935
8936   unixified = NULL;
8937   if (buf == NULL) {
8938       Newx(unixified, VMS_MAXRSS, char);
8939   }
8940   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8941     PerlMem_free(pathified);
8942     if (unixified) Safefree(unixified);
8943     return NULL;
8944   }
8945   PerlMem_free(pathified);
8946   if (buf) {
8947     return buf;
8948   }
8949   else if (ts) {
8950     unixlen = strlen(unixified);
8951     Newx(cp,unixlen+1,char);
8952     memcpy(cp,unixified,unixlen);
8953     cp[unixlen] = '\0';
8954     Safefree(unixified);
8955     return cp;
8956   }
8957   else {
8958     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
8959     Safefree(unixified);
8960     return __tounixpath_retbuf;
8961   }
8962
8963 }  /* end of do_tounixpath() */
8964 /*}}}*/
8965 /* External entry points */
8966 char *
8967 Perl_tounixpath(pTHX_ const char *path, char *buf)
8968 {
8969     return do_tounixpath(path, buf, 0, NULL);
8970 }
8971
8972 char *
8973 Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8974 {
8975     return do_tounixpath(path, buf, 1, NULL);
8976 }
8977
8978 char *
8979 Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8980 {
8981     return do_tounixpath(path, buf, 0, utf8_fl);
8982 }
8983
8984 char *
8985 Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8986 {
8987     return do_tounixpath(path, buf, 1, utf8_fl);
8988 }
8989
8990 /*
8991  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8992  *
8993  *****************************************************************************
8994  *                                                                           *
8995  *  Copyright (C) 1989-1994, 2007 by                                         *
8996  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8997  *                                                                           *
8998  *  Permission is hereby granted for the reproduction of this software       *
8999  *  on condition that this copyright notice is included in source            *
9000  *  distributions of the software.  The code may be modified and             *
9001  *  distributed under the same terms as Perl itself.                         *
9002  *                                                                           *
9003  *  27-Aug-1994 Modified for inclusion in perl5                              *
9004  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9005  *****************************************************************************
9006  */
9007
9008 /*
9009  * getredirection() is intended to aid in porting C programs
9010  * to VMS (Vax-11 C).  The native VMS environment does not support
9011  * '>' and '<' I/O redirection, or command line wild card expansion,
9012  * or a command line pipe mechanism using the '|' AND background
9013  * command execution '&'.  All of these capabilities are provided to any
9014  * C program which calls this procedure as the first thing in the
9015  * main program.
9016  * The piping mechanism will probably work with almost any 'filter' type
9017  * of program.  With suitable modification, it may useful for other
9018  * portability problems as well.
9019  *
9020  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9021  */
9022 struct list_item
9023     {
9024     struct list_item *next;
9025     char *value;
9026     };
9027
9028 static void add_item(struct list_item **head,
9029                      struct list_item **tail,
9030                      char *value,
9031                      int *count);
9032
9033 static void mp_expand_wild_cards(pTHX_ char *item,
9034                                 struct list_item **head,
9035                                 struct list_item **tail,
9036                                 int *count);
9037
9038 static int background_process(pTHX_ int argc, char **argv);
9039
9040 static void pipe_and_fork(pTHX_ char **cmargv);
9041
9042 /*{{{ void getredirection(int *ac, char ***av)*/
9043 static void
9044 mp_getredirection(pTHX_ int *ac, char ***av)
9045 /*
9046  * Process vms redirection arg's.  Exit if any error is seen.
9047  * If getredirection() processes an argument, it is erased
9048  * from the vector.  getredirection() returns a new argc and argv value.
9049  * In the event that a background command is requested (by a trailing "&"),
9050  * this routine creates a background subprocess, and simply exits the program.
9051  *
9052  * Warning: do not try to simplify the code for vms.  The code
9053  * presupposes that getredirection() is called before any data is
9054  * read from stdin or written to stdout.
9055  *
9056  * Normal usage is as follows:
9057  *
9058  *      main(argc, argv)
9059  *      int             argc;
9060  *      char            *argv[];
9061  *      {
9062  *              getredirection(&argc, &argv);
9063  *      }
9064  */
9065 {
9066     int                 argc = *ac;     /* Argument Count         */
9067     char                **argv = *av;   /* Argument Vector        */
9068     char                *ap;            /* Argument pointer       */
9069     int                 j;              /* argv[] index           */
9070     int                 item_count = 0; /* Count of Items in List */
9071     struct list_item    *list_head = 0; /* First Item in List       */
9072     struct list_item    *list_tail;     /* Last Item in List        */
9073     char                *in = NULL;     /* Input File Name          */
9074     char                *out = NULL;    /* Output File Name         */
9075     char                *outmode = "w"; /* Mode to Open Output File */
9076     char                *err = NULL;    /* Error File Name          */
9077     char                *errmode = "w"; /* Mode to Open Error File  */
9078     int                 cmargc = 0;     /* Piped Command Arg Count  */
9079     char                **cmargv = NULL;/* Piped Command Arg Vector */
9080
9081     /*
9082      * First handle the case where the last thing on the line ends with
9083      * a '&'.  This indicates the desire for the command to be run in a
9084      * subprocess, so we satisfy that desire.
9085      */
9086     ap = argv[argc-1];
9087     if (0 == strcmp("&", ap))
9088        exit(background_process(aTHX_ --argc, argv));
9089     if (*ap && '&' == ap[strlen(ap)-1])
9090         {
9091         ap[strlen(ap)-1] = '\0';
9092        exit(background_process(aTHX_ argc, argv));
9093         }
9094     /*
9095      * Now we handle the general redirection cases that involve '>', '>>',
9096      * '<', and pipes '|'.
9097      */
9098     for (j = 0; j < argc; ++j)
9099         {
9100         if (0 == strcmp("<", argv[j]))
9101             {
9102             if (j+1 >= argc)
9103                 {
9104                 fprintf(stderr,"No input file after < on command line");
9105                 exit(LIB$_WRONUMARG);
9106                 }
9107             in = argv[++j];
9108             continue;
9109             }
9110         if ('<' == *(ap = argv[j]))
9111             {
9112             in = 1 + ap;
9113             continue;
9114             }
9115         if (0 == strcmp(">", ap))
9116             {
9117             if (j+1 >= argc)
9118                 {
9119                 fprintf(stderr,"No output file after > on command line");
9120                 exit(LIB$_WRONUMARG);
9121                 }
9122             out = argv[++j];
9123             continue;
9124             }
9125         if ('>' == *ap)
9126             {
9127             if ('>' == ap[1])
9128                 {
9129                 outmode = "a";
9130                 if ('\0' == ap[2])
9131                     out = argv[++j];
9132                 else
9133                     out = 2 + ap;
9134                 }
9135             else
9136                 out = 1 + ap;
9137             if (j >= argc)
9138                 {
9139                 fprintf(stderr,"No output file after > or >> on command line");
9140                 exit(LIB$_WRONUMARG);
9141                 }
9142             continue;
9143             }
9144         if (('2' == *ap) && ('>' == ap[1]))
9145             {
9146             if ('>' == ap[2])
9147                 {
9148                 errmode = "a";
9149                 if ('\0' == ap[3])
9150                     err = argv[++j];
9151                 else
9152                     err = 3 + ap;
9153                 }
9154             else
9155                 if ('\0' == ap[2])
9156                     err = argv[++j];
9157                 else
9158                     err = 2 + ap;
9159             if (j >= argc)
9160                 {
9161                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9162                 exit(LIB$_WRONUMARG);
9163                 }
9164             continue;
9165             }
9166         if (0 == strcmp("|", argv[j]))
9167             {
9168             if (j+1 >= argc)
9169                 {
9170                 fprintf(stderr,"No command into which to pipe on command line");
9171                 exit(LIB$_WRONUMARG);
9172                 }
9173             cmargc = argc-(j+1);
9174             cmargv = &argv[j+1];
9175             argc = j;
9176             continue;
9177             }
9178         if ('|' == *(ap = argv[j]))
9179             {
9180             ++argv[j];
9181             cmargc = argc-j;
9182             cmargv = &argv[j];
9183             argc = j;
9184             continue;
9185             }
9186         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9187         }
9188     /*
9189      * Allocate and fill in the new argument vector, Some Unix's terminate
9190      * the list with an extra null pointer.
9191      */
9192     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9193     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9194     *av = argv;
9195     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9196         argv[j] = list_head->value;
9197     *ac = item_count;
9198     if (cmargv != NULL)
9199         {
9200         if (out != NULL)
9201             {
9202             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9203             exit(LIB$_INVARGORD);
9204             }
9205         pipe_and_fork(aTHX_ cmargv);
9206         }
9207
9208     /* Check for input from a pipe (mailbox) */
9209
9210     if (in == NULL && 1 == isapipe(0))
9211         {
9212         char mbxname[L_tmpnam];
9213         long int bufsize;
9214         long int dvi_item = DVI$_DEVBUFSIZ;
9215         $DESCRIPTOR(mbxnam, "");
9216         $DESCRIPTOR(mbxdevnam, "");
9217
9218         /* Input from a pipe, reopen it in binary mode to disable       */
9219         /* carriage control processing.                                 */
9220
9221         fgetname(stdin, mbxname, 1);
9222         mbxnam.dsc$a_pointer = mbxname;
9223         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9224         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9225         mbxdevnam.dsc$a_pointer = mbxname;
9226         mbxdevnam.dsc$w_length = sizeof(mbxname);
9227         dvi_item = DVI$_DEVNAM;
9228         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9229         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9230         set_errno(0);
9231         set_vaxc_errno(1);
9232         freopen(mbxname, "rb", stdin);
9233         if (errno != 0)
9234             {
9235             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9236             exit(vaxc$errno);
9237             }
9238         }
9239     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9240         {
9241         fprintf(stderr,"Can't open input file %s as stdin",in);
9242         exit(vaxc$errno);
9243         }
9244     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9245         {
9246         fprintf(stderr,"Can't open output file %s as stdout",out);
9247         exit(vaxc$errno);
9248         }
9249         if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
9250
9251     if (err != NULL) {
9252         if (strcmp(err,"&1") == 0) {
9253             dup2(fileno(stdout), fileno(stderr));
9254             vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
9255         } else {
9256         FILE *tmperr;
9257         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9258             {
9259             fprintf(stderr,"Can't open error file %s as stderr",err);
9260             exit(vaxc$errno);
9261             }
9262             fclose(tmperr);
9263            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9264                 {
9265                 exit(vaxc$errno);
9266                 }
9267             vmssetuserlnm("SYS$ERROR", err);
9268         }
9269         }
9270 #ifdef ARGPROC_DEBUG
9271     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9272     for (j = 0; j < *ac;  ++j)
9273         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9274 #endif
9275    /* Clear errors we may have hit expanding wildcards, so they don't
9276       show up in Perl's $! later */
9277    set_errno(0); set_vaxc_errno(1);
9278 }  /* end of getredirection() */
9279 /*}}}*/
9280
9281 static void
9282 add_item(struct list_item **head, struct list_item **tail, char *value, int *count)
9283 {
9284     if (*head == 0)
9285         {
9286         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9287         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9288         *tail = *head;
9289         }
9290     else {
9291         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9292         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9293         *tail = (*tail)->next;
9294         }
9295     (*tail)->value = value;
9296     ++(*count);
9297 }
9298
9299 static void
9300 mp_expand_wild_cards(pTHX_ char *item, struct list_item **head,
9301                      struct list_item **tail, int *count)
9302 {
9303     int expcount = 0;
9304     unsigned long int context = 0;
9305     int isunix = 0;
9306     int item_len = 0;
9307     char *had_version;
9308     char *had_device;
9309     int had_directory;
9310     char *devdir,*cp;
9311     char *vmsspec;
9312     $DESCRIPTOR(filespec, "");
9313     $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9314     $DESCRIPTOR(resultspec, "");
9315     unsigned long int lff_flags = 0;
9316     int sts;
9317     int rms_sts;
9318
9319 #ifdef VMS_LONGNAME_SUPPORT
9320     lff_flags = LIB$M_FIL_LONG_NAMES;
9321 #endif
9322
9323     for (cp = item; *cp; cp++) {
9324         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9325         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9326     }
9327     if (!*cp || isspace(*cp))
9328         {
9329         add_item(head, tail, item, count);
9330         return;
9331         }
9332     else
9333         {
9334      /* "double quoted" wild card expressions pass as is */
9335      /* From DCL that means using e.g.:                  */
9336      /* perl program """perl.*"""                        */
9337      item_len = strlen(item);
9338      if ( '"' == *item && '"' == item[item_len-1] )
9339        {
9340        item++;
9341        item[item_len-2] = '\0';
9342        add_item(head, tail, item, count);
9343        return;
9344        }
9345      }
9346     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9347     resultspec.dsc$b_class = DSC$K_CLASS_D;
9348     resultspec.dsc$a_pointer = NULL;
9349     vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9350     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9351     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9352       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9353     if (!isunix || !filespec.dsc$a_pointer)
9354       filespec.dsc$a_pointer = item;
9355     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9356     /*
9357      * Only return version specs, if the caller specified a version
9358      */
9359     had_version = strchr(item, ';');
9360     /*
9361      * Only return device and directory specs, if the caller specified either.
9362      */
9363     had_device = strchr(item, ':');
9364     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9365
9366     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9367                                  (&filespec, &resultspec, &context,
9368                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9369         {
9370         char *string;
9371         char *c;
9372
9373         string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9374         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9375         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9376         if (NULL == had_version)
9377             *(strrchr(string, ';')) = '\0';
9378         if ((!had_directory) && (had_device == NULL))
9379             {
9380             if (NULL == (devdir = strrchr(string, ']')))
9381                 devdir = strrchr(string, '>');
9382             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9383             }
9384         /*
9385          * Be consistent with what the C RTL has already done to the rest of
9386          * the argv items and lowercase all of these names.
9387          */
9388         if (!decc_efs_case_preserve) {
9389             for (c = string; *c; ++c)
9390             if (isupper(*c))
9391                 *c = tolower(*c);
9392         }
9393         if (isunix) trim_unixpath(string,item,1);
9394         add_item(head, tail, string, count);
9395         ++expcount;
9396     }
9397     PerlMem_free(vmsspec);
9398     if (sts != RMS$_NMF)
9399         {
9400         set_vaxc_errno(sts);
9401         switch (sts)
9402             {
9403             case RMS$_FNF: case RMS$_DNF:
9404                 set_errno(ENOENT); break;
9405             case RMS$_DIR:
9406                 set_errno(ENOTDIR); break;
9407             case RMS$_DEV:
9408                 set_errno(ENODEV); break;
9409             case RMS$_FNM: case RMS$_SYN:
9410                 set_errno(EINVAL); break;
9411             case RMS$_PRV:
9412                 set_errno(EACCES); break;
9413             default:
9414                 _ckvmssts_noperl(sts);
9415             }
9416         }
9417     if (expcount == 0)
9418         add_item(head, tail, item, count);
9419     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9420     _ckvmssts_noperl(lib$find_file_end(&context));
9421 }
9422
9423
9424 static void
9425 pipe_and_fork(pTHX_ char **cmargv)
9426 {
9427     PerlIO *fp;
9428     struct dsc$descriptor_s *vmscmd;
9429     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9430     int sts, j, l, ismcr, quote, tquote = 0;
9431
9432     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9433     vms_execfree(vmscmd);
9434
9435     j = l = 0;
9436     p = subcmd;
9437     q = cmargv[0];
9438     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9439               && toupper(*(q+2)) == 'R' && !*(q+3);
9440
9441     while (q && l < MAX_DCL_LINE_LENGTH) {
9442         if (!*q) {
9443             if (j > 0 && quote) {
9444                 *p++ = '"';
9445                 l++;
9446             }
9447             q = cmargv[++j];
9448             if (q) {
9449                 if (ismcr && j > 1) quote = 1;
9450                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9451                 *p++ = ' ';
9452                 l++;
9453                 if (quote || tquote) {
9454                     *p++ = '"';
9455                     l++;
9456                 }
9457             }
9458         } else {
9459             if ((quote||tquote) && *q == '"') {
9460                 *p++ = '"';
9461                 l++;
9462             }
9463             *p++ = *q++;
9464             l++;
9465         }
9466     }
9467     *p = '\0';
9468
9469     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9470     if (fp == NULL) {
9471         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9472     }
9473 }
9474
9475 static int
9476 background_process(pTHX_ int argc, char **argv)
9477 {
9478     char command[MAX_DCL_SYMBOL + 1] = "$";
9479     $DESCRIPTOR(value, "");
9480     static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9481     static $DESCRIPTOR(null, "NLA0:");
9482     static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9483     char pidstring[80];
9484     $DESCRIPTOR(pidstr, "");
9485     int pid;
9486     unsigned long int flags = 17, one = 1, retsts;
9487     int len;
9488
9489     len = my_strlcat(command, argv[0], sizeof(command));
9490     while (--argc && (len < MAX_DCL_SYMBOL))
9491         {
9492         my_strlcat(command, " \"", sizeof(command));
9493         my_strlcat(command, *(++argv), sizeof(command));
9494         len = my_strlcat(command, "\"", sizeof(command));
9495         }
9496     value.dsc$a_pointer = command;
9497     value.dsc$w_length = strlen(value.dsc$a_pointer);
9498     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9499     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9500     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9501         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9502     }
9503     else {
9504         _ckvmssts_noperl(retsts);
9505     }
9506 #ifdef ARGPROC_DEBUG
9507     PerlIO_printf(Perl_debug_log, "%s\n", command);
9508 #endif
9509     sprintf(pidstring, "%08X", pid);
9510     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9511     pidstr.dsc$a_pointer = pidstring;
9512     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9513     lib$set_symbol(&pidsymbol, &pidstr);
9514     return(SS$_NORMAL);
9515 }
9516 /*}}}*/
9517 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9518
9519
9520 /* OS-specific initialization at image activation (not thread startup) */
9521 /* Older VAXC header files lack these constants */
9522 #ifndef JPI$_RIGHTS_SIZE
9523 #  define JPI$_RIGHTS_SIZE 817
9524 #endif
9525 #ifndef KGB$M_SUBSYSTEM
9526 #  define KGB$M_SUBSYSTEM 0x8
9527 #endif
9528
9529 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9530
9531 /*{{{void vms_image_init(int *, char ***)*/
9532 void
9533 vms_image_init(int *argcp, char ***argvp)
9534 {
9535   int status;
9536   char eqv[LNM$C_NAMLENGTH+1] = "";
9537   unsigned int len, tabct = 8, tabidx = 0;
9538   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9539   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9540   unsigned short int dummy, rlen;
9541   struct dsc$descriptor_s **tabvec;
9542 #if defined(PERL_IMPLICIT_CONTEXT)
9543   pTHX = NULL;
9544 #endif
9545   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9546                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9547                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9548                                  {          0,                0,    0,      0} };
9549
9550 #ifdef KILL_BY_SIGPRC
9551     Perl_csighandler_init();
9552 #endif
9553
9554 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9555     /* This was moved from the pre-image init handler because on threaded */
9556     /* Perl it was always returning 0 for the default value. */
9557     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9558     if (status > 0) {
9559         int s;
9560         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9561         if (s > 0) {
9562             int initial;
9563             initial = decc$feature_get_value(s, 4);
9564             if (initial > 0) {
9565                 /* initial is: 0 if nothing has set the feature */
9566                 /*            -1 if initialized to default */
9567                 /*             1 if set by logical name */
9568                 /*             2 if set by decc$feature_set_value */
9569                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9570
9571                 /* If the value is not valid, force the feature off */
9572                 if (decc_disable_posix_root < 0) {
9573                     decc$feature_set_value(s, 1, 1);
9574                     decc_disable_posix_root = 1;
9575                 }
9576             }
9577             else {
9578                 /* Nothing has asked for it explicitly, so use our own default. */
9579                 decc_disable_posix_root = 1;
9580                 decc$feature_set_value(s, 1, 1);
9581             }
9582         }
9583     }
9584 #endif
9585
9586   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9587   _ckvmssts_noperl(iosb[0]);
9588   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9589     if (iprv[i]) {           /* Running image installed with privs? */
9590       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9591       will_taint = TRUE;
9592       break;
9593     }
9594   }
9595   /* Rights identifiers might trigger tainting as well. */
9596   if (!will_taint && (rlen || rsz)) {
9597     while (rlen < rsz) {
9598       /* We didn't get all the identifiers on the first pass.  Allocate a
9599        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9600        * were needed to hold all identifiers at time of last call; we'll
9601        * allocate that many unsigned long ints), and go back and get 'em.
9602        * If it gave us less than it wanted to despite ample buffer space,
9603        * something's broken.  Is your system missing a system identifier?
9604        */
9605       if (rsz <= jpilist[1].buflen) {
9606          /* Perl_croak accvios when used this early in startup. */
9607          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9608                          rsz, (unsigned long) jpilist[1].buflen,
9609                          "Check your rights database for corruption.\n");
9610          exit(SS$_ABORT);
9611       }
9612       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9613       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9614       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9615       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9616       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9617       _ckvmssts_noperl(iosb[0]);
9618     }
9619     mask = (unsigned long int *)jpilist[1].bufadr;
9620     /* Check attribute flags for each identifier (2nd longword); protected
9621      * subsystem identifiers trigger tainting.
9622      */
9623     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9624       if (mask[i] & KGB$M_SUBSYSTEM) {
9625         will_taint = TRUE;
9626         break;
9627       }
9628     }
9629     if (mask != rlst) PerlMem_free(mask);
9630   }
9631
9632   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9633    * logical, some versions of the CRTL will add a phanthom /000000/
9634    * directory.  This needs to be removed.
9635    */
9636   if (decc_filename_unix_report) {
9637     char * zeros;
9638     int ulen;
9639     ulen = strlen(argvp[0][0]);
9640     if (ulen > 7) {
9641       zeros = strstr(argvp[0][0], "/000000/");
9642       if (zeros != NULL) {
9643         int mlen;
9644         mlen = ulen - (zeros - argvp[0][0]) - 7;
9645         memmove(zeros, &zeros[7], mlen);
9646         ulen = ulen - 7;
9647         argvp[0][0][ulen] = '\0';
9648       }
9649     }
9650     /* It also may have a trailing dot that needs to be removed otherwise
9651      * it will be converted to VMS mode incorrectly.
9652      */
9653     ulen--;
9654     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9655       argvp[0][0][ulen] = '\0';
9656   }
9657
9658   /* We need to use this hack to tell Perl it should run with tainting,
9659    * since its tainting flag may be part of the PL_curinterp struct, which
9660    * hasn't been allocated when vms_image_init() is called.
9661    */
9662   if (will_taint) {
9663     char **newargv, **oldargv;
9664     oldargv = *argvp;
9665     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9666     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9667     newargv[0] = oldargv[0];
9668     newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9669     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9670     strcpy(newargv[1], "-T");
9671     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9672     (*argcp)++;
9673     newargv[*argcp] = NULL;
9674     /* We orphan the old argv, since we don't know where it's come from,
9675      * so we don't know how to free it.
9676      */
9677     *argvp = newargv;
9678   }
9679   else {  /* Did user explicitly request tainting? */
9680     int i;
9681     char *cp, **av = *argvp;
9682     for (i = 1; i < *argcp; i++) {
9683       if (*av[i] != '-') break;
9684       for (cp = av[i]+1; *cp; cp++) {
9685         if (*cp == 'T') { will_taint = 1; break; }
9686         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9687                   strchr("DFIiMmx",*cp)) break;
9688       }
9689       if (will_taint) break;
9690     }
9691   }
9692
9693   for (tabidx = 0;
9694        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9695        tabidx++) {
9696     if (!tabidx) {
9697       tabvec = (struct dsc$descriptor_s **)
9698             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9699       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9700     }
9701     else if (tabidx >= tabct) {
9702       tabct += 8;
9703       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9704       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9705     }
9706     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9707     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9708     tabvec[tabidx]->dsc$w_length  = len;
9709     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9710     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_S;
9711     tabvec[tabidx]->dsc$a_pointer = (char *)PerlMem_malloc(len + 1);
9712     if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9713     my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
9714   }
9715   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9716
9717   getredirection(argcp,argvp);
9718 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9719   {
9720 # include <reentrancy.h>
9721   decc$set_reentrancy(C$C_MULTITHREAD);
9722   }
9723 #endif
9724   return;
9725 }
9726 /*}}}*/
9727
9728
9729 /* trim_unixpath()
9730  * Trim Unix-style prefix off filespec, so it looks like what a shell
9731  * glob expansion would return (i.e. from specified prefix on, not
9732  * full path).  Note that returned filespec is Unix-style, regardless
9733  * of whether input filespec was VMS-style or Unix-style.
9734  *
9735  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9736  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9737  * vector of options; at present, only bit 0 is used, and if set tells
9738  * trim unixpath to try the current default directory as a prefix when
9739  * presented with a possibly ambiguous ... wildcard.
9740  *
9741  * Returns !=0 on success, with trimmed filespec replacing contents of
9742  * fspec, and 0 on failure, with contents of fpsec unchanged.
9743  */
9744 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9745 int
9746 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9747 {
9748   char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9749   int tmplen, reslen = 0, dirs = 0;
9750
9751   if (!wildspec || !fspec) return 0;
9752
9753   unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9754   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9755   tplate = unixwild;
9756   if (strpbrk(wildspec,"]>:") != NULL) {
9757     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9758         PerlMem_free(unixwild);
9759         return 0;
9760     }
9761   }
9762   else {
9763     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9764   }
9765   unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9766   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9767   if (strpbrk(fspec,"]>:") != NULL) {
9768     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9769         PerlMem_free(unixwild);
9770         PerlMem_free(unixified);
9771         return 0;
9772     }
9773     else base = unixified;
9774     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9775      * check to see that final result fits into (isn't longer than) fspec */
9776     reslen = strlen(fspec);
9777   }
9778   else base = fspec;
9779
9780   /* No prefix or absolute path on wildcard, so nothing to remove */
9781   if (!*tplate || *tplate == '/') {
9782     PerlMem_free(unixwild);
9783     if (base == fspec) {
9784         PerlMem_free(unixified);
9785         return 1;
9786     }
9787     tmplen = strlen(unixified);
9788     if (tmplen > reslen) {
9789         PerlMem_free(unixified);
9790         return 0;  /* not enough space */
9791     }
9792     /* Copy unixified resultant, including trailing NUL */
9793     memmove(fspec,unixified,tmplen+1);
9794     PerlMem_free(unixified);
9795     return 1;
9796   }
9797
9798   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9799   if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9800     for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9801     for (cp1 = end ;cp1 >= base; cp1--)
9802       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9803         { cp1++; break; }
9804     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9805     PerlMem_free(unixified);
9806     PerlMem_free(unixwild);
9807     return 1;
9808   }
9809   else {
9810     char *tpl, *lcres;
9811     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9812     int ells = 1, totells, segdirs, match;
9813     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9814                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9815
9816     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9817     totells = ells;
9818     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9819     tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9820     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9821     if (ellipsis == tplate && opts & 1) {
9822       /* Template begins with an ellipsis.  Since we can't tell how many
9823        * directory names at the front of the resultant to keep for an
9824        * arbitrary starting point, we arbitrarily choose the current
9825        * default directory as a starting point.  If it's there as a prefix,
9826        * clip it off.  If not, fall through and act as if the leading
9827        * ellipsis weren't there (i.e. return shortest possible path that
9828        * could match template).
9829        */
9830       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9831           PerlMem_free(tpl);
9832           PerlMem_free(unixified);
9833           PerlMem_free(unixwild);
9834           return 0;
9835       }
9836       if (!decc_efs_case_preserve) {
9837         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9838           if (_tolower(*cp1) != _tolower(*cp2)) break;
9839       }
9840       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9841       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9842       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9843         memmove(fspec,cp2+1,end - cp2);
9844         PerlMem_free(tpl);
9845         PerlMem_free(unixified);
9846         PerlMem_free(unixwild);
9847         return 1;
9848       }
9849     }
9850     /* First off, back up over constant elements at end of path */
9851     if (dirs) {
9852       for (front = end ; front >= base; front--)
9853          if (*front == '/' && !dirs--) { front++; break; }
9854     }
9855     lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9856     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9857     for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9858          cp1++,cp2++) {
9859             if (!decc_efs_case_preserve) {
9860                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9861             }
9862             else {
9863                 *cp2 = *cp1;
9864             }
9865     }
9866     if (cp1 != '\0') {
9867         PerlMem_free(tpl);
9868         PerlMem_free(unixified);
9869         PerlMem_free(unixwild);
9870         PerlMem_free(lcres);
9871         return 0;  /* Path too long. */
9872     }
9873     lcend = cp2;
9874     *cp2 = '\0';  /* Pick up with memcpy later */
9875     lcfront = lcres + (front - base);
9876     /* Now skip over each ellipsis and try to match the path in front of it. */
9877     while (ells--) {
9878       for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9879         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9880             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9881       if (cp1 < tplate) break; /* template started with an ellipsis */
9882       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9883         ellipsis = cp1; continue;
9884       }
9885       wilddsc.dsc$a_pointer = tpl;
9886       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9887       nextell = cp1;
9888       for (segdirs = 0, cp2 = tpl;
9889            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9890            cp1++, cp2++) {
9891          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9892          else {
9893             if (!decc_efs_case_preserve) {
9894               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9895             }
9896             else {
9897               *cp2 = *cp1;  /* else preserve case for match */
9898             }
9899          }
9900          if (*cp2 == '/') segdirs++;
9901       }
9902       if (cp1 != ellipsis - 1) {
9903           PerlMem_free(tpl);
9904           PerlMem_free(unixified);
9905           PerlMem_free(unixwild);
9906           PerlMem_free(lcres);
9907           return 0; /* Path too long */
9908       }
9909       /* Back up at least as many dirs as in template before matching */
9910       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9911         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9912       for (match = 0; cp1 > lcres;) {
9913         resdsc.dsc$a_pointer = cp1;
9914         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9915           match++;
9916           if (match == 1) lcfront = cp1;
9917         }
9918         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9919       }
9920       if (!match) {
9921         PerlMem_free(tpl);
9922         PerlMem_free(unixified);
9923         PerlMem_free(unixwild);
9924         PerlMem_free(lcres);
9925         return 0;  /* Can't find prefix ??? */
9926       }
9927       if (match > 1 && opts & 1) {
9928         /* This ... wildcard could cover more than one set of dirs (i.e.
9929          * a set of similar dir names is repeated).  If the template
9930          * contains more than 1 ..., upstream elements could resolve the
9931          * ambiguity, but it's not worth a full backtracking setup here.
9932          * As a quick heuristic, clip off the current default directory
9933          * if it's present to find the trimmed spec, else use the
9934          * shortest string that this ... could cover.
9935          */
9936         char def[NAM$C_MAXRSS+1], *st;
9937
9938         if (getcwd(def, sizeof def,0) == NULL) {
9939             PerlMem_free(unixified);
9940             PerlMem_free(unixwild);
9941             PerlMem_free(lcres);
9942             PerlMem_free(tpl);
9943             return 0;
9944         }
9945         if (!decc_efs_case_preserve) {
9946           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9947             if (_tolower(*cp1) != _tolower(*cp2)) break;
9948         }
9949         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9950         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9951         if (*cp1 == '\0' && *cp2 == '/') {
9952           memmove(fspec,cp2+1,end - cp2);
9953           PerlMem_free(tpl);
9954           PerlMem_free(unixified);
9955           PerlMem_free(unixwild);
9956           PerlMem_free(lcres);
9957           return 1;
9958         }
9959         /* Nope -- stick with lcfront from above and keep going. */
9960       }
9961     }
9962     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9963     PerlMem_free(tpl);
9964     PerlMem_free(unixified);
9965     PerlMem_free(unixwild);
9966     PerlMem_free(lcres);
9967     return 1;
9968   }
9969
9970 }  /* end of trim_unixpath() */
9971 /*}}}*/
9972
9973
9974 /*
9975  *  VMS readdir() routines.
9976  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9977  *
9978  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9979  *  Minor modifications to original routines.
9980  */
9981
9982 /* readdir may have been redefined by reentr.h, so make sure we get
9983  * the local version for what we do here.
9984  */
9985 #ifdef readdir
9986 # undef readdir
9987 #endif
9988 #if !defined(PERL_IMPLICIT_CONTEXT)
9989 # define readdir Perl_readdir
9990 #else
9991 # define readdir(a) Perl_readdir(aTHX_ a)
9992 #endif
9993
9994     /* Number of elements in vms_versions array */
9995 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9996
9997 /*
9998  *  Open a directory, return a handle for later use.
9999  */
10000 /*{{{ DIR *opendir(char*name) */
10001 DIR *
10002 Perl_opendir(pTHX_ const char *name)
10003 {
10004     DIR *dd;
10005     char *dir;
10006     Stat_t sb;
10007
10008     Newx(dir, VMS_MAXRSS, char);
10009     if (int_tovmspath(name, dir, NULL) == NULL) {
10010       Safefree(dir);
10011       return NULL;
10012     }
10013     /* Check access before stat; otherwise stat does not
10014      * accurately report whether it's a directory.
10015      */
10016     if (!strstr(dir, "::") /* sys$check_access doesn't do remotes */
10017         && !cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10018       /* cando_by_name has already set errno */
10019       Safefree(dir);
10020       return NULL;
10021     }
10022     if (flex_stat(dir,&sb) == -1) return NULL;
10023     if (!S_ISDIR(sb.st_mode)) {
10024       Safefree(dir);
10025       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10026       return NULL;
10027     }
10028     /* Get memory for the handle, and the pattern. */
10029     Newx(dd,1,DIR);
10030     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10031
10032     /* Fill in the fields; mainly playing with the descriptor. */
10033     sprintf(dd->pattern, "%s*.*",dir);
10034     Safefree(dir);
10035     dd->context = 0;
10036     dd->count = 0;
10037     dd->flags = 0;
10038     /* By saying we want the result of readdir() in unix format, we are really
10039      * saying we want all the escapes removed, translating characters that
10040      * must be escaped in a VMS-format name to their unescaped form, which is
10041      * presumably allowed in a Unix-format name.
10042      */
10043     dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
10044     dd->pat.dsc$a_pointer = dd->pattern;
10045     dd->pat.dsc$w_length = strlen(dd->pattern);
10046     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10047     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10048 #if defined(USE_ITHREADS)
10049     Newx(dd->mutex,1,perl_mutex);
10050     MUTEX_INIT( (perl_mutex *) dd->mutex );
10051 #else
10052     dd->mutex = NULL;
10053 #endif
10054
10055     return dd;
10056 }  /* end of opendir() */
10057 /*}}}*/
10058
10059 /*
10060  *  Set the flag to indicate we want versions or not.
10061  */
10062 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10063 void
10064 vmsreaddirversions(DIR *dd, int flag)
10065 {
10066     if (flag)
10067         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10068     else
10069         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10070 }
10071 /*}}}*/
10072
10073 /*
10074  *  Free up an opened directory.
10075  */
10076 /*{{{ void closedir(DIR *dd)*/
10077 void
10078 Perl_closedir(DIR *dd)
10079 {
10080     int sts;
10081
10082     sts = lib$find_file_end(&dd->context);
10083     Safefree(dd->pattern);
10084 #if defined(USE_ITHREADS)
10085     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10086     Safefree(dd->mutex);
10087 #endif
10088     Safefree(dd);
10089 }
10090 /*}}}*/
10091
10092 /*
10093  *  Collect all the version numbers for the current file.
10094  */
10095 static void
10096 collectversions(pTHX_ DIR *dd)
10097 {
10098     struct dsc$descriptor_s     pat;
10099     struct dsc$descriptor_s     res;
10100     struct dirent *e;
10101     char *p, *text, *buff;
10102     int i;
10103     unsigned long context, tmpsts;
10104
10105     /* Convenient shorthand. */
10106     e = &dd->entry;
10107
10108     /* Add the version wildcard, ignoring the "*.*" put on before */
10109     i = strlen(dd->pattern);
10110     Newx(text,i + e->d_namlen + 3,char);
10111     my_strlcpy(text, dd->pattern, i + 1);
10112     sprintf(&text[i - 3], "%s;*", e->d_name);
10113
10114     /* Set up the pattern descriptor. */
10115     pat.dsc$a_pointer = text;
10116     pat.dsc$w_length = i + e->d_namlen - 1;
10117     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10118     pat.dsc$b_class = DSC$K_CLASS_S;
10119
10120     /* Set up result descriptor. */
10121     Newx(buff, VMS_MAXRSS, char);
10122     res.dsc$a_pointer = buff;
10123     res.dsc$w_length = VMS_MAXRSS - 1;
10124     res.dsc$b_dtype = DSC$K_DTYPE_T;
10125     res.dsc$b_class = DSC$K_CLASS_S;
10126
10127     /* Read files, collecting versions. */
10128     for (context = 0, e->vms_verscount = 0;
10129          e->vms_verscount < VERSIZE(e);
10130          e->vms_verscount++) {
10131         unsigned long rsts;
10132         unsigned long flags = 0;
10133
10134 #ifdef VMS_LONGNAME_SUPPORT
10135         flags = LIB$M_FIL_LONG_NAMES;
10136 #endif
10137         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10138         if (tmpsts == RMS$_NMF || context == 0) break;
10139         _ckvmssts(tmpsts);
10140         buff[VMS_MAXRSS - 1] = '\0';
10141         if ((p = strchr(buff, ';')))
10142             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10143         else
10144             e->vms_versions[e->vms_verscount] = -1;
10145     }
10146
10147     _ckvmssts(lib$find_file_end(&context));
10148     Safefree(text);
10149     Safefree(buff);
10150
10151 }  /* end of collectversions() */
10152
10153 /*
10154  *  Read the next entry from the directory.
10155  */
10156 /*{{{ struct dirent *readdir(DIR *dd)*/
10157 struct dirent *
10158 Perl_readdir(pTHX_ DIR *dd)
10159 {
10160     struct dsc$descriptor_s     res;
10161     char *p, *buff;
10162     unsigned long int tmpsts;
10163     unsigned long rsts;
10164     unsigned long flags = 0;
10165     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10166     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10167
10168     /* Set up result descriptor, and get next file. */
10169     Newx(buff, VMS_MAXRSS, char);
10170     res.dsc$a_pointer = buff;
10171     res.dsc$w_length = VMS_MAXRSS - 1;
10172     res.dsc$b_dtype = DSC$K_DTYPE_T;
10173     res.dsc$b_class = DSC$K_CLASS_S;
10174
10175 #ifdef VMS_LONGNAME_SUPPORT
10176     flags = LIB$M_FIL_LONG_NAMES;
10177 #endif
10178
10179     tmpsts = lib$find_file
10180         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10181     if (dd->context == 0)
10182         tmpsts = RMS$_NMF;  /* None left. (should be set, but make sure) */
10183
10184     if (!(tmpsts & 1)) {
10185       switch (tmpsts) {
10186         case RMS$_NMF:
10187           break;  /* no more files considered success */
10188         case RMS$_PRV:
10189           SETERRNO(EACCES, tmpsts); break;
10190         case RMS$_DEV:
10191           SETERRNO(ENODEV, tmpsts); break;
10192         case RMS$_DIR:
10193           SETERRNO(ENOTDIR, tmpsts); break;
10194         case RMS$_FNF: case RMS$_DNF:
10195           SETERRNO(ENOENT, tmpsts); break;
10196         default:
10197           SETERRNO(EVMSERR, tmpsts);
10198       }
10199       Safefree(buff);
10200       return NULL;
10201     }
10202     dd->count++;
10203     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10204     buff[res.dsc$w_length] = '\0';
10205     p = buff + res.dsc$w_length;
10206     while (--p >= buff) if (!isspace(*p)) break;
10207     *p = '\0';
10208     if (!decc_efs_case_preserve) {
10209       for (p = buff; *p; p++) *p = _tolower(*p);
10210     }
10211
10212     /* Skip any directory component and just copy the name. */
10213     sts = vms_split_path
10214        (buff,
10215         &v_spec,
10216         &v_len,
10217         &r_spec,
10218         &r_len,
10219         &d_spec,
10220         &d_len,
10221         &n_spec,
10222         &n_len,
10223         &e_spec,
10224         &e_len,
10225         &vs_spec,
10226         &vs_len);
10227
10228     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10229
10230         /* In Unix report mode, remove the ".dir;1" from the name */
10231         /* if it is a real directory. */
10232         if (decc_filename_unix_report && decc_efs_charset) {
10233             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10234                 Stat_t statbuf;
10235                 int ret_sts;
10236
10237                 ret_sts = flex_lstat(buff, &statbuf);
10238                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10239                     e_len = 0;
10240                     e_spec[0] = 0;
10241                 }
10242             }
10243         }
10244
10245         /* Drop NULL extensions on UNIX file specification */
10246         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10247             e_len = 0;
10248             e_spec[0] = '\0';
10249         }
10250     }
10251
10252     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10253     dd->entry.d_name[n_len + e_len] = '\0';
10254     dd->entry.d_namlen = n_len + e_len;
10255
10256     /* Convert the filename to UNIX format if needed */
10257     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10258
10259         /* Translate the encoded characters. */
10260         /* Fixme: Unicode handling could result in embedded 0 characters */
10261         if (strchr(dd->entry.d_name, '^') != NULL) {
10262             char new_name[256];
10263             char * q;
10264             p = dd->entry.d_name;
10265             q = new_name;
10266             while (*p != 0) {
10267                 int inchars_read, outchars_added;
10268                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10269                 p += inchars_read;
10270                 q += outchars_added;
10271                 /* fix-me */
10272                 /* if outchars_added > 1, then this is a wide file specification */
10273                 /* Wide file specifications need to be passed in Perl */
10274                 /* counted strings apparently with a Unicode flag */
10275             }
10276             *q = 0;
10277             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10278         }
10279     }
10280
10281     dd->entry.vms_verscount = 0;
10282     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10283     Safefree(buff);
10284     return &dd->entry;
10285
10286 }  /* end of readdir() */
10287 /*}}}*/
10288
10289 /*
10290  *  Read the next entry from the directory -- thread-safe version.
10291  */
10292 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10293 int
10294 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10295 {
10296     int retval;
10297
10298     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10299
10300     entry = readdir(dd);
10301     *result = entry;
10302     retval = ( *result == NULL ? errno : 0 );
10303
10304     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10305
10306     return retval;
10307
10308 }  /* end of readdir_r() */
10309 /*}}}*/
10310
10311 /*
10312  *  Return something that can be used in a seekdir later.
10313  */
10314 /*{{{ long telldir(DIR *dd)*/
10315 long
10316 Perl_telldir(DIR *dd)
10317 {
10318     return dd->count;
10319 }
10320 /*}}}*/
10321
10322 /*
10323  *  Return to a spot where we used to be.  Brute force.
10324  */
10325 /*{{{ void seekdir(DIR *dd,long count)*/
10326 void
10327 Perl_seekdir(pTHX_ DIR *dd, long count)
10328 {
10329     int old_flags;
10330
10331     /* If we haven't done anything yet... */
10332     if (dd->count == 0)
10333         return;
10334
10335     /* Remember some state, and clear it. */
10336     old_flags = dd->flags;
10337     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10338     _ckvmssts(lib$find_file_end(&dd->context));
10339     dd->context = 0;
10340
10341     /* The increment is in readdir(). */
10342     for (dd->count = 0; dd->count < count; )
10343         readdir(dd);
10344
10345     dd->flags = old_flags;
10346
10347 }  /* end of seekdir() */
10348 /*}}}*/
10349
10350 /* VMS subprocess management
10351  *
10352  * my_vfork() - just a vfork(), after setting a flag to record that
10353  * the current script is trying a Unix-style fork/exec.
10354  *
10355  * vms_do_aexec() and vms_do_exec() are called in response to the
10356  * perl 'exec' function.  If this follows a vfork call, then they
10357  * call out the regular perl routines in doio.c which do an
10358  * execvp (for those who really want to try this under VMS).
10359  * Otherwise, they do exactly what the perl docs say exec should
10360  * do - terminate the current script and invoke a new command
10361  * (See below for notes on command syntax.)
10362  *
10363  * do_aspawn() and do_spawn() implement the VMS side of the perl
10364  * 'system' function.
10365  *
10366  * Note on command arguments to perl 'exec' and 'system': When handled
10367  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10368  * are concatenated to form a DCL command string.  If the first non-numeric
10369  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10370  * the command string is handed off to DCL directly.  Otherwise,
10371  * the first token of the command is taken as the filespec of an image
10372  * to run.  The filespec is expanded using a default type of '.EXE' and
10373  * the process defaults for device, directory, etc., and if found, the resultant
10374  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10375  * the command string as parameters.  This is perhaps a bit complicated,
10376  * but I hope it will form a happy medium between what VMS folks expect
10377  * from lib$spawn and what Unix folks expect from exec.
10378  */
10379
10380 static int vfork_called;
10381
10382 /*{{{int my_vfork(void)*/
10383 int
10384 my_vfork(void)
10385 {
10386   vfork_called++;
10387   return vfork();
10388 }
10389 /*}}}*/
10390
10391
10392 static void
10393 vms_execfree(struct dsc$descriptor_s *vmscmd)
10394 {
10395   if (vmscmd) {
10396       if (vmscmd->dsc$a_pointer) {
10397           PerlMem_free(vmscmd->dsc$a_pointer);
10398       }
10399       PerlMem_free(vmscmd);
10400   }
10401 }
10402
10403 static char *
10404 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10405 {
10406   char *junk, *tmps = NULL;
10407   size_t cmdlen = 0;
10408   size_t rlen;
10409   SV **idx;
10410   STRLEN n_a;
10411
10412   idx = mark;
10413   if (really) {
10414     tmps = SvPV(really,rlen);
10415     if (*tmps) {
10416       cmdlen += rlen + 1;
10417       idx++;
10418     }
10419   }
10420
10421   for (idx++; idx <= sp; idx++) {
10422     if (*idx) {
10423       junk = SvPVx(*idx,rlen);
10424       cmdlen += rlen ? rlen + 1 : 0;
10425     }
10426   }
10427   Newx(PL_Cmd, cmdlen+1, char);
10428
10429   if (tmps && *tmps) {
10430     my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10431     mark++;
10432   }
10433   else *PL_Cmd = '\0';
10434   while (++mark <= sp) {
10435     if (*mark) {
10436       char *s = SvPVx(*mark,n_a);
10437       if (!*s) continue;
10438       if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10439       my_strlcat(PL_Cmd, s, cmdlen+1);
10440     }
10441   }
10442   return PL_Cmd;
10443
10444 }  /* end of setup_argstr() */
10445
10446
10447 static unsigned long int
10448 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10449                    struct dsc$descriptor_s **pvmscmd)
10450 {
10451   char * vmsspec;
10452   char * resspec;
10453   char image_name[NAM$C_MAXRSS+1];
10454   char image_argv[NAM$C_MAXRSS+1];
10455   $DESCRIPTOR(defdsc,".EXE");
10456   $DESCRIPTOR(defdsc2,".");
10457   struct dsc$descriptor_s resdsc;
10458   struct dsc$descriptor_s *vmscmd;
10459   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10460   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10461   char *s, *rest, *cp, *wordbreak;
10462   char * cmd;
10463   int cmdlen;
10464   int isdcl;
10465
10466   vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10467   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10468
10469   /* vmsspec is a DCL command buffer, not just a filename */
10470   vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10471   if (vmsspec == NULL)
10472       _ckvmssts_noperl(SS$_INSFMEM);
10473
10474   resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10475   if (resspec == NULL)
10476       _ckvmssts_noperl(SS$_INSFMEM);
10477
10478   /* Make a copy for modification */
10479   cmdlen = strlen(incmd);
10480   cmd = (char *)PerlMem_malloc(cmdlen+1);
10481   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10482   my_strlcpy(cmd, incmd, cmdlen + 1);
10483   image_name[0] = 0;
10484   image_argv[0] = 0;
10485
10486   resdsc.dsc$a_pointer = resspec;
10487   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10488   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10489   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10490
10491   vmscmd->dsc$a_pointer = NULL;
10492   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10493   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10494   vmscmd->dsc$w_length = 0;
10495   if (pvmscmd) *pvmscmd = vmscmd;
10496
10497   if (suggest_quote) *suggest_quote = 0;
10498
10499   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10500     PerlMem_free(cmd);
10501     PerlMem_free(vmsspec);
10502     PerlMem_free(resspec);
10503     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10504   }
10505
10506   s = cmd;
10507
10508   while (*s && isspace(*s)) s++;
10509
10510   if (*s == '@' || *s == '$') {
10511     vmsspec[0] = *s;  rest = s + 1;
10512     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10513   }
10514   else { cp = vmsspec; rest = s; }
10515
10516   /* If the first word is quoted, then we need to unquote it and
10517    * escape spaces within it.  We'll expand into the resspec buffer,
10518    * then copy back into the cmd buffer, expanding the latter if
10519    * necessary.
10520    */
10521   if (*rest == '"') {
10522     char *cp2;
10523     char *r = rest;
10524     bool in_quote = 0;
10525     int clen = cmdlen;
10526     int soff = s - cmd;
10527
10528     for (cp2 = resspec;
10529          *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10530          rest++) {
10531
10532       if (*rest == ' ') {    /* Escape ' ' to '^_'. */
10533         *cp2 = '^';
10534         *(++cp2) = '_';
10535         cp2++;
10536         clen++;
10537       }
10538       else if (*rest == '"') {
10539         clen--;
10540         if (in_quote) {     /* Must be closing quote. */
10541           rest++;
10542           break;
10543         }
10544         in_quote = 1;
10545       }
10546       else {
10547         *cp2 = *rest;
10548         cp2++;
10549       }
10550     }
10551     *cp2 = '\0';
10552
10553     /* Expand the command buffer if necessary. */
10554     if (clen > cmdlen) {
10555       cmd = (char *)PerlMem_realloc(cmd, clen);
10556       if (cmd == NULL)
10557         _ckvmssts_noperl(SS$_INSFMEM);
10558       /* Where we are may have changed, so recompute offsets */
10559       r = cmd + (r - s - soff);
10560       rest = cmd + (rest - s - soff);
10561       s = cmd + soff;
10562     }
10563
10564     /* Shift the non-verb portion of the command (if any) up or
10565      * down as necessary.
10566      */
10567     if (*rest)
10568       memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10569
10570     /* Copy the unquoted and escaped command verb into place. */
10571     memcpy(r, resspec, cp2 - resspec);
10572     cmd[clen] = '\0';
10573     cmdlen = clen;
10574     rest = r;         /* Rewind for subsequent operations. */
10575   }
10576
10577   if (*rest == '.' || *rest == '/') {
10578     char *cp2;
10579     for (cp2 = resspec;
10580          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10581          rest++, cp2++) *cp2 = *rest;
10582     *cp2 = '\0';
10583     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10584       s = vmsspec;
10585
10586       /* When a UNIX spec with no file type is translated to VMS, */
10587       /* A trailing '.' is appended under ODS-5 rules.            */
10588       /* Here we do not want that trailing "." as it prevents     */
10589       /* Looking for a implied ".exe" type. */
10590       if (decc_efs_charset) {
10591           int i;
10592           i = strlen(vmsspec);
10593           if (vmsspec[i-1] == '.') {
10594               vmsspec[i-1] = '\0';
10595           }
10596       }
10597
10598       if (*rest) {
10599         for (cp2 = vmsspec + strlen(vmsspec);
10600              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10601              rest++, cp2++) *cp2 = *rest;
10602         *cp2 = '\0';
10603       }
10604     }
10605   }
10606   /* Intuit whether verb (first word of cmd) is a DCL command:
10607    *   - if first nonspace char is '@', it's a DCL indirection
10608    * otherwise
10609    *   - if verb contains a filespec separator, it's not a DCL command
10610    *   - if it doesn't, caller tells us whether to default to a DCL
10611    *     command, or to a local image unless told it's DCL (by leading '$')
10612    */
10613   if (*s == '@') {
10614       isdcl = 1;
10615       if (suggest_quote) *suggest_quote = 1;
10616   } else {
10617     char *filespec = strpbrk(s,":<[.;");
10618     rest = wordbreak = strpbrk(s," \"\t/");
10619     if (!wordbreak) wordbreak = s + strlen(s);
10620     if (*s == '$') check_img = 0;
10621     if (filespec && (filespec < wordbreak)) isdcl = 0;
10622     else isdcl = !check_img;
10623   }
10624
10625   if (!isdcl) {
10626     int rsts;
10627     imgdsc.dsc$a_pointer = s;
10628     imgdsc.dsc$w_length = wordbreak - s;
10629     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10630     if (!(retsts&1)) {
10631         _ckvmssts_noperl(lib$find_file_end(&cxt));
10632         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10633       if (!(retsts & 1) && *s == '$') {
10634         _ckvmssts_noperl(lib$find_file_end(&cxt));
10635         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10636         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10637         if (!(retsts&1)) {
10638           _ckvmssts_noperl(lib$find_file_end(&cxt));
10639           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10640         }
10641       }
10642     }
10643     _ckvmssts_noperl(lib$find_file_end(&cxt));
10644
10645     if (retsts & 1) {
10646       FILE *fp;
10647       s = resspec;
10648       while (*s && !isspace(*s)) s++;
10649       *s = '\0';
10650
10651       /* check that it's really not DCL with no file extension */
10652       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10653       if (fp) {
10654         char b[256] = {0,0,0,0};
10655         read(fileno(fp), b, 256);
10656         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10657         if (isdcl) {
10658           int shebang_len;
10659
10660           /* Check for script */
10661           shebang_len = 0;
10662           if ((b[0] == '#') && (b[1] == '!'))
10663              shebang_len = 2;
10664 #ifdef ALTERNATE_SHEBANG
10665           else {
10666             shebang_len = strlen(ALTERNATE_SHEBANG);
10667             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10668               char * perlstr;
10669                 perlstr = strstr("perl",b);
10670                 if (perlstr == NULL)
10671                   shebang_len = 0;
10672             }
10673             else
10674               shebang_len = 0;
10675           }
10676 #endif
10677
10678           if (shebang_len > 0) {
10679           int i;
10680           int j;
10681           char tmpspec[NAM$C_MAXRSS + 1];
10682
10683             i = shebang_len;
10684              /* Image is following after white space */
10685             /*--------------------------------------*/
10686             while (isprint(b[i]) && isspace(b[i]))
10687                 i++;
10688
10689             j = 0;
10690             while (isprint(b[i]) && !isspace(b[i])) {
10691                 tmpspec[j++] = b[i++];
10692                 if (j >= NAM$C_MAXRSS)
10693                    break;
10694             }
10695             tmpspec[j] = '\0';
10696
10697              /* There may be some default parameters to the image */
10698             /*---------------------------------------------------*/
10699             j = 0;
10700             while (isprint(b[i])) {
10701                 image_argv[j++] = b[i++];
10702                 if (j >= NAM$C_MAXRSS)
10703                    break;
10704             }
10705             while ((j > 0) && !isprint(image_argv[j-1]))
10706                 j--;
10707             image_argv[j] = 0;
10708
10709             /* It will need to be converted to VMS format and validated */
10710             if (tmpspec[0] != '\0') {
10711               char * iname;
10712
10713                /* Try to find the exact program requested to be run */
10714               /*---------------------------------------------------*/
10715               iname = int_rmsexpand
10716                  (tmpspec, image_name, ".exe",
10717                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10718               if (iname != NULL) {
10719                 if (cando_by_name_int
10720                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10721                   /* MCR prefix needed */
10722                   isdcl = 0;
10723                 }
10724                 else {
10725                    /* Try again with a null type */
10726                   /*----------------------------*/
10727                   iname = int_rmsexpand
10728                     (tmpspec, image_name, ".",
10729                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10730                   if (iname != NULL) {
10731                     if (cando_by_name_int
10732                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10733                       /* MCR prefix needed */
10734                       isdcl = 0;
10735                     }
10736                   }
10737                 }
10738
10739                  /* Did we find the image to run the script? */
10740                 /*------------------------------------------*/
10741                 if (isdcl) {
10742                   char *tchr;
10743
10744                    /* Assume DCL or foreign command exists */
10745                   /*--------------------------------------*/
10746                   tchr = strrchr(tmpspec, '/');
10747                   if (tchr != NULL) {
10748                     tchr++;
10749                   }
10750                   else {
10751                     tchr = tmpspec;
10752                   }
10753                   my_strlcpy(image_name, tchr, sizeof(image_name));
10754                 }
10755               }
10756             }
10757           }
10758         }
10759         fclose(fp);
10760       }
10761       if (check_img && isdcl) {
10762           PerlMem_free(cmd);
10763           PerlMem_free(resspec);
10764           PerlMem_free(vmsspec);
10765           return RMS$_FNF;
10766       }
10767
10768       if (cando_by_name(S_IXUSR,0,resspec)) {
10769         vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10770         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10771         if (!isdcl) {
10772             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10773             if (image_name[0] != 0) {
10774                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10775                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10776             }
10777         } else if (image_name[0] != 0) {
10778             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10779             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10780         } else {
10781             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10782         }
10783         if (suggest_quote) *suggest_quote = 1;
10784
10785         /* If there is an image name, use original command */
10786         if (image_name[0] == 0)
10787             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10788         else {
10789             rest = cmd;
10790             while (*rest && isspace(*rest)) rest++;
10791         }
10792
10793         if (image_argv[0] != 0) {
10794           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10795           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10796         }
10797         if (rest) {
10798            int rest_len;
10799            int vmscmd_len;
10800
10801            rest_len = strlen(rest);
10802            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10803            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10804               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10805            else
10806              retsts = CLI$_BUFOVF;
10807         }
10808         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10809         PerlMem_free(cmd);
10810         PerlMem_free(vmsspec);
10811         PerlMem_free(resspec);
10812         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10813       }
10814       else
10815         retsts = RMS$_PRV;
10816     }
10817   }
10818   /* It's either a DCL command or we couldn't find a suitable image */
10819   vmscmd->dsc$w_length = strlen(cmd);
10820
10821   vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10822   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10823
10824   PerlMem_free(cmd);
10825   PerlMem_free(resspec);
10826   PerlMem_free(vmsspec);
10827
10828   /* check if it's a symbol (for quoting purposes) */
10829   if (suggest_quote && !*suggest_quote) {
10830     int iss;
10831     char equiv[LNM$C_NAMLENGTH];
10832     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10833     eqvdsc.dsc$a_pointer = equiv;
10834
10835     iss = lib$get_symbol(vmscmd,&eqvdsc);
10836     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10837   }
10838   if (!(retsts & 1)) {
10839     /* just hand off status values likely to be due to user error */
10840     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10841         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10842        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10843     else { _ckvmssts_noperl(retsts); }
10844   }
10845
10846   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10847
10848 }  /* end of setup_cmddsc() */
10849
10850
10851 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10852 bool
10853 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10854 {
10855   bool exec_sts;
10856   char * cmd;
10857
10858   if (sp > mark) {
10859     if (vfork_called) {           /* this follows a vfork - act Unixish */
10860       vfork_called--;
10861       if (vfork_called < 0) {
10862         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10863         vfork_called = 0;
10864       }
10865       else return do_aexec(really,mark,sp);
10866     }
10867                                            /* no vfork - act VMSish */
10868     cmd = setup_argstr(aTHX_ really,mark,sp);
10869     exec_sts = vms_do_exec(cmd);
10870     Safefree(cmd);  /* Clean up from setup_argstr() */
10871     return exec_sts;
10872   }
10873
10874   return FALSE;
10875 }  /* end of vms_do_aexec() */
10876 /*}}}*/
10877
10878 /* {{{bool vms_do_exec(char *cmd) */
10879 bool
10880 Perl_vms_do_exec(pTHX_ const char *cmd)
10881 {
10882   struct dsc$descriptor_s *vmscmd;
10883
10884   if (vfork_called) {             /* this follows a vfork - act Unixish */
10885     vfork_called--;
10886     if (vfork_called < 0) {
10887       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10888       vfork_called = 0;
10889     }
10890     else return do_exec(cmd);
10891   }
10892
10893   {                               /* no vfork - act VMSish */
10894     unsigned long int retsts;
10895
10896     TAINT_ENV();
10897     TAINT_PROPER("exec");
10898     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10899       retsts = lib$do_command(vmscmd);
10900
10901     switch (retsts) {
10902       case RMS$_FNF: case RMS$_DNF:
10903         set_errno(ENOENT); break;
10904       case RMS$_DIR:
10905         set_errno(ENOTDIR); break;
10906       case RMS$_DEV:
10907         set_errno(ENODEV); break;
10908       case RMS$_PRV:
10909         set_errno(EACCES); break;
10910       case RMS$_SYN:
10911         set_errno(EINVAL); break;
10912       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10913         set_errno(E2BIG); break;
10914       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10915         _ckvmssts_noperl(retsts); /* fall through */
10916       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10917         set_errno(EVMSERR);
10918     }
10919     set_vaxc_errno(retsts);
10920     if (ckWARN(WARN_EXEC)) {
10921       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10922              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10923     }
10924     vms_execfree(vmscmd);
10925   }
10926
10927   return FALSE;
10928
10929 }  /* end of vms_do_exec() */
10930 /*}}}*/
10931
10932 int do_spawn2(pTHX_ const char *, int);
10933
10934 int
10935 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10936 {
10937   unsigned long int sts;
10938   char * cmd;
10939   int flags = 0;
10940
10941   if (sp > mark) {
10942
10943     /* We'll copy the (undocumented?) Win32 behavior and allow a
10944      * numeric first argument.  But the only value we'll support
10945      * through do_aspawn is a value of 1, which means spawn without
10946      * waiting for completion -- other values are ignored.
10947      */
10948     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10949         ++mark;
10950         flags = SvIVx(*mark);
10951     }
10952
10953     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10954         flags = CLI$M_NOWAIT;
10955     else
10956         flags = 0;
10957
10958     cmd = setup_argstr(aTHX_ really, mark, sp);
10959     sts = do_spawn2(aTHX_ cmd, flags);
10960     /* pp_sys will clean up cmd */
10961     return sts;
10962   }
10963   return SS$_ABORT;
10964 }  /* end of do_aspawn() */
10965 /*}}}*/
10966
10967
10968 /* {{{int do_spawn(char* cmd) */
10969 int
10970 Perl_do_spawn(pTHX_ char* cmd)
10971 {
10972     PERL_ARGS_ASSERT_DO_SPAWN;
10973
10974     return do_spawn2(aTHX_ cmd, 0);
10975 }
10976 /*}}}*/
10977
10978 /* {{{int do_spawn_nowait(char* cmd) */
10979 int
10980 Perl_do_spawn_nowait(pTHX_ char* cmd)
10981 {
10982     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10983
10984     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10985 }
10986 /*}}}*/
10987
10988 /* {{{int do_spawn2(char *cmd) */
10989 int
10990 do_spawn2(pTHX_ const char *cmd, int flags)
10991 {
10992   unsigned long int sts, substs;
10993
10994   /* The caller of this routine expects to Safefree(PL_Cmd) */
10995   Newx(PL_Cmd,10,char);
10996
10997   TAINT_ENV();
10998   TAINT_PROPER("spawn");
10999   if (!cmd || !*cmd) {
11000     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11001     if (!(sts & 1)) {
11002       switch (sts) {
11003         case RMS$_FNF:  case RMS$_DNF:
11004           set_errno(ENOENT); break;
11005         case RMS$_DIR:
11006           set_errno(ENOTDIR); break;
11007         case RMS$_DEV:
11008           set_errno(ENODEV); break;
11009         case RMS$_PRV:
11010           set_errno(EACCES); break;
11011         case RMS$_SYN:
11012           set_errno(EINVAL); break;
11013         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11014           set_errno(E2BIG); break;
11015         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11016           _ckvmssts_noperl(sts); /* fall through */
11017         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11018           set_errno(EVMSERR);
11019       }
11020       set_vaxc_errno(sts);
11021       if (ckWARN(WARN_EXEC)) {
11022         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11023                     Strerror(errno));
11024       }
11025     }
11026     sts = substs;
11027   }
11028   else {
11029     char mode[3];
11030     PerlIO * fp;
11031     if (flags & CLI$M_NOWAIT)
11032         strcpy(mode, "n");
11033     else
11034         strcpy(mode, "nW");
11035
11036     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11037     if (fp != NULL)
11038       my_pclose(fp);
11039     /* sts will be the pid in the nowait case, so leave a
11040      * hint saying not to do any bit shifting to it.
11041      */
11042     if (flags & CLI$M_NOWAIT)
11043         PL_statusvalue = -1;
11044   }
11045   return sts;
11046 }  /* end of do_spawn2() */
11047 /*}}}*/
11048
11049
11050 static unsigned int *sockflags, sockflagsize;
11051
11052 /*
11053  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11054  * routines found in some versions of the CRTL can't deal with sockets.
11055  * We don't shim the other file open routines since a socket isn't
11056  * likely to be opened by a name.
11057  */
11058 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11059 FILE *
11060 my_fdopen(int fd, const char *mode)
11061 {
11062   FILE *fp = fdopen(fd, mode);
11063
11064   if (fp) {
11065     unsigned int fdoff = fd / sizeof(unsigned int);
11066     Stat_t sbuf; /* native stat; we don't need flex_stat */
11067     if (!sockflagsize || fdoff > sockflagsize) {
11068       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11069       else           Newx  (sockflags,fdoff+2,unsigned int);
11070       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11071       sockflagsize = fdoff + 2;
11072     }
11073     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11074       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11075   }
11076   return fp;
11077
11078 }
11079 /*}}}*/
11080
11081
11082 /*
11083  * Clear the corresponding bit when the (possibly) socket stream is closed.
11084  * There still a small hole: we miss an implicit close which might occur
11085  * via freopen().  >> Todo
11086  */
11087 /*{{{ int my_fclose(FILE *fp)*/
11088 int
11089 my_fclose(FILE *fp) {
11090   if (fp) {
11091     unsigned int fd = fileno(fp);
11092     unsigned int fdoff = fd / sizeof(unsigned int);
11093
11094     if (sockflagsize && fdoff < sockflagsize)
11095       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11096   }
11097   return fclose(fp);
11098 }
11099 /*}}}*/
11100
11101
11102 /*
11103  * A simple fwrite replacement which outputs itmsz*nitm chars without
11104  * introducing record boundaries every itmsz chars.
11105  * We are using fputs, which depends on a terminating null.  We may
11106  * well be writing binary data, so we need to accommodate not only
11107  * data with nulls sprinkled in the middle but also data with no null
11108  * byte at the end.
11109  */
11110 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11111 int
11112 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11113 {
11114   char *cp, *end, *cpd;
11115   char *data;
11116   unsigned int fd = fileno(dest);
11117   unsigned int fdoff = fd / sizeof(unsigned int);
11118   int retval;
11119   int bufsize = itmsz * nitm + 1;
11120
11121   if (fdoff < sockflagsize &&
11122       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11123     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11124     return nitm;
11125   }
11126
11127   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11128   memcpy( data, src, itmsz*nitm );
11129   data[itmsz*nitm] = '\0';
11130
11131   end = data + itmsz * nitm;
11132   retval = (int) nitm; /* on success return # items written */
11133
11134   cpd = data;
11135   while (cpd <= end) {
11136     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11137     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11138     if (cp < end)
11139       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11140     cpd = cp + 1;
11141   }
11142
11143   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11144   return retval;
11145
11146 }  /* end of my_fwrite() */
11147 /*}}}*/
11148
11149 /*{{{ int my_flush(FILE *fp)*/
11150 int
11151 Perl_my_flush(pTHX_ FILE *fp)
11152 {
11153     int res;
11154     if ((res = fflush(fp)) == 0 && fp) {
11155 #ifdef VMS_DO_SOCKETS
11156         Stat_t s;
11157         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11158 #endif
11159             res = fsync(fileno(fp));
11160     }
11161 /*
11162  * If the flush succeeded but set end-of-file, we need to clear
11163  * the error because our caller may check ferror().  BTW, this
11164  * probably means we just flushed an empty file.
11165  */
11166     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11167
11168     return res;
11169 }
11170 /*}}}*/
11171
11172 /* fgetname() is not returning the correct file specifications when
11173  * decc_filename_unix_report mode is active.  So we have to have it
11174  * aways return filenames in VMS mode and convert it ourselves.
11175  */
11176
11177 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11178 char *
11179 Perl_my_fgetname(FILE *fp, char * buf) {
11180     char * retname;
11181     char * vms_name;
11182
11183     retname = fgetname(fp, buf, 1);
11184
11185     /* If we are in VMS mode, then we are done */
11186     if (!decc_filename_unix_report || (retname == NULL)) {
11187        return retname;
11188     }
11189
11190     /* Convert this to Unix format */
11191     vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11192     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11193     retname = int_tounixspec(vms_name, buf, NULL);
11194     PerlMem_free(vms_name);
11195
11196     return retname;
11197 }
11198 /*}}}*/
11199
11200 /*
11201  * Here are replacements for the following Unix routines in the VMS environment:
11202  *      getpwuid    Get information for a particular UIC or UID
11203  *      getpwnam    Get information for a named user
11204  *      getpwent    Get information for each user in the rights database
11205  *      setpwent    Reset search to the start of the rights database
11206  *      endpwent    Finish searching for users in the rights database
11207  *
11208  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11209  * (defined in pwd.h), which contains the following fields:-
11210  *      struct passwd {
11211  *              char        *pw_name;    Username (in lower case)
11212  *              char        *pw_passwd;  Hashed password
11213  *              unsigned int pw_uid;     UIC
11214  *              unsigned int pw_gid;     UIC group  number
11215  *              char        *pw_unixdir; Default device/directory (VMS-style)
11216  *              char        *pw_gecos;   Owner name
11217  *              char        *pw_dir;     Default device/directory (Unix-style)
11218  *              char        *pw_shell;   Default CLI name (eg. DCL)
11219  *      };
11220  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11221  *
11222  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11223  * not the UIC member number (eg. what's returned by getuid()),
11224  * getpwuid() can accept either as input (if uid is specified, the caller's
11225  * UIC group is used), though it won't recognise gid=0.
11226  *
11227  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11228  * information about other users in your group or in other groups, respectively.
11229  * If the required privilege is not available, then these routines fill only
11230  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11231  * string).
11232  *
11233  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11234  */
11235
11236 /* sizes of various UAF record fields */
11237 #define UAI$S_USERNAME 12
11238 #define UAI$S_IDENT    31
11239 #define UAI$S_OWNER    31
11240 #define UAI$S_DEFDEV   31
11241 #define UAI$S_DEFDIR   63
11242 #define UAI$S_DEFCLI   31
11243 #define UAI$S_PWD       8
11244
11245 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11246                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11247                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11248
11249 static char __empty[]= "";
11250 static struct passwd __passwd_empty=
11251     {(char *) __empty, (char *) __empty, 0, 0,
11252      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11253 static int contxt= 0;
11254 static struct passwd __pwdcache;
11255 static char __pw_namecache[UAI$S_IDENT+1];
11256
11257 /*
11258  * This routine does most of the work extracting the user information.
11259  */
11260 static int
11261 fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11262 {
11263     static struct {
11264         unsigned char length;
11265         char pw_gecos[UAI$S_OWNER+1];
11266     } owner;
11267     static union uicdef uic;
11268     static struct {
11269         unsigned char length;
11270         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11271     } defdev;
11272     static struct {
11273         unsigned char length;
11274         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11275     } defdir;
11276     static struct {
11277         unsigned char length;
11278         char pw_shell[UAI$S_DEFCLI+1];
11279     } defcli;
11280     static char pw_passwd[UAI$S_PWD+1];
11281
11282     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11283     struct dsc$descriptor_s name_desc;
11284     unsigned long int sts;
11285
11286     static struct itmlst_3 itmlst[]= {
11287         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11288         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11289         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11290         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11291         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11292         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11293         {0,                0,           NULL,    NULL}};
11294
11295     name_desc.dsc$w_length=  strlen(name);
11296     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11297     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11298     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11299
11300 /*  Note that sys$getuai returns many fields as counted strings. */
11301     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11302     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11303       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11304     }
11305     else { _ckvmssts(sts); }
11306     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11307
11308     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11309     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11310     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11311     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11312     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11313     owner.pw_gecos[lowner]=            '\0';
11314     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11315     defcli.pw_shell[ldefcli]=          '\0';
11316     if (valid_uic(uic)) {
11317         pwd->pw_uid= uic.uic$l_uic;
11318         pwd->pw_gid= uic.uic$v_group;
11319     }
11320     else
11321       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11322     pwd->pw_passwd=  pw_passwd;
11323     pwd->pw_gecos=   owner.pw_gecos;
11324     pwd->pw_dir=     defdev.pw_dir;
11325     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11326     pwd->pw_shell=   defcli.pw_shell;
11327     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11328         int ldir;
11329         ldir= strlen(pwd->pw_unixdir) - 1;
11330         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11331     }
11332     else
11333         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11334     if (!decc_efs_case_preserve)
11335         __mystrtolower(pwd->pw_unixdir);
11336     return 1;
11337 }
11338
11339 /*
11340  * Get information for a named user.
11341 */
11342 /*{{{struct passwd *getpwnam(char *name)*/
11343 struct passwd *
11344 Perl_my_getpwnam(pTHX_ const char *name)
11345 {
11346     struct dsc$descriptor_s name_desc;
11347     union uicdef uic;
11348     unsigned long int sts;
11349
11350     __pwdcache = __passwd_empty;
11351     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11352       /* We still may be able to determine pw_uid and pw_gid */
11353       name_desc.dsc$w_length=  strlen(name);
11354       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11355       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11356       name_desc.dsc$a_pointer= (char *) name;
11357       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11358         __pwdcache.pw_uid= uic.uic$l_uic;
11359         __pwdcache.pw_gid= uic.uic$v_group;
11360       }
11361       else {
11362         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11363           set_vaxc_errno(sts);
11364           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11365           return NULL;
11366         }
11367         else { _ckvmssts(sts); }
11368       }
11369     }
11370     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11371     __pwdcache.pw_name= __pw_namecache;
11372     return &__pwdcache;
11373 }  /* end of my_getpwnam() */
11374 /*}}}*/
11375
11376 /*
11377  * Get information for a particular UIC or UID.
11378  * Called by my_getpwent with uid=-1 to list all users.
11379 */
11380 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11381 struct passwd *
11382 Perl_my_getpwuid(pTHX_ Uid_t uid)
11383 {
11384     const $DESCRIPTOR(name_desc,__pw_namecache);
11385     unsigned short lname;
11386     union uicdef uic;
11387     unsigned long int status;
11388
11389     if (uid == (unsigned int) -1) {
11390       do {
11391         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11392         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11393           set_vaxc_errno(status);
11394           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11395           my_endpwent();
11396           return NULL;
11397         }
11398         else { _ckvmssts(status); }
11399       } while (!valid_uic (uic));
11400     }
11401     else {
11402       uic.uic$l_uic= uid;
11403       if (!uic.uic$v_group)
11404         uic.uic$v_group= PerlProc_getgid();
11405       if (valid_uic(uic))
11406         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11407       else status = SS$_IVIDENT;
11408       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11409           status == RMS$_PRV) {
11410         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11411         return NULL;
11412       }
11413       else { _ckvmssts(status); }
11414     }
11415     __pw_namecache[lname]= '\0';
11416     __mystrtolower(__pw_namecache);
11417
11418     __pwdcache = __passwd_empty;
11419     __pwdcache.pw_name = __pw_namecache;
11420
11421 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11422     The identifier's value is usually the UIC, but it doesn't have to be,
11423     so if we can, we let fillpasswd update this. */
11424     __pwdcache.pw_uid =  uic.uic$l_uic;
11425     __pwdcache.pw_gid =  uic.uic$v_group;
11426
11427     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11428     return &__pwdcache;
11429
11430 }  /* end of my_getpwuid() */
11431 /*}}}*/
11432
11433 /*
11434  * Get information for next user.
11435 */
11436 /*{{{struct passwd *my_getpwent()*/
11437 struct passwd *
11438 Perl_my_getpwent(pTHX)
11439 {
11440     return (my_getpwuid((unsigned int) -1));
11441 }
11442 /*}}}*/
11443
11444 /*
11445  * Finish searching rights database for users.
11446 */
11447 /*{{{void my_endpwent()*/
11448 void
11449 Perl_my_endpwent(pTHX)
11450 {
11451     if (contxt) {
11452       _ckvmssts(sys$finish_rdb(&contxt));
11453       contxt= 0;
11454     }
11455 }
11456 /*}}}*/
11457
11458 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11459  * my_utime(), and flex_stat(), all of which operate on UTC unless
11460  * VMSISH_TIMES is true.
11461  */
11462 /* method used to handle UTC conversions:
11463  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11464  */
11465 static int gmtime_emulation_type;
11466 /* number of secs to add to UTC POSIX-style time to get local time */
11467 static long int utc_offset_secs;
11468
11469 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11470  * in vmsish.h.  #undef them here so we can call the CRTL routines
11471  * directly.
11472  */
11473 #undef gmtime
11474 #undef localtime
11475 #undef time
11476
11477
11478 static time_t toutc_dst(time_t loc) {
11479   struct tm *rsltmp;
11480
11481   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11482   loc -= utc_offset_secs;
11483   if (rsltmp->tm_isdst) loc -= 3600;
11484   return loc;
11485 }
11486 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11487        ((gmtime_emulation_type || my_time(NULL)), \
11488        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11489        ((secs) - utc_offset_secs))))
11490
11491 static time_t toloc_dst(time_t utc) {
11492   struct tm *rsltmp;
11493
11494   utc += utc_offset_secs;
11495   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11496   if (rsltmp->tm_isdst) utc += 3600;
11497   return utc;
11498 }
11499 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11500        ((gmtime_emulation_type || my_time(NULL)), \
11501        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11502        ((secs) + utc_offset_secs))))
11503
11504 /* my_time(), my_localtime(), my_gmtime()
11505  * By default traffic in UTC time values, using CRTL gmtime() or
11506  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11507  * Note: We need to use these functions even when the CRTL has working
11508  * UTC support, since they also handle C<use vmsish qw(times);>
11509  *
11510  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11511  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11512  */
11513
11514 /*{{{time_t my_time(time_t *timep)*/
11515 time_t
11516 Perl_my_time(pTHX_ time_t *timep)
11517 {
11518   time_t when;
11519   struct tm *tm_p;
11520
11521   if (gmtime_emulation_type == 0) {
11522     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11523                               /* results of calls to gmtime() and localtime() */
11524                               /* for same &base */
11525
11526     gmtime_emulation_type++;
11527     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11528       char off[LNM$C_NAMLENGTH+1];;
11529
11530       gmtime_emulation_type++;
11531       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11532         gmtime_emulation_type++;
11533         utc_offset_secs = 0;
11534         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11535       }
11536       else { utc_offset_secs = atol(off); }
11537     }
11538     else { /* We've got a working gmtime() */
11539       struct tm gmt, local;
11540
11541       gmt = *tm_p;
11542       tm_p = localtime(&base);
11543       local = *tm_p;
11544       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11545       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11546       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11547       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11548     }
11549   }
11550
11551   when = time(NULL);
11552 # ifdef VMSISH_TIME
11553   if (VMSISH_TIME) when = _toloc(when);
11554 # endif
11555   if (timep != NULL) *timep = when;
11556   return when;
11557
11558 }  /* end of my_time() */
11559 /*}}}*/
11560
11561
11562 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11563 struct tm *
11564 Perl_my_gmtime(pTHX_ const time_t *timep)
11565 {
11566   time_t when;
11567   struct tm *rsltmp;
11568
11569   if (timep == NULL) {
11570     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11571     return NULL;
11572   }
11573   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11574
11575   when = *timep;
11576 # ifdef VMSISH_TIME
11577   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11578 #  endif
11579   return gmtime(&when);
11580 }  /* end of my_gmtime() */
11581 /*}}}*/
11582
11583
11584 /*{{{struct tm *my_localtime(const time_t *timep)*/
11585 struct tm *
11586 Perl_my_localtime(pTHX_ const time_t *timep)
11587 {
11588   time_t when;
11589
11590   if (timep == NULL) {
11591     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11592     return NULL;
11593   }
11594   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11595   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11596
11597   when = *timep;
11598 # ifdef VMSISH_TIME
11599   if (VMSISH_TIME) when = _toutc(when);
11600 # endif
11601   /* CRTL localtime() wants UTC as input, does tz correction itself */
11602   return localtime(&when);
11603 } /*  end of my_localtime() */
11604 /*}}}*/
11605
11606 /* Reset definitions for later calls */
11607 #define gmtime(t)    my_gmtime(t)
11608 #define localtime(t) my_localtime(t)
11609 #define time(t)      my_time(t)
11610
11611
11612 /* my_utime - update modification/access time of a file
11613  *
11614  * VMS 7.3 and later implementation
11615  * Only the UTC translation is home-grown. The rest is handled by the
11616  * CRTL utime(), which will take into account the relevant feature
11617  * logicals and ODS-5 volume characteristics for true access times.
11618  *
11619  * pre VMS 7.3 implementation:
11620  * The calling sequence is identical to POSIX utime(), but under
11621  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11622  * not maintain access times.  Restrictions differ from the POSIX
11623  * definition in that the time can be changed as long as the
11624  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11625  * no separate checks are made to insure that the caller is the
11626  * owner of the file or has special privs enabled.
11627  * Code here is based on Joe Meadows' FILE utility.
11628  *
11629  */
11630
11631 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11632  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11633  * in 100 ns intervals.
11634  */
11635 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11636
11637 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11638 int
11639 Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11640 {
11641 #if __CRTL_VER >= 70300000
11642   struct utimbuf utc_utimes, *utc_utimesp;
11643
11644   if (utimes != NULL) {
11645     utc_utimes.actime = utimes->actime;
11646     utc_utimes.modtime = utimes->modtime;
11647 # ifdef VMSISH_TIME
11648     /* If input was local; convert to UTC for sys svc */
11649     if (VMSISH_TIME) {
11650       utc_utimes.actime = _toutc(utimes->actime);
11651       utc_utimes.modtime = _toutc(utimes->modtime);
11652     }
11653 # endif
11654     utc_utimesp = &utc_utimes;
11655   }
11656   else {
11657     utc_utimesp = NULL;
11658   }
11659
11660   return utime(file, utc_utimesp);
11661
11662 #else /* __CRTL_VER < 70300000 */
11663
11664   int i;
11665   int sts;
11666   long int bintime[2], len = 2, lowbit, unixtime,
11667            secscale = 10000000; /* seconds --> 100 ns intervals */
11668   unsigned long int chan, iosb[2], retsts;
11669   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11670   struct FAB myfab = cc$rms_fab;
11671   struct NAM mynam = cc$rms_nam;
11672 #if defined (__DECC) && defined (__VAX)
11673   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11674    * at least through VMS V6.1, which causes a type-conversion warning.
11675    */
11676 #  pragma message save
11677 #  pragma message disable cvtdiftypes
11678 #endif
11679   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11680   struct fibdef myfib;
11681 #if defined (__DECC) && defined (__VAX)
11682   /* This should be right after the declaration of myatr, but due
11683    * to a bug in VAX DEC C, this takes effect a statement early.
11684    */
11685 #  pragma message restore
11686 #endif
11687   /* cast ok for read only parameter */
11688   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11689                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11690                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11691
11692   if (file == NULL || *file == '\0') {
11693     SETERRNO(ENOENT, LIB$_INVARG);
11694     return -1;
11695   }
11696
11697   /* Convert to VMS format ensuring that it will fit in 255 characters */
11698   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11699       SETERRNO(ENOENT, LIB$_INVARG);
11700       return -1;
11701   }
11702   if (utimes != NULL) {
11703     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11704      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11705      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11706      * as input, we force the sign bit to be clear by shifting unixtime right
11707      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11708      */
11709     lowbit = (utimes->modtime & 1) ? secscale : 0;
11710     unixtime = (long int) utimes->modtime;
11711 #   ifdef VMSISH_TIME
11712     /* If input was UTC; convert to local for sys svc */
11713     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11714 #   endif
11715     unixtime >>= 1;  secscale <<= 1;
11716     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11717     if (!(retsts & 1)) {
11718       SETERRNO(EVMSERR, retsts);
11719       return -1;
11720     }
11721     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11722     if (!(retsts & 1)) {
11723       SETERRNO(EVMSERR, retsts);
11724       return -1;
11725     }
11726   }
11727   else {
11728     /* Just get the current time in VMS format directly */
11729     retsts = sys$gettim(bintime);
11730     if (!(retsts & 1)) {
11731       SETERRNO(EVMSERR, retsts);
11732       return -1;
11733     }
11734   }
11735
11736   myfab.fab$l_fna = vmsspec;
11737   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11738   myfab.fab$l_nam = &mynam;
11739   mynam.nam$l_esa = esa;
11740   mynam.nam$b_ess = (unsigned char) sizeof esa;
11741   mynam.nam$l_rsa = rsa;
11742   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11743   if (decc_efs_case_preserve)
11744       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11745
11746   /* Look for the file to be affected, letting RMS parse the file
11747    * specification for us as well.  I have set errno using only
11748    * values documented in the utime() man page for VMS POSIX.
11749    */
11750   retsts = sys$parse(&myfab,0,0);
11751   if (!(retsts & 1)) {
11752     set_vaxc_errno(retsts);
11753     if      (retsts == RMS$_PRV) set_errno(EACCES);
11754     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11755     else                         set_errno(EVMSERR);
11756     return -1;
11757   }
11758   retsts = sys$search(&myfab,0,0);
11759   if (!(retsts & 1)) {
11760     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11761     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11762     set_vaxc_errno(retsts);
11763     if      (retsts == RMS$_PRV) set_errno(EACCES);
11764     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11765     else                         set_errno(EVMSERR);
11766     return -1;
11767   }
11768
11769   devdsc.dsc$w_length = mynam.nam$b_dev;
11770   /* cast ok for read only parameter */
11771   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11772
11773   retsts = sys$assign(&devdsc,&chan,0,0);
11774   if (!(retsts & 1)) {
11775     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11776     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11777     set_vaxc_errno(retsts);
11778     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11779     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11780     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11781     else                               set_errno(EVMSERR);
11782     return -1;
11783   }
11784
11785   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11786   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11787
11788   memset((void *) &myfib, 0, sizeof myfib);
11789 #if defined(__DECC) || defined(__DECCXX)
11790   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11791   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11792   /* This prevents the revision time of the file being reset to the current
11793    * time as a result of our IO$_MODIFY $QIO. */
11794   myfib.fib$l_acctl = FIB$M_NORECORD;
11795 #else
11796   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11797   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11798   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11799 #endif
11800   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11801   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11802   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11803   _ckvmssts(sys$dassgn(chan));
11804   if (retsts & 1) retsts = iosb[0];
11805   if (!(retsts & 1)) {
11806     set_vaxc_errno(retsts);
11807     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11808     else                      set_errno(EVMSERR);
11809     return -1;
11810   }
11811
11812   return 0;
11813
11814 #endif /* #if __CRTL_VER >= 70300000 */
11815
11816 }  /* end of my_utime() */
11817 /*}}}*/
11818
11819 /*
11820  * flex_stat, flex_lstat, flex_fstat
11821  * basic stat, but gets it right when asked to stat
11822  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11823  */
11824
11825 #ifndef _USE_STD_STAT
11826 /* encode_dev packs a VMS device name string into an integer to allow
11827  * simple comparisons. This can be used, for example, to check whether two
11828  * files are located on the same device, by comparing their encoded device
11829  * names. Even a string comparison would not do, because stat() reuses the
11830  * device name buffer for each call; so without encode_dev, it would be
11831  * necessary to save the buffer and use strcmp (this would mean a number of
11832  * changes to the standard Perl code, to say nothing of what a Perl script
11833  * would have to do.
11834  *
11835  * The device lock id, if it exists, should be unique (unless perhaps compared
11836  * with lock ids transferred from other nodes). We have a lock id if the disk is
11837  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11838  * device names. Thus we use the lock id in preference, and only if that isn't
11839  * available, do we try to pack the device name into an integer (flagged by
11840  * the sign bit (LOCKID_MASK) being set).
11841  *
11842  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11843  * name and its encoded form, but it seems very unlikely that we will find
11844  * two files on different disks that share the same encoded device names,
11845  * and even more remote that they will share the same file id (if the test
11846  * is to check for the same file).
11847  *
11848  * A better method might be to use sys$device_scan on the first call, and to
11849  * search for the device, returning an index into the cached array.
11850  * The number returned would be more intelligible.
11851  * This is probably not worth it, and anyway would take quite a bit longer
11852  * on the first call.
11853  */
11854 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11855 static mydev_t
11856 encode_dev (pTHX_ const char *dev)
11857 {
11858   int i;
11859   unsigned long int f;
11860   mydev_t enc;
11861   char c;
11862   const char *q;
11863
11864   if (!dev || !dev[0]) return 0;
11865
11866 #if LOCKID_MASK
11867   {
11868     struct dsc$descriptor_s dev_desc;
11869     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11870
11871     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11872        can try that first. */
11873     dev_desc.dsc$w_length =  strlen (dev);
11874     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11875     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11876     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11877     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11878     if (!$VMS_STATUS_SUCCESS(status)) {
11879       switch (status) {
11880         case SS$_NOSUCHDEV:
11881           SETERRNO(ENODEV, status);
11882           return 0;
11883         default:
11884           _ckvmssts(status);
11885       }
11886     }
11887     if (lockid) return (lockid & ~LOCKID_MASK);
11888   }
11889 #endif
11890
11891   /* Otherwise we try to encode the device name */
11892   enc = 0;
11893   f = 1;
11894   i = 0;
11895   for (q = dev + strlen(dev); q--; q >= dev) {
11896     if (*q == ':')
11897         break;
11898     if (isdigit (*q))
11899       c= (*q) - '0';
11900     else if (isalpha (toupper (*q)))
11901       c= toupper (*q) - 'A' + (char)10;
11902     else
11903       continue; /* Skip '$'s */
11904     i++;
11905     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11906     if (i>1) f *= 36;
11907     enc += f * (unsigned long int) c;
11908   }
11909   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11910
11911 }  /* end of encode_dev() */
11912 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11913         device_no = encode_dev(aTHX_ devname)
11914 #else
11915 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11916         device_no = new_dev_no
11917 #endif
11918
11919 static int
11920 is_null_device(const char *name)
11921 {
11922   if (decc_bug_devnull != 0) {
11923     if (strncmp("/dev/null", name, 9) == 0)
11924       return 1;
11925   }
11926     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11927        The underscore prefix, controller letter, and unit number are
11928        independently optional; for our purposes, the colon punctuation
11929        is not.  The colon can be trailed by optional directory and/or
11930        filename, but two consecutive colons indicates a nodename rather
11931        than a device.  [pr]  */
11932   if (*name == '_') ++name;
11933   if (tolower(*name++) != 'n') return 0;
11934   if (tolower(*name++) != 'l') return 0;
11935   if (tolower(*name) == 'a') ++name;
11936   if (*name == '0') ++name;
11937   return (*name++ == ':') && (*name != ':');
11938 }
11939
11940 static int
11941 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11942
11943 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11944
11945 static I32
11946 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective, const char *fname, int opts)
11947 {
11948   char usrname[L_cuserid];
11949   struct dsc$descriptor_s usrdsc =
11950          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11951   char *vmsname = NULL, *fileified = NULL;
11952   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11953   unsigned short int retlen, trnlnm_iter_count;
11954   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11955   union prvdef curprv;
11956   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11957          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11958          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11959   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11960          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11961          {0,0,0,0}};
11962   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11963          {0,0,0,0}};
11964   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11965   Stat_t st;
11966   static int profile_context = -1;
11967
11968   if (!fname || !*fname) return FALSE;
11969
11970   /* Make sure we expand logical names, since sys$check_access doesn't */
11971   fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11972   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11973   if (!strpbrk(fname,"/]>:")) {
11974       my_strlcpy(fileified, fname, VMS_MAXRSS);
11975       trnlnm_iter_count = 0;
11976       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11977         trnlnm_iter_count++;
11978         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11979       }
11980       fname = fileified;
11981   }
11982
11983   vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11984   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11985   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11986     /* Don't know if already in VMS format, so make sure */
11987     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11988       PerlMem_free(fileified);
11989       PerlMem_free(vmsname);
11990       return FALSE;
11991     }
11992   }
11993   else {
11994     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11995   }
11996
11997   /* sys$check_access needs a file spec, not a directory spec.
11998    * flex_stat now will handle a null thread context during startup.
11999    */
12000
12001   retlen = namdsc.dsc$w_length = strlen(vmsname);
12002   if (vmsname[retlen-1] == ']'
12003       || vmsname[retlen-1] == '>'
12004       || vmsname[retlen-1] == ':'
12005       || (!flex_stat_int(vmsname, &st, 1) &&
12006           S_ISDIR(st.st_mode))) {
12007
12008       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12009         PerlMem_free(fileified);
12010         PerlMem_free(vmsname);
12011         return FALSE;
12012       }
12013       fname = fileified;
12014   }
12015   else {
12016       fname = vmsname;
12017   }
12018
12019   retlen = namdsc.dsc$w_length = strlen(fname);
12020   namdsc.dsc$a_pointer = (char *)fname;
12021
12022   switch (bit) {
12023     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12024       access = ARM$M_EXECUTE;
12025       flags = CHP$M_READ;
12026       break;
12027     case S_IRUSR: case S_IRGRP: case S_IROTH:
12028       access = ARM$M_READ;
12029       flags = CHP$M_READ | CHP$M_USEREADALL;
12030       break;
12031     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12032       access = ARM$M_WRITE;
12033       flags = CHP$M_READ | CHP$M_WRITE;
12034       break;
12035     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12036       access = ARM$M_DELETE;
12037       flags = CHP$M_READ | CHP$M_WRITE;
12038       break;
12039     default:
12040       if (fileified != NULL)
12041         PerlMem_free(fileified);
12042       if (vmsname != NULL)
12043         PerlMem_free(vmsname);
12044       return FALSE;
12045   }
12046
12047   /* Before we call $check_access, create a user profile with the current
12048    * process privs since otherwise it just uses the default privs from the
12049    * UAF and might give false positives or negatives.  This only works on
12050    * VMS versions v6.0 and later since that's when sys$create_user_profile
12051    * became available.
12052    */
12053
12054   /* get current process privs and username */
12055   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12056   _ckvmssts_noperl(iosb[0]);
12057
12058   /* find out the space required for the profile */
12059   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12060                                     &usrprodsc.dsc$w_length,&profile_context));
12061
12062   /* allocate space for the profile and get it filled in */
12063   usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
12064   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12065   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12066                                     &usrprodsc.dsc$w_length,&profile_context));
12067
12068   /* use the profile to check access to the file; free profile & analyze results */
12069   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12070   PerlMem_free(usrprodsc.dsc$a_pointer);
12071   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12072
12073   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12074       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12075       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12076     set_vaxc_errno(retsts);
12077     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12078     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12079     else set_errno(ENOENT);
12080     if (fileified != NULL)
12081       PerlMem_free(fileified);
12082     if (vmsname != NULL)
12083       PerlMem_free(vmsname);
12084     return FALSE;
12085   }
12086   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12087     if (fileified != NULL)
12088       PerlMem_free(fileified);
12089     if (vmsname != NULL)
12090       PerlMem_free(vmsname);
12091     return TRUE;
12092   }
12093   _ckvmssts_noperl(retsts);
12094
12095   if (fileified != NULL)
12096     PerlMem_free(fileified);
12097   if (vmsname != NULL)
12098     PerlMem_free(vmsname);
12099   return FALSE;  /* Should never get here */
12100
12101 }
12102
12103 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12104 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12105  * subset of the applicable information.
12106  */
12107 bool
12108 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12109 {
12110   return cando_by_name_int
12111         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12112 }  /* end of cando() */
12113 /*}}}*/
12114
12115
12116 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12117 I32
12118 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12119 {
12120    return cando_by_name_int(bit, effective, fname, 0);
12121
12122 }  /* end of cando_by_name() */
12123 /*}}}*/
12124
12125
12126 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12127 int
12128 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12129 {
12130   dSAVE_ERRNO; /* fstat may set this even on success */
12131   if (!fstat(fd, &statbufp->crtl_stat)) {
12132     char *cptr;
12133     char *vms_filename;
12134     vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12135     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12136
12137     /* Save name for cando by name in VMS format */
12138     cptr = getname(fd, vms_filename, 1);
12139
12140     /* This should not happen, but just in case */
12141     if (cptr == NULL) {
12142         statbufp->st_devnam[0] = 0;
12143     }
12144     else {
12145         /* Make sure that the saved name fits in 255 characters */
12146         cptr = int_rmsexpand_vms
12147                        (vms_filename,
12148                         statbufp->st_devnam,
12149                         0);
12150         if (cptr == NULL)
12151             statbufp->st_devnam[0] = 0;
12152     }
12153     PerlMem_free(vms_filename);
12154
12155     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12156     VMS_DEVICE_ENCODE
12157         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12158
12159 #   ifdef VMSISH_TIME
12160     if (VMSISH_TIME) {
12161       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12162       statbufp->st_atime = _toloc(statbufp->st_atime);
12163       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12164     }
12165 #   endif
12166     RESTORE_ERRNO;
12167     return 0;
12168   }
12169   return -1;
12170
12171 }  /* end of flex_fstat() */
12172 /*}}}*/
12173
12174 static int
12175 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12176 {
12177     char *temp_fspec = NULL;
12178     char *fileified = NULL;
12179     const char *save_spec;
12180     char *ret_spec;
12181     int retval = -1;
12182     char efs_hack = 0;
12183     char already_fileified = 0;
12184     dSAVEDERRNO;
12185
12186     if (!fspec) {
12187         errno = EINVAL;
12188         return retval;
12189     }
12190
12191     if (decc_bug_devnull != 0) {
12192       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12193         memset(statbufp,0,sizeof *statbufp);
12194         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12195         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12196         statbufp->st_uid = 0x00010001;
12197         statbufp->st_gid = 0x0001;
12198         time((time_t *)&statbufp->st_mtime);
12199         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12200         return 0;
12201       }
12202     }
12203
12204     SAVE_ERRNO;
12205
12206 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12207   /*
12208    * If we are in POSIX filespec mode, accept the filename as is.
12209    */
12210   if (decc_posix_compliant_pathnames == 0) {
12211 #endif
12212
12213     /* Try for a simple stat first.  If fspec contains a filename without
12214      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12215      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12216      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12217      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12218      * the file with null type, specify this by calling flex_stat() with
12219      * a '.' at the end of fspec.
12220      */
12221
12222     if (lstat_flag == 0)
12223         retval = stat(fspec, &statbufp->crtl_stat);
12224     else
12225         retval = lstat(fspec, &statbufp->crtl_stat);
12226
12227     if (!retval) {
12228         save_spec = fspec;
12229     }
12230     else {
12231         /* In the odd case where we have write but not read access
12232          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12233          */
12234         fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12235         if (fileified == NULL)
12236               _ckvmssts_noperl(SS$_INSFMEM);
12237
12238         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12239         if (ret_spec != NULL) {
12240             if (lstat_flag == 0)
12241                 retval = stat(fileified, &statbufp->crtl_stat);
12242             else
12243                 retval = lstat(fileified, &statbufp->crtl_stat);
12244             save_spec = fileified;
12245             already_fileified = 1;
12246         }
12247     }
12248
12249     if (retval && vms_bug_stat_filename) {
12250
12251         temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12252         if (temp_fspec == NULL)
12253             _ckvmssts_noperl(SS$_INSFMEM);
12254
12255         /* We should try again as a vmsified file specification. */
12256
12257         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12258         if (ret_spec != NULL) {
12259             if (lstat_flag == 0)
12260                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12261             else
12262                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12263             save_spec = temp_fspec;
12264         }
12265     }
12266
12267     if (retval) {
12268         /* Last chance - allow multiple dots without EFS CHARSET */
12269         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12270          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12271          * enable it if it isn't already.
12272          */
12273 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12274         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12275             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12276 #endif
12277         if (lstat_flag == 0)
12278             retval = stat(fspec, &statbufp->crtl_stat);
12279         else
12280             retval = lstat(fspec, &statbufp->crtl_stat);
12281         save_spec = fspec;
12282 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12283         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12284             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12285             efs_hack = 1;
12286         }
12287 #endif
12288     }
12289
12290 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12291   } else {
12292     if (lstat_flag == 0)
12293       retval = stat(temp_fspec, &statbufp->crtl_stat);
12294     else
12295       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12296       save_spec = temp_fspec;
12297   }
12298 #endif
12299
12300 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12301   /* As you were... */
12302   if (!decc_efs_charset)
12303     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12304 #endif
12305
12306     if (!retval) {
12307       char *cptr;
12308       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12309
12310       /* If this is an lstat, do not follow the link */
12311       if (lstat_flag)
12312         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12313
12314 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12315       /* If we used the efs_hack above, we must also use it here for */
12316       /* perl_cando to work */
12317       if (efs_hack && (decc_efs_charset_index > 0)) {
12318           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12319       }
12320 #endif
12321
12322       /* If we've got a directory, save a fileified, expanded version of it
12323        * in st_devnam.  If not a directory, just an expanded version.
12324        */
12325       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12326           fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12327           if (fileified == NULL)
12328               _ckvmssts_noperl(SS$_INSFMEM);
12329
12330           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12331           if (cptr != NULL)
12332               save_spec = fileified;
12333       }
12334
12335       cptr = int_rmsexpand(save_spec,
12336                            statbufp->st_devnam,
12337                            NULL,
12338                            rmsex_flags,
12339                            0,
12340                            0);
12341
12342 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12343       if (efs_hack && (decc_efs_charset_index > 0)) {
12344           decc$feature_set_value(decc_efs_charset, 1, 0);
12345       }
12346 #endif
12347
12348       /* Fix me: If this is NULL then stat found a file, and we could */
12349       /* not convert the specification to VMS - Should never happen */
12350       if (cptr == NULL)
12351         statbufp->st_devnam[0] = 0;
12352
12353       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12354       VMS_DEVICE_ENCODE
12355         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12356 #     ifdef VMSISH_TIME
12357       if (VMSISH_TIME) {
12358         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12359         statbufp->st_atime = _toloc(statbufp->st_atime);
12360         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12361       }
12362 #     endif
12363     }
12364     /* If we were successful, leave errno where we found it */
12365     if (retval == 0) RESTORE_ERRNO;
12366     if (temp_fspec)
12367         PerlMem_free(temp_fspec);
12368     if (fileified)
12369         PerlMem_free(fileified);
12370     return retval;
12371
12372 }  /* end of flex_stat_int() */
12373
12374
12375 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12376 int
12377 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12378 {
12379    return flex_stat_int(fspec, statbufp, 0);
12380 }
12381 /*}}}*/
12382
12383 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12384 int
12385 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12386 {
12387    return flex_stat_int(fspec, statbufp, 1);
12388 }
12389 /*}}}*/
12390
12391
12392 /*{{{char *my_getlogin()*/
12393 /* VMS cuserid == Unix getlogin, except calling sequence */
12394 char *
12395 my_getlogin(void)
12396 {
12397     static char user[L_cuserid];
12398     return cuserid(user);
12399 }
12400 /*}}}*/
12401
12402
12403 /*  rmscopy - copy a file using VMS RMS routines
12404  *
12405  *  Copies contents and attributes of spec_in to spec_out, except owner
12406  *  and protection information.  Name and type of spec_in are used as
12407  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12408  *  should try to propagate timestamps from the input file to the output file.
12409  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12410  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12411  *  propagated to the output file at creation iff the output file specification
12412  *  did not contain an explicit name or type, and the revision date is always
12413  *  updated at the end of the copy operation.  If it is greater than 0, then
12414  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12415  *  other than the revision date should be propagated, and bit 1 indicates
12416  *  that the revision date should be propagated.
12417  *
12418  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12419  *
12420  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12421  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12422  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12423  * as part of the Perl standard distribution under the terms of the
12424  * GNU General Public License or the Perl Artistic License.  Copies
12425  * of each may be found in the Perl standard distribution.
12426  */ /* FIXME */
12427 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12428 int
12429 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12430 {
12431     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12432          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12433     unsigned long int sts;
12434     int dna_len;
12435     struct FAB fab_in, fab_out;
12436     struct RAB rab_in, rab_out;
12437     rms_setup_nam(nam);
12438     rms_setup_nam(nam_out);
12439     struct XABDAT xabdat;
12440     struct XABFHC xabfhc;
12441     struct XABRDT xabrdt;
12442     struct XABSUM xabsum;
12443
12444     vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12445     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12446     vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12447     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12448     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12449         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12450       PerlMem_free(vmsin);
12451       PerlMem_free(vmsout);
12452       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12453       return 0;
12454     }
12455
12456     esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12457     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12458     esal = NULL;
12459 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12460     esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12461     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12462 #endif
12463     fab_in = cc$rms_fab;
12464     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12465     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12466     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12467     fab_in.fab$l_fop = FAB$M_SQO;
12468     rms_bind_fab_nam(fab_in, nam);
12469     fab_in.fab$l_xab = (void *) &xabdat;
12470
12471     rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12472     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12473     rsal = NULL;
12474 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12475     rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12476     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12477 #endif
12478     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12479     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12480     rms_nam_esl(nam) = 0;
12481     rms_nam_rsl(nam) = 0;
12482     rms_nam_esll(nam) = 0;
12483     rms_nam_rsll(nam) = 0;
12484 #ifdef NAM$M_NO_SHORT_UPCASE
12485     if (decc_efs_case_preserve)
12486         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12487 #endif
12488
12489     xabdat = cc$rms_xabdat;        /* To get creation date */
12490     xabdat.xab$l_nxt = (void *) &xabfhc;
12491
12492     xabfhc = cc$rms_xabfhc;        /* To get record length */
12493     xabfhc.xab$l_nxt = (void *) &xabsum;
12494
12495     xabsum = cc$rms_xabsum;        /* To get key and area information */
12496
12497     if (!((sts = sys$open(&fab_in)) & 1)) {
12498       PerlMem_free(vmsin);
12499       PerlMem_free(vmsout);
12500       PerlMem_free(esa);
12501       if (esal != NULL)
12502         PerlMem_free(esal);
12503       PerlMem_free(rsa);
12504       if (rsal != NULL)
12505         PerlMem_free(rsal);
12506       set_vaxc_errno(sts);
12507       switch (sts) {
12508         case RMS$_FNF: case RMS$_DNF:
12509           set_errno(ENOENT); break;
12510         case RMS$_DIR:
12511           set_errno(ENOTDIR); break;
12512         case RMS$_DEV:
12513           set_errno(ENODEV); break;
12514         case RMS$_SYN:
12515           set_errno(EINVAL); break;
12516         case RMS$_PRV:
12517           set_errno(EACCES); break;
12518         default:
12519           set_errno(EVMSERR);
12520       }
12521       return 0;
12522     }
12523
12524     nam_out = nam;
12525     fab_out = fab_in;
12526     fab_out.fab$w_ifi = 0;
12527     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12528     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12529     fab_out.fab$l_fop = FAB$M_SQO;
12530     rms_bind_fab_nam(fab_out, nam_out);
12531     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12532     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12533     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12534     esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12535     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12536     rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12537     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12538     esal_out = NULL;
12539     rsal_out = NULL;
12540 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12541     esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12542     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12543     rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12544     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12545 #endif
12546     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12547     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12548
12549     if (preserve_dates == 0) {  /* Act like DCL COPY */
12550       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12551       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12552       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12553         PerlMem_free(vmsin);
12554         PerlMem_free(vmsout);
12555         PerlMem_free(esa);
12556         if (esal != NULL)
12557             PerlMem_free(esal);
12558         PerlMem_free(rsa);
12559         if (rsal != NULL)
12560             PerlMem_free(rsal);
12561         PerlMem_free(esa_out);
12562         if (esal_out != NULL)
12563             PerlMem_free(esal_out);
12564         PerlMem_free(rsa_out);
12565         if (rsal_out != NULL)
12566             PerlMem_free(rsal_out);
12567         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12568         set_vaxc_errno(sts);
12569         return 0;
12570       }
12571       fab_out.fab$l_xab = (void *) &xabdat;
12572       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12573         preserve_dates = 1;
12574     }
12575     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12576       preserve_dates =0;      /* bitmask from this point forward   */
12577
12578     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12579     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12580       PerlMem_free(vmsin);
12581       PerlMem_free(vmsout);
12582       PerlMem_free(esa);
12583       if (esal != NULL)
12584           PerlMem_free(esal);
12585       PerlMem_free(rsa);
12586       if (rsal != NULL)
12587           PerlMem_free(rsal);
12588       PerlMem_free(esa_out);
12589       if (esal_out != NULL)
12590           PerlMem_free(esal_out);
12591       PerlMem_free(rsa_out);
12592       if (rsal_out != NULL)
12593           PerlMem_free(rsal_out);
12594       set_vaxc_errno(sts);
12595       switch (sts) {
12596         case RMS$_DNF:
12597           set_errno(ENOENT); break;
12598         case RMS$_DIR:
12599           set_errno(ENOTDIR); break;
12600         case RMS$_DEV:
12601           set_errno(ENODEV); break;
12602         case RMS$_SYN:
12603           set_errno(EINVAL); break;
12604         case RMS$_PRV:
12605           set_errno(EACCES); break;
12606         default:
12607           set_errno(EVMSERR);
12608       }
12609       return 0;
12610     }
12611     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12612     if (preserve_dates & 2) {
12613       /* sys$close() will process xabrdt, not xabdat */
12614       xabrdt = cc$rms_xabrdt;
12615 #ifndef __GNUC__
12616       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12617 #else
12618       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12619        * is unsigned long[2], while DECC & VAXC use a struct */
12620       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12621 #endif
12622       fab_out.fab$l_xab = (void *) &xabrdt;
12623     }
12624
12625     ubf = (char *)PerlMem_malloc(32256);
12626     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12627     rab_in = cc$rms_rab;
12628     rab_in.rab$l_fab = &fab_in;
12629     rab_in.rab$l_rop = RAB$M_BIO;
12630     rab_in.rab$l_ubf = ubf;
12631     rab_in.rab$w_usz = 32256;
12632     if (!((sts = sys$connect(&rab_in)) & 1)) {
12633       sys$close(&fab_in); sys$close(&fab_out);
12634       PerlMem_free(vmsin);
12635       PerlMem_free(vmsout);
12636       PerlMem_free(ubf);
12637       PerlMem_free(esa);
12638       if (esal != NULL)
12639           PerlMem_free(esal);
12640       PerlMem_free(rsa);
12641       if (rsal != NULL)
12642           PerlMem_free(rsal);
12643       PerlMem_free(esa_out);
12644       if (esal_out != NULL)
12645           PerlMem_free(esal_out);
12646       PerlMem_free(rsa_out);
12647       if (rsal_out != NULL)
12648           PerlMem_free(rsal_out);
12649       set_errno(EVMSERR); set_vaxc_errno(sts);
12650       return 0;
12651     }
12652
12653     rab_out = cc$rms_rab;
12654     rab_out.rab$l_fab = &fab_out;
12655     rab_out.rab$l_rbf = ubf;
12656     if (!((sts = sys$connect(&rab_out)) & 1)) {
12657       sys$close(&fab_in); sys$close(&fab_out);
12658       PerlMem_free(vmsin);
12659       PerlMem_free(vmsout);
12660       PerlMem_free(ubf);
12661       PerlMem_free(esa);
12662       if (esal != NULL)
12663           PerlMem_free(esal);
12664       PerlMem_free(rsa);
12665       if (rsal != NULL)
12666           PerlMem_free(rsal);
12667       PerlMem_free(esa_out);
12668       if (esal_out != NULL)
12669           PerlMem_free(esal_out);
12670       PerlMem_free(rsa_out);
12671       if (rsal_out != NULL)
12672           PerlMem_free(rsal_out);
12673       set_errno(EVMSERR); set_vaxc_errno(sts);
12674       return 0;
12675     }
12676
12677     while ((sts = sys$read(&rab_in))) {  /* always true  */
12678       if (sts == RMS$_EOF) break;
12679       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12680       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12681         sys$close(&fab_in); sys$close(&fab_out);
12682         PerlMem_free(vmsin);
12683         PerlMem_free(vmsout);
12684         PerlMem_free(ubf);
12685         PerlMem_free(esa);
12686         if (esal != NULL)
12687             PerlMem_free(esal);
12688         PerlMem_free(rsa);
12689         if (rsal != NULL)
12690             PerlMem_free(rsal);
12691         PerlMem_free(esa_out);
12692         if (esal_out != NULL)
12693             PerlMem_free(esal_out);
12694         PerlMem_free(rsa_out);
12695         if (rsal_out != NULL)
12696             PerlMem_free(rsal_out);
12697         set_errno(EVMSERR); set_vaxc_errno(sts);
12698         return 0;
12699       }
12700     }
12701
12702
12703     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12704     sys$close(&fab_in);  sys$close(&fab_out);
12705     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12706
12707     PerlMem_free(vmsin);
12708     PerlMem_free(vmsout);
12709     PerlMem_free(ubf);
12710     PerlMem_free(esa);
12711     if (esal != NULL)
12712         PerlMem_free(esal);
12713     PerlMem_free(rsa);
12714     if (rsal != NULL)
12715         PerlMem_free(rsal);
12716     PerlMem_free(esa_out);
12717     if (esal_out != NULL)
12718         PerlMem_free(esal_out);
12719     PerlMem_free(rsa_out);
12720     if (rsal_out != NULL)
12721         PerlMem_free(rsal_out);
12722
12723     if (!(sts & 1)) {
12724       set_errno(EVMSERR); set_vaxc_errno(sts);
12725       return 0;
12726     }
12727
12728     return 1;
12729
12730 }  /* end of rmscopy() */
12731 /*}}}*/
12732
12733
12734 /***  The following glue provides 'hooks' to make some of the routines
12735  * from this file available from Perl.  These routines are sufficiently
12736  * basic, and are required sufficiently early in the build process,
12737  * that's it's nice to have them available to miniperl as well as the
12738  * full Perl, so they're set up here instead of in an extension.  The
12739  * Perl code which handles importation of these names into a given
12740  * package lives in [.VMS]Filespec.pm in @INC.
12741  */
12742
12743 void
12744 rmsexpand_fromperl(pTHX_ CV *cv)
12745 {
12746   dXSARGS;
12747   char *fspec, *defspec = NULL, *rslt;
12748   STRLEN n_a;
12749   int fs_utf8, dfs_utf8;
12750
12751   fs_utf8 = 0;
12752   dfs_utf8 = 0;
12753   if (!items || items > 2)
12754     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12755   fspec = SvPV(ST(0),n_a);
12756   fs_utf8 = SvUTF8(ST(0));
12757   if (!fspec || !*fspec) XSRETURN_UNDEF;
12758   if (items == 2) {
12759     defspec = SvPV(ST(1),n_a);
12760     dfs_utf8 = SvUTF8(ST(1));
12761   }
12762   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12763   ST(0) = sv_newmortal();
12764   if (rslt != NULL) {
12765     sv_usepvn(ST(0),rslt,strlen(rslt));
12766     if (fs_utf8) {
12767         SvUTF8_on(ST(0));
12768     }
12769   }
12770   XSRETURN(1);
12771 }
12772
12773 void
12774 vmsify_fromperl(pTHX_ CV *cv)
12775 {
12776   dXSARGS;
12777   char *vmsified;
12778   STRLEN n_a;
12779   int utf8_fl;
12780
12781   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12782   utf8_fl = SvUTF8(ST(0));
12783   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12784   ST(0) = sv_newmortal();
12785   if (vmsified != NULL) {
12786     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12787     if (utf8_fl) {
12788         SvUTF8_on(ST(0));
12789     }
12790   }
12791   XSRETURN(1);
12792 }
12793
12794 void
12795 unixify_fromperl(pTHX_ CV *cv)
12796 {
12797   dXSARGS;
12798   char *unixified;
12799   STRLEN n_a;
12800   int utf8_fl;
12801
12802   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12803   utf8_fl = SvUTF8(ST(0));
12804   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12805   ST(0) = sv_newmortal();
12806   if (unixified != NULL) {
12807     sv_usepvn(ST(0),unixified,strlen(unixified));
12808     if (utf8_fl) {
12809         SvUTF8_on(ST(0));
12810     }
12811   }
12812   XSRETURN(1);
12813 }
12814
12815 void
12816 fileify_fromperl(pTHX_ CV *cv)
12817 {
12818   dXSARGS;
12819   char *fileified;
12820   STRLEN n_a;
12821   int utf8_fl;
12822
12823   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12824   utf8_fl = SvUTF8(ST(0));
12825   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12826   ST(0) = sv_newmortal();
12827   if (fileified != NULL) {
12828     sv_usepvn(ST(0),fileified,strlen(fileified));
12829     if (utf8_fl) {
12830         SvUTF8_on(ST(0));
12831     }
12832   }
12833   XSRETURN(1);
12834 }
12835
12836 void
12837 pathify_fromperl(pTHX_ CV *cv)
12838 {
12839   dXSARGS;
12840   char *pathified;
12841   STRLEN n_a;
12842   int utf8_fl;
12843
12844   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12845   utf8_fl = SvUTF8(ST(0));
12846   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12847   ST(0) = sv_newmortal();
12848   if (pathified != NULL) {
12849     sv_usepvn(ST(0),pathified,strlen(pathified));
12850     if (utf8_fl) {
12851         SvUTF8_on(ST(0));
12852     }
12853   }
12854   XSRETURN(1);
12855 }
12856
12857 void
12858 vmspath_fromperl(pTHX_ CV *cv)
12859 {
12860   dXSARGS;
12861   char *vmspath;
12862   STRLEN n_a;
12863   int utf8_fl;
12864
12865   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12866   utf8_fl = SvUTF8(ST(0));
12867   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12868   ST(0) = sv_newmortal();
12869   if (vmspath != NULL) {
12870     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12871     if (utf8_fl) {
12872         SvUTF8_on(ST(0));
12873     }
12874   }
12875   XSRETURN(1);
12876 }
12877
12878 void
12879 unixpath_fromperl(pTHX_ CV *cv)
12880 {
12881   dXSARGS;
12882   char *unixpath;
12883   STRLEN n_a;
12884   int utf8_fl;
12885
12886   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12887   utf8_fl = SvUTF8(ST(0));
12888   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12889   ST(0) = sv_newmortal();
12890   if (unixpath != NULL) {
12891     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12892     if (utf8_fl) {
12893         SvUTF8_on(ST(0));
12894     }
12895   }
12896   XSRETURN(1);
12897 }
12898
12899 void
12900 candelete_fromperl(pTHX_ CV *cv)
12901 {
12902   dXSARGS;
12903   char *fspec, *fsp;
12904   SV *mysv;
12905   IO *io;
12906   STRLEN n_a;
12907
12908   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12909
12910   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12911   Newx(fspec, VMS_MAXRSS, char);
12912   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12913   if (isGV_with_GP(mysv)) {
12914     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12915       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12916       ST(0) = &PL_sv_no;
12917       Safefree(fspec);
12918       XSRETURN(1);
12919     }
12920     fsp = fspec;
12921   }
12922   else {
12923     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12924       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12925       ST(0) = &PL_sv_no;
12926       Safefree(fspec);
12927       XSRETURN(1);
12928     }
12929   }
12930
12931   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12932   Safefree(fspec);
12933   XSRETURN(1);
12934 }
12935
12936 void
12937 rmscopy_fromperl(pTHX_ CV *cv)
12938 {
12939   dXSARGS;
12940   char *inspec, *outspec, *inp, *outp;
12941   int date_flag;
12942   SV *mysv;
12943   IO *io;
12944   STRLEN n_a;
12945
12946   if (items < 2 || items > 3)
12947     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12948
12949   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12950   Newx(inspec, VMS_MAXRSS, char);
12951   if (isGV_with_GP(mysv)) {
12952     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12953       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12954       ST(0) = sv_2mortal(newSViv(0));
12955       Safefree(inspec);
12956       XSRETURN(1);
12957     }
12958     inp = inspec;
12959   }
12960   else {
12961     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12962       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12963       ST(0) = sv_2mortal(newSViv(0));
12964       Safefree(inspec);
12965       XSRETURN(1);
12966     }
12967   }
12968   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12969   Newx(outspec, VMS_MAXRSS, char);
12970   if (isGV_with_GP(mysv)) {
12971     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12972       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12973       ST(0) = sv_2mortal(newSViv(0));
12974       Safefree(inspec);
12975       Safefree(outspec);
12976       XSRETURN(1);
12977     }
12978     outp = outspec;
12979   }
12980   else {
12981     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12982       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12983       ST(0) = sv_2mortal(newSViv(0));
12984       Safefree(inspec);
12985       Safefree(outspec);
12986       XSRETURN(1);
12987     }
12988   }
12989   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12990
12991   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12992   Safefree(inspec);
12993   Safefree(outspec);
12994   XSRETURN(1);
12995 }
12996
12997 /* The mod2fname is limited to shorter filenames by design, so it should
12998  * not be modified to support longer EFS pathnames
12999  */
13000 void
13001 mod2fname(pTHX_ CV *cv)
13002 {
13003   dXSARGS;
13004   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13005        workbuff[NAM$C_MAXRSS*1 + 1];
13006   SSize_t counter, num_entries;
13007   /* ODS-5 ups this, but we want to be consistent, so... */
13008   int max_name_len = 39;
13009   AV *in_array = (AV *)SvRV(ST(0));
13010
13011   num_entries = av_tindex(in_array);
13012
13013   /* All the names start with PL_. */
13014   strcpy(ultimate_name, "PL_");
13015
13016   /* Clean up our working buffer */
13017   Zero(work_name, sizeof(work_name), char);
13018
13019   /* Run through the entries and build up a working name */
13020   for(counter = 0; counter <= num_entries; counter++) {
13021     /* If it's not the first name then tack on a __ */
13022     if (counter) {
13023       my_strlcat(work_name, "__", sizeof(work_name));
13024     }
13025     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
13026   }
13027
13028   /* Check to see if we actually have to bother...*/
13029   if (strlen(work_name) + 3 <= max_name_len) {
13030     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
13031   } else {
13032     /* It's too darned big, so we need to go strip. We use the same */
13033     /* algorithm as xsubpp does. First, strip out doubled __ */
13034     char *source, *dest, last;
13035     dest = workbuff;
13036     last = 0;
13037     for (source = work_name; *source; source++) {
13038       if (last == *source && last == '_') {
13039         continue;
13040       }
13041       *dest++ = *source;
13042       last = *source;
13043     }
13044     /* Go put it back */
13045     my_strlcpy(work_name, workbuff, sizeof(work_name));
13046     /* Is it still too big? */
13047     if (strlen(work_name) + 3 > max_name_len) {
13048       /* Strip duplicate letters */
13049       last = 0;
13050       dest = workbuff;
13051       for (source = work_name; *source; source++) {
13052         if (last == toupper(*source)) {
13053         continue;
13054         }
13055         *dest++ = *source;
13056         last = toupper(*source);
13057       }
13058       my_strlcpy(work_name, workbuff, sizeof(work_name));
13059     }
13060
13061     /* Is it *still* too big? */
13062     if (strlen(work_name) + 3 > max_name_len) {
13063       /* Too bad, we truncate */
13064       work_name[max_name_len - 2] = 0;
13065     }
13066     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
13067   }
13068
13069   /* Okay, return it */
13070   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13071   XSRETURN(1);
13072 }
13073
13074 void
13075 hushexit_fromperl(pTHX_ CV *cv)
13076 {
13077     dXSARGS;
13078
13079     if (items > 0) {
13080         VMSISH_HUSHED = SvTRUE(ST(0));
13081     }
13082     ST(0) = boolSV(VMSISH_HUSHED);
13083     XSRETURN(1);
13084 }
13085
13086
13087 PerlIO *
13088 Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io)
13089 {
13090     PerlIO *fp;
13091     struct vs_str_st *rslt;
13092     char *vmsspec;
13093     char *rstr;
13094     char *begin, *cp;
13095     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13096     PerlIO *tmpfp;
13097     STRLEN i;
13098     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13099     struct dsc$descriptor_vs rsdsc;
13100     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13101     unsigned long hasver = 0, isunix = 0;
13102     unsigned long int lff_flags = 0;
13103     int rms_sts;
13104     int vms_old_glob = 1;
13105
13106     if (!SvOK(tmpglob)) {
13107         SETERRNO(ENOENT,RMS$_FNF);
13108         return NULL;
13109     }
13110
13111     vms_old_glob = !decc_filename_unix_report;
13112
13113 #ifdef VMS_LONGNAME_SUPPORT
13114     lff_flags = LIB$M_FIL_LONG_NAMES;
13115 #endif
13116     /* The Newx macro will not allow me to assign a smaller array
13117      * to the rslt pointer, so we will assign it to the begin char pointer
13118      * and then copy the value into the rslt pointer.
13119      */
13120     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13121     rslt = (struct vs_str_st *)begin;
13122     rslt->length = 0;
13123     rstr = &rslt->str[0];
13124     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13125     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13126     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13127     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13128
13129     Newx(vmsspec, VMS_MAXRSS, char);
13130
13131         /* We could find out if there's an explicit dev/dir or version
13132            by peeking into lib$find_file's internal context at
13133            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13134            but that's unsupported, so I don't want to do it now and
13135            have it bite someone in the future. */
13136         /* Fix-me: vms_split_path() is the only way to do this, the
13137            existing method will fail with many legal EFS or UNIX specifications
13138          */
13139
13140     cp = SvPV(tmpglob,i);
13141
13142     for (; i; i--) {
13143         if (cp[i] == ';') hasver = 1;
13144         if (cp[i] == '.') {
13145             if (sts) hasver = 1;
13146             else sts = 1;
13147         }
13148         if (cp[i] == '/') {
13149             hasdir = isunix = 1;
13150             break;
13151         }
13152         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13153             hasdir = 1;
13154             break;
13155         }
13156     }
13157
13158     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13159     if ((hasdir == 0) && decc_filename_unix_report) {
13160         isunix = 1;
13161     }
13162
13163     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13164         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13165         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13166         int wildstar = 0;
13167         int wildquery = 0;
13168         int found = 0;
13169         Stat_t st;
13170         int stat_sts;
13171         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13172         if (!stat_sts && S_ISDIR(st.st_mode)) {
13173             char * vms_dir;
13174             const char * fname;
13175             STRLEN fname_len;
13176
13177             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13178             /* path delimiter of ':>]', if so, then the old behavior has */
13179             /* obviously been specifically requested */
13180
13181             fname = SvPVX_const(tmpglob);
13182             fname_len = strlen(fname);
13183             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13184             if (vms_old_glob || (vms_dir != NULL)) {
13185                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13186                                             SvPVX(tmpglob),vmsspec,NULL);
13187                 ok = (wilddsc.dsc$a_pointer != NULL);
13188                 /* maybe passed 'foo' rather than '[.foo]', thus not
13189                    detected above */
13190                 hasdir = 1;
13191             } else {
13192                 /* Operate just on the directory, the special stat/fstat for */
13193                 /* leaves the fileified  specification in the st_devnam */
13194                 /* member. */
13195                 wilddsc.dsc$a_pointer = st.st_devnam;
13196                 ok = 1;
13197             }
13198         }
13199         else {
13200             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13201             ok = (wilddsc.dsc$a_pointer != NULL);
13202         }
13203         if (ok)
13204             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13205
13206         /* If not extended character set, replace ? with % */
13207         /* With extended character set, ? is a wildcard single character */
13208         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13209             if (*cp == '?') {
13210                 wildquery = 1;
13211                 if (!decc_efs_charset)
13212                     *cp = '%';
13213             } else if (*cp == '%') {
13214                 wildquery = 1;
13215             } else if (*cp == '*') {
13216                 wildstar = 1;
13217             }
13218         }
13219
13220         if (ok) {
13221             wv_sts = vms_split_path(
13222                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13223                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13224                 &wvs_spec, &wvs_len);
13225         } else {
13226             wn_spec = NULL;
13227             wn_len = 0;
13228             we_spec = NULL;
13229             we_len = 0;
13230         }
13231
13232         sts = SS$_NORMAL;
13233         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13234          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13235          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13236          int valid_find;
13237
13238             valid_find = 0;
13239             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13240                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13241             if (!$VMS_STATUS_SUCCESS(sts))
13242                 break;
13243
13244             /* with varying string, 1st word of buffer contains result length */
13245             rstr[rslt->length] = '\0';
13246
13247              /* Find where all the components are */
13248              v_sts = vms_split_path
13249                        (rstr,
13250                         &v_spec,
13251                         &v_len,
13252                         &r_spec,
13253                         &r_len,
13254                         &d_spec,
13255                         &d_len,
13256                         &n_spec,
13257                         &n_len,
13258                         &e_spec,
13259                         &e_len,
13260                         &vs_spec,
13261                         &vs_len);
13262
13263             /* If no version on input, truncate the version on output */
13264             if (!hasver && (vs_len > 0)) {
13265                 *vs_spec = '\0';
13266                 vs_len = 0;
13267             }
13268
13269             if (isunix) {
13270
13271                 /* In Unix report mode, remove the ".dir;1" from the name */
13272                 /* if it is a real directory */
13273                 if (decc_filename_unix_report && decc_efs_charset) {
13274                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13275                         Stat_t statbuf;
13276                         int ret_sts;
13277
13278                         ret_sts = flex_lstat(rstr, &statbuf);
13279                         if ((ret_sts == 0) &&
13280                             S_ISDIR(statbuf.st_mode)) {
13281                             e_len = 0;
13282                             e_spec[0] = 0;
13283                         }
13284                     }
13285                 }
13286
13287                 /* No version & a null extension on UNIX handling */
13288                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13289                     e_len = 0;
13290                     *e_spec = '\0';
13291                 }
13292             }
13293
13294             if (!decc_efs_case_preserve) {
13295                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13296             }
13297
13298             /* Find File treats a Null extension as return all extensions */
13299             /* This is contrary to Perl expectations */
13300
13301             if (wildstar || wildquery || vms_old_glob) {
13302                 /* really need to see if the returned file name matched */
13303                 /* but for now will assume that it matches */
13304                 valid_find = 1;
13305             } else {
13306                 /* Exact Match requested */
13307                 /* How are directories handled? - like a file */
13308                 if ((e_len == we_len) && (n_len == wn_len)) {
13309                     int t1;
13310                     t1 = e_len;
13311                     if (t1 > 0)
13312                         t1 = strncmp(e_spec, we_spec, e_len);
13313                     if (t1 == 0) {
13314                        t1 = n_len;
13315                        if (t1 > 0)
13316                            t1 = strncmp(n_spec, we_spec, n_len);
13317                        if (t1 == 0)
13318                            valid_find = 1;
13319                     }
13320                 }
13321             }
13322
13323             if (valid_find) {
13324                 found++;
13325
13326                 if (hasdir) {
13327                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13328                     begin = rstr;
13329                 }
13330                 else {
13331                     /* Start with the name */
13332                     begin = n_spec;
13333                 }
13334                 strcat(begin,"\n");
13335                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13336             }
13337         }
13338         if (cxt) (void)lib$find_file_end(&cxt);
13339
13340         if (!found) {
13341             /* Be POSIXish: return the input pattern when no matches */
13342             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13343             strcat(rstr,"\n");
13344             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13345         }
13346
13347         if (ok && sts != RMS$_NMF &&
13348             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13349         if (!ok) {
13350             if (!(sts & 1)) {
13351                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13352             }
13353             PerlIO_close(tmpfp);
13354             fp = NULL;
13355         }
13356         else {
13357             PerlIO_rewind(tmpfp);
13358             IoTYPE(io) = IoTYPE_RDONLY;
13359             IoIFP(io) = fp = tmpfp;
13360             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13361         }
13362     }
13363     Safefree(vmsspec);
13364     Safefree(rslt);
13365     return fp;
13366 }
13367
13368
13369 static char *
13370 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13371                    int *utf8_fl);
13372
13373 void
13374 unixrealpath_fromperl(pTHX_ CV *cv)
13375 {
13376     dXSARGS;
13377     char *fspec, *rslt_spec, *rslt;
13378     STRLEN n_a;
13379
13380     if (!items || items != 1)
13381         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13382
13383     fspec = SvPV(ST(0),n_a);
13384     if (!fspec || !*fspec) XSRETURN_UNDEF;
13385
13386     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13387     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13388
13389     ST(0) = sv_newmortal();
13390     if (rslt != NULL)
13391         sv_usepvn(ST(0),rslt,strlen(rslt));
13392     else
13393         Safefree(rslt_spec);
13394         XSRETURN(1);
13395 }
13396
13397 static char *
13398 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13399                    int *utf8_fl);
13400
13401 void
13402 vmsrealpath_fromperl(pTHX_ CV *cv)
13403 {
13404     dXSARGS;
13405     char *fspec, *rslt_spec, *rslt;
13406     STRLEN n_a;
13407
13408     if (!items || items != 1)
13409         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13410
13411     fspec = SvPV(ST(0),n_a);
13412     if (!fspec || !*fspec) XSRETURN_UNDEF;
13413
13414     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13415     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13416
13417     ST(0) = sv_newmortal();
13418     if (rslt != NULL)
13419         sv_usepvn(ST(0),rslt,strlen(rslt));
13420     else
13421         Safefree(rslt_spec);
13422         XSRETURN(1);
13423 }
13424
13425 #ifdef HAS_SYMLINK
13426 /*
13427  * A thin wrapper around decc$symlink to make sure we follow the
13428  * standard and do not create a symlink with a zero-length name,
13429  * and convert the target to Unix format, as the CRTL can't handle
13430  * targets in VMS format.
13431  */
13432 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13433 int
13434 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13435 {
13436     int sts;
13437     char * utarget;
13438
13439     if (!link_name || !*link_name) {
13440       SETERRNO(ENOENT, SS$_NOSUCHFILE);
13441       return -1;
13442     }
13443
13444     utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13445     /* An untranslatable filename should be passed through. */
13446     (void) int_tounixspec(contents, utarget, NULL);
13447     sts = symlink(utarget, link_name);
13448     PerlMem_free(utarget);
13449     return sts;
13450 }
13451 /*}}}*/
13452
13453 #endif /* HAS_SYMLINK */
13454
13455 int do_vms_case_tolerant(void);
13456
13457 void
13458 case_tolerant_process_fromperl(pTHX_ CV *cv)
13459 {
13460   dXSARGS;
13461   ST(0) = boolSV(do_vms_case_tolerant());
13462   XSRETURN(1);
13463 }
13464
13465 #ifdef USE_ITHREADS
13466
13467 void
13468 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13469                           struct interp_intern *dst)
13470 {
13471     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13472
13473     memcpy(dst,src,sizeof(struct interp_intern));
13474 }
13475
13476 #endif
13477
13478 void
13479 Perl_sys_intern_clear(pTHX)
13480 {
13481 }
13482
13483 void
13484 Perl_sys_intern_init(pTHX)
13485 {
13486     unsigned int ix = RAND_MAX;
13487     double x;
13488
13489     VMSISH_HUSHED = 0;
13490
13491     MY_POSIX_EXIT = vms_posix_exit;
13492
13493     x = (float)ix;
13494     MY_INV_RAND_MAX = 1./x;
13495 }
13496
13497 void
13498 init_os_extras(void)
13499 {
13500   dTHX;
13501   char* file = __FILE__;
13502   if (decc_disable_to_vms_logname_translation) {
13503     no_translate_barewords = TRUE;
13504   } else {
13505     no_translate_barewords = FALSE;
13506   }
13507
13508   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13509   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13510   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13511   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13512   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13513   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13514   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13515   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13516   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13517   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13518   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13519   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13520   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13521   newXSproto("VMS::Filespec::case_tolerant_process",
13522       case_tolerant_process_fromperl,file,"");
13523
13524   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13525
13526   return;
13527 }
13528
13529 #if __CRTL_VER == 80200000
13530 /* This missed getting in to the DECC SDK for 8.2 */
13531 char *realpath(const char *file_name, char * resolved_name, ...);
13532 #endif
13533
13534 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13535 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13536  * The perl fallback routine to provide realpath() is not as efficient
13537  * on OpenVMS.
13538  */
13539
13540 #ifdef __cplusplus
13541 extern "C" {
13542 #endif
13543
13544 /* Hack, use old stat() as fastest way of getting ino_t and device */
13545 int decc$stat(const char *name, void * statbuf);
13546 #if !defined(__VAX) && __CRTL_VER >= 80200000
13547 int decc$lstat(const char *name, void * statbuf);
13548 #else
13549 #define decc$lstat decc$stat
13550 #endif
13551
13552 #ifdef __cplusplus
13553 }
13554 #endif
13555
13556
13557 /* Realpath is fragile.  In 8.3 it does not work if the feature
13558  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13559  * links are implemented in RMS, not the CRTL. It also can fail if the
13560  * user does not have read/execute access to some of the directories.
13561  * So in order for Do What I Mean mode to work, if realpath() fails,
13562  * fall back to looking up the filename by the device name and FID.
13563  */
13564
13565 int vms_fid_to_name(char * outname, int outlen,
13566                     const char * name, int lstat_flag, mode_t * mode)
13567 {
13568 #pragma message save
13569 #pragma message disable MISALGNDSTRCT
13570 #pragma message disable MISALGNDMEM
13571 #pragma member_alignment save
13572 #pragma nomember_alignment
13573     struct statbuf_t {
13574         char       * st_dev;
13575         unsigned short st_ino[3];
13576         unsigned short old_st_mode;
13577         unsigned long  padl[30];  /* plenty of room */
13578     } statbuf;
13579 #pragma message restore
13580 #pragma member_alignment restore
13581
13582     int sts;
13583     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13584     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13585     char *fileified;
13586     char *temp_fspec;
13587     char *ret_spec;
13588
13589     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13590      * unexpected answers
13591      */
13592
13593     fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13594     if (fileified == NULL)
13595         _ckvmssts_noperl(SS$_INSFMEM);
13596
13597     temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13598     if (temp_fspec == NULL)
13599         _ckvmssts_noperl(SS$_INSFMEM);
13600
13601     sts = -1;
13602     /* First need to try as a directory */
13603     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13604     if (ret_spec != NULL) {
13605         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13606         if (ret_spec != NULL) {
13607             if (lstat_flag == 0)
13608                 sts = decc$stat(fileified, &statbuf);
13609             else
13610                 sts = decc$lstat(fileified, &statbuf);
13611         }
13612     }
13613
13614     /* Then as a VMS file spec */
13615     if (sts != 0) {
13616         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13617         if (ret_spec != NULL) {
13618             if (lstat_flag == 0) {
13619                 sts = decc$stat(temp_fspec, &statbuf);
13620             } else {
13621                 sts = decc$lstat(temp_fspec, &statbuf);
13622             }
13623         }
13624     }
13625
13626     if (sts) {
13627         /* Next try - allow multiple dots with out EFS CHARSET */
13628         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13629          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13630          * enable it if it isn't already.
13631          */
13632 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13633         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13634             decc$feature_set_value(decc_efs_charset_index, 1, 1);
13635 #endif
13636         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13637         if (lstat_flag == 0) {
13638             sts = decc$stat(name, &statbuf);
13639         } else {
13640             sts = decc$lstat(name, &statbuf);
13641         }
13642 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13643         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13644             decc$feature_set_value(decc_efs_charset_index, 1, 0);
13645 #endif
13646     }
13647
13648
13649     /* and then because the Perl Unix to VMS conversion is not perfect */
13650     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13651     /* characters from filenames so we need to try it as-is */
13652     if (sts) {
13653         if (lstat_flag == 0) {
13654             sts = decc$stat(name, &statbuf);
13655         } else {
13656             sts = decc$lstat(name, &statbuf);
13657         }
13658     }
13659
13660     if (sts == 0) {
13661         int vms_sts;
13662
13663         dvidsc.dsc$a_pointer=statbuf.st_dev;
13664         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13665
13666         specdsc.dsc$a_pointer = outname;
13667         specdsc.dsc$w_length = outlen-1;
13668
13669         vms_sts = lib$fid_to_name
13670             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13671         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13672             outname[specdsc.dsc$w_length] = 0;
13673
13674             /* Return the mode */
13675             if (mode) {
13676                 *mode = statbuf.old_st_mode;
13677             }
13678         }
13679     }
13680     PerlMem_free(temp_fspec);
13681     PerlMem_free(fileified);
13682     return sts;
13683 }
13684
13685
13686
13687 static char *
13688 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13689                    int *utf8_fl)
13690 {
13691     char * rslt = NULL;
13692
13693 #ifdef HAS_SYMLINK
13694     if (decc_posix_compliant_pathnames > 0 ) {
13695         /* realpath currently only works if posix compliant pathnames are
13696          * enabled.  It may start working when they are not, but in that
13697          * case we still want the fallback behavior for backwards compatibility
13698          */
13699         rslt = realpath(filespec, outbuf);
13700     }
13701 #endif
13702
13703     if (rslt == NULL) {
13704         char * vms_spec;
13705         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13706         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13707         mode_t my_mode;
13708
13709         /* Fall back to fid_to_name */
13710
13711         Newx(vms_spec, VMS_MAXRSS + 1, char);
13712
13713         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13714         if (sts == 0) {
13715
13716
13717             /* Now need to trim the version off */
13718             sts = vms_split_path
13719                   (vms_spec,
13720                    &v_spec,
13721                    &v_len,
13722                    &r_spec,
13723                    &r_len,
13724                    &d_spec,
13725                    &d_len,
13726                    &n_spec,
13727                    &n_len,
13728                    &e_spec,
13729                    &e_len,
13730                    &vs_spec,
13731                    &vs_len);
13732
13733
13734                 if (sts == 0) {
13735                     int haslower = 0;
13736                     const char *cp;
13737
13738                     /* Trim off the version */
13739                     int file_len = v_len + r_len + d_len + n_len + e_len;
13740                     vms_spec[file_len] = 0;
13741
13742                     /* Trim off the .DIR if this is a directory */
13743                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13744                         if (S_ISDIR(my_mode)) {
13745                             e_len = 0;
13746                             e_spec[0] = 0;
13747                         }
13748                     }
13749
13750                     /* Drop NULL extensions on UNIX file specification */
13751                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
13752                         e_len = 0;
13753                         e_spec[0] = '\0';
13754                     }
13755
13756                     /* The result is expected to be in UNIX format */
13757                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13758
13759                     /* Downcase if input had any lower case letters and
13760                      * case preservation is not in effect.
13761                      */
13762                     if (!decc_efs_case_preserve) {
13763                         for (cp = filespec; *cp; cp++)
13764                             if (islower(*cp)) { haslower = 1; break; }
13765
13766                         if (haslower) __mystrtolower(rslt);
13767                     }
13768                 }
13769         } else {
13770
13771             /* Now for some hacks to deal with backwards and forward */
13772             /* compatibility */
13773             if (!decc_efs_charset) {
13774
13775                 /* 1. ODS-2 mode wants to do a syntax only translation */
13776                 rslt = int_rmsexpand(filespec, outbuf,
13777                                     NULL, 0, NULL, utf8_fl);
13778
13779             } else {
13780                 if (decc_filename_unix_report) {
13781                     char * dir_name;
13782                     char * vms_dir_name;
13783                     char * file_name;
13784
13785                     /* 2. ODS-5 / UNIX report mode should return a failure */
13786                     /*    if the parent directory also does not exist */
13787                     /*    Otherwise, get the real path for the parent */
13788                     /*    and add the child to it. */
13789
13790                     /* basename / dirname only available for VMS 7.0+ */
13791                     /* So we may need to implement them as common routines */
13792
13793                     Newx(dir_name, VMS_MAXRSS + 1, char);
13794                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13795                     dir_name[0] = '\0';
13796                     file_name = NULL;
13797
13798                     /* First try a VMS parse */
13799                     sts = vms_split_path
13800                           (filespec,
13801                            &v_spec,
13802                            &v_len,
13803                            &r_spec,
13804                            &r_len,
13805                            &d_spec,
13806                            &d_len,
13807                            &n_spec,
13808                            &n_len,
13809                            &e_spec,
13810                            &e_len,
13811                            &vs_spec,
13812                            &vs_len);
13813
13814                     if (sts == 0) {
13815                         /* This is VMS */
13816
13817                         int dir_len = v_len + r_len + d_len + n_len;
13818                         if (dir_len > 0) {
13819                            memcpy(dir_name, filespec, dir_len);
13820                            dir_name[dir_len] = '\0';
13821                            file_name = (char *)&filespec[dir_len + 1];
13822                         }
13823                     } else {
13824                         /* This must be UNIX */
13825                         char * tchar;
13826
13827                         tchar = strrchr(filespec, '/');
13828
13829                         if (tchar != NULL) {
13830                             int dir_len = tchar - filespec;
13831                             memcpy(dir_name, filespec, dir_len);
13832                             dir_name[dir_len] = '\0';
13833                             file_name = (char *) &filespec[dir_len + 1];
13834                         }
13835                     }
13836
13837                     /* Dir name is defaulted */
13838                     if (dir_name[0] == 0) {
13839                         dir_name[0] = '.';
13840                         dir_name[1] = '\0';
13841                     }
13842
13843                     /* Need realpath for the directory */
13844                     sts = vms_fid_to_name(vms_dir_name,
13845                                           VMS_MAXRSS + 1,
13846                                           dir_name, 0, NULL);
13847
13848                     if (sts == 0) {
13849                         /* Now need to pathify it. */
13850                         char *tdir = int_pathify_dirspec(vms_dir_name,
13851                                                          outbuf);
13852
13853                         /* And now add the original filespec to it */
13854                         if (file_name != NULL) {
13855                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13856                         }
13857                         return outbuf;
13858                     }
13859                     Safefree(vms_dir_name);
13860                     Safefree(dir_name);
13861                 }
13862             }
13863         }
13864         Safefree(vms_spec);
13865     }
13866     return rslt;
13867 }
13868
13869 static char *
13870 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13871                    int *utf8_fl)
13872 {
13873     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13874     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13875
13876     /* Fall back to fid_to_name */
13877
13878     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13879     if (sts != 0) {
13880         return NULL;
13881     }
13882     else {
13883
13884
13885         /* Now need to trim the version off */
13886         sts = vms_split_path
13887                   (outbuf,
13888                    &v_spec,
13889                    &v_len,
13890                    &r_spec,
13891                    &r_len,
13892                    &d_spec,
13893                    &d_len,
13894                    &n_spec,
13895                    &n_len,
13896                    &e_spec,
13897                    &e_len,
13898                    &vs_spec,
13899                    &vs_len);
13900
13901
13902         if (sts == 0) {
13903             int haslower = 0;
13904             const char *cp;
13905
13906             /* Trim off the version */
13907             int file_len = v_len + r_len + d_len + n_len + e_len;
13908             outbuf[file_len] = 0;
13909
13910             /* Downcase if input had any lower case letters and
13911              * case preservation is not in effect.
13912              */
13913             if (!decc_efs_case_preserve) {
13914                 for (cp = filespec; *cp; cp++)
13915                     if (islower(*cp)) { haslower = 1; break; }
13916
13917                 if (haslower) __mystrtolower(outbuf);
13918             }
13919         }
13920     }
13921     return outbuf;
13922 }
13923
13924
13925 /*}}}*/
13926 /* External entry points */
13927 char *
13928 Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13929 {
13930     return do_vms_realpath(filespec, outbuf, utf8_fl);
13931 }
13932
13933 char *
13934 Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13935 {
13936     return do_vms_realname(filespec, outbuf, utf8_fl);
13937 }
13938
13939 /* case_tolerant */
13940
13941 /*{{{int do_vms_case_tolerant(void)*/
13942 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13943  * controlled by a process setting.
13944  */
13945 int
13946 do_vms_case_tolerant(void)
13947 {
13948     return vms_process_case_tolerant;
13949 }
13950 /*}}}*/
13951 /* External entry points */
13952 int
13953 Perl_vms_case_tolerant(void)
13954 {
13955 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13956     return do_vms_case_tolerant();
13957 #else
13958     return vms_process_case_tolerant;
13959 #endif
13960 }
13961
13962  /* Start of DECC RTL Feature handling */
13963
13964 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13965
13966 static int
13967 set_feature_default(const char *name, int value)
13968 {
13969     int status;
13970     int index;
13971     char val_str[10];
13972
13973     /* If the feature has been explicitly disabled in the environment,
13974      * then don't enable it here.
13975      */
13976     if (value > 0) {
13977         status = simple_trnlnm(name, val_str, sizeof(val_str));
13978         if (status) {
13979             val_str[0] = _toupper(val_str[0]);
13980             if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
13981                 return 0;
13982         }
13983     }
13984
13985     index = decc$feature_get_index(name);
13986
13987     status = decc$feature_set_value(index, 1, value);
13988     if (index == -1 || (status == -1)) {
13989       return -1;
13990     }
13991
13992     status = decc$feature_get_value(index, 1);
13993     if (status != value) {
13994       return -1;
13995     }
13996
13997     /* Various things may check for an environment setting
13998      * rather than the feature directly, so set that too.
13999      */
14000     vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
14001
14002     return 0;
14003 }
14004 #endif
14005
14006
14007 /* C RTL Feature settings */
14008
14009 #if defined(__DECC) || defined(__DECCXX)
14010
14011 #ifdef __cplusplus
14012 extern "C" {
14013 #endif
14014
14015 extern void
14016 vmsperl_set_features(void)
14017 {
14018     int status;
14019     int s;
14020     char val_str[10];
14021 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14022     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14023     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14024     unsigned long case_perm;
14025     unsigned long case_image;
14026 #endif
14027
14028     /* Allow an exception to bring Perl into the VMS debugger */
14029     vms_debug_on_exception = 0;
14030     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14031     if (status) {
14032        val_str[0] = _toupper(val_str[0]);
14033        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14034          vms_debug_on_exception = 1;
14035        else
14036          vms_debug_on_exception = 0;
14037     }
14038
14039     /* Debug unix/vms file translation routines */
14040     vms_debug_fileify = 0;
14041     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14042     if (status) {
14043         val_str[0] = _toupper(val_str[0]);
14044         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14045             vms_debug_fileify = 1;
14046         else
14047             vms_debug_fileify = 0;
14048     }
14049
14050
14051     /* Historically PERL has been doing vmsify / stat differently than */
14052     /* the CRTL.  In particular, under some conditions the CRTL will   */
14053     /* remove some illegal characters like spaces from filenames       */
14054     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14055     /* been reporting such file names as invalid and fails to stat them */
14056     /* fixing this bug so that stat()/lstat() accept these like the     */
14057     /* CRTL does will result in several tests failing.                  */
14058     /* This should really be fixed, but for now, set up a feature to    */
14059     /* enable it so that the impact can be studied.                     */
14060     vms_bug_stat_filename = 0;
14061     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14062     if (status) {
14063         val_str[0] = _toupper(val_str[0]);
14064         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14065             vms_bug_stat_filename = 1;
14066         else
14067             vms_bug_stat_filename = 0;
14068     }
14069
14070
14071     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14072     vms_vtf7_filenames = 0;
14073     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14074     if (status) {
14075        val_str[0] = _toupper(val_str[0]);
14076        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14077          vms_vtf7_filenames = 1;
14078        else
14079          vms_vtf7_filenames = 0;
14080     }
14081
14082     /* unlink all versions on unlink() or rename() */
14083     vms_unlink_all_versions = 0;
14084     status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14085     if (status) {
14086        val_str[0] = _toupper(val_str[0]);
14087        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14088          vms_unlink_all_versions = 1;
14089        else
14090          vms_unlink_all_versions = 0;
14091     }
14092
14093 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14094     /* Detect running under GNV Bash or other UNIX like shell */
14095     gnv_unix_shell = 0;
14096     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14097     if (status) {
14098          gnv_unix_shell = 1;
14099          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14100          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14101          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14102          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14103          vms_unlink_all_versions = 1;
14104          vms_posix_exit = 1;
14105          /* Reverse default ordering of PERL_ENV_TABLES. */
14106          defenv[0] = &crtlenvdsc;
14107          defenv[1] = &fildevdsc;
14108     }
14109     /* Some reasonable defaults that are not CRTL defaults */
14110     set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14111     set_feature_default("DECC$ARGV_PARSE_STYLE", 1);     /* Requires extended parse. */
14112     set_feature_default("DECC$EFS_CHARSET", 1);
14113 #endif
14114
14115     /* hacks to see if known bugs are still present for testing */
14116
14117     /* PCP mode requires creating /dev/null special device file */
14118     decc_bug_devnull = 0;
14119     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14120     if (status) {
14121        val_str[0] = _toupper(val_str[0]);
14122        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14123           decc_bug_devnull = 1;
14124        else
14125           decc_bug_devnull = 0;
14126     }
14127
14128 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14129     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14130     if (s >= 0) {
14131         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14132         if (decc_disable_to_vms_logname_translation < 0)
14133             decc_disable_to_vms_logname_translation = 0;
14134     }
14135
14136     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14137     if (s >= 0) {
14138         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14139         if (decc_efs_case_preserve < 0)
14140             decc_efs_case_preserve = 0;
14141     }
14142
14143     s = decc$feature_get_index("DECC$EFS_CHARSET");
14144     decc_efs_charset_index = s;
14145     if (s >= 0) {
14146         decc_efs_charset = decc$feature_get_value(s, 1);
14147         if (decc_efs_charset < 0)
14148             decc_efs_charset = 0;
14149     }
14150
14151     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14152     if (s >= 0) {
14153         decc_filename_unix_report = decc$feature_get_value(s, 1);
14154         if (decc_filename_unix_report > 0) {
14155             decc_filename_unix_report = 1;
14156             vms_posix_exit = 1;
14157         }
14158         else
14159             decc_filename_unix_report = 0;
14160     }
14161
14162     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14163     if (s >= 0) {
14164         decc_filename_unix_only = decc$feature_get_value(s, 1);
14165         if (decc_filename_unix_only > 0) {
14166             decc_filename_unix_only = 1;
14167         }
14168         else {
14169             decc_filename_unix_only = 0;
14170         }
14171     }
14172
14173     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14174     if (s >= 0) {
14175         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14176         if (decc_filename_unix_no_version < 0)
14177             decc_filename_unix_no_version = 0;
14178     }
14179
14180     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14181     if (s >= 0) {
14182         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14183         if (decc_readdir_dropdotnotype < 0)
14184             decc_readdir_dropdotnotype = 0;
14185     }
14186
14187 #if __CRTL_VER >= 80200000
14188     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14189     if (s >= 0) {
14190         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14191         if (decc_posix_compliant_pathnames < 0)
14192             decc_posix_compliant_pathnames = 0;
14193         if (decc_posix_compliant_pathnames > 4)
14194             decc_posix_compliant_pathnames = 0;
14195     }
14196
14197 #endif
14198 #else
14199     status = simple_trnlnm
14200         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14201     if (status) {
14202         val_str[0] = _toupper(val_str[0]);
14203         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14204            decc_disable_to_vms_logname_translation = 1;
14205         }
14206     }
14207
14208 #ifndef __VAX
14209     status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14210     if (status) {
14211         val_str[0] = _toupper(val_str[0]);
14212         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14213            decc_efs_case_preserve = 1;
14214         }
14215     }
14216 #endif
14217
14218     status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14219     if (status) {
14220         val_str[0] = _toupper(val_str[0]);
14221         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14222            decc_filename_unix_report = 1;
14223         }
14224     }
14225     status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14226     if (status) {
14227         val_str[0] = _toupper(val_str[0]);
14228         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14229            decc_filename_unix_only = 1;
14230            decc_filename_unix_report = 1;
14231         }
14232     }
14233     status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14234     if (status) {
14235         val_str[0] = _toupper(val_str[0]);
14236         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14237            decc_filename_unix_no_version = 1;
14238         }
14239     }
14240     status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14241     if (status) {
14242         val_str[0] = _toupper(val_str[0]);
14243         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14244            decc_readdir_dropdotnotype = 1;
14245         }
14246     }
14247 #endif
14248
14249 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14250
14251      /* Report true case tolerance */
14252     /*----------------------------*/
14253     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14254     if (!$VMS_STATUS_SUCCESS(status))
14255         case_perm = PPROP$K_CASE_BLIND;
14256     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14257     if (!$VMS_STATUS_SUCCESS(status))
14258         case_image = PPROP$K_CASE_BLIND;
14259     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14260         (case_image == PPROP$K_CASE_SENSITIVE))
14261         vms_process_case_tolerant = 0;
14262
14263 #endif
14264
14265     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14266     /* for strict backward compatibility */
14267     status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14268     if (status) {
14269        val_str[0] = _toupper(val_str[0]);
14270        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14271          vms_posix_exit = 1;
14272        else
14273          vms_posix_exit = 0;
14274     }
14275 }
14276
14277 /* Use 32-bit pointers because that's what the image activator
14278  * assumes for the LIB$INITIALZE psect.
14279  */
14280 #if __INITIAL_POINTER_SIZE
14281 #pragma pointer_size save
14282 #pragma pointer_size 32
14283 #endif
14284
14285 /* Create a reference to the LIB$INITIALIZE function. */
14286 extern void LIB$INITIALIZE(void);
14287 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14288
14289 /* Create an array of pointers to the init functions in the special
14290  * LIB$INITIALIZE section. In our case, the array only has one entry.
14291  */
14292 #pragma extern_model save
14293 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
14294 extern void (* const vmsperl_unused_global_2[])() =
14295 {
14296    vmsperl_set_features,
14297 };
14298 #pragma extern_model restore
14299
14300 #if __INITIAL_POINTER_SIZE
14301 #pragma pointer_size restore
14302 #endif
14303
14304 #ifdef __cplusplus
14305 }
14306 #endif
14307
14308 #endif /* defined(__DECC) || defined(__DECCXX) */
14309 /*  End of vms.c */