vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993-2013 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 simple_trnlnm
 274    (const char * logname,
 275     char * value,
 276     int value_len)
 277 {
 278     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 279     const unsigned long attr = LNM$M_CASE_BLIND;
 280     struct dsc$descriptor_s name_dsc;
 281     int status;
 282     unsigned short result;
 283     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 284                                 {0, 0, 0, 0}};
 285
 286     name_dsc.dsc$w_length = strlen(logname);
 287     name_dsc.dsc$a_pointer = (char *)logname;
 288     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 289     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 290
 291     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 292
 293     if ($VMS_STATUS_SUCCESS(status)) {
 294
 295          /* Null terminate and return the string */
 296         /*--------------------------------------*/
 297         value[result] = 0;
 298         return result;
 299     }
 300
 301     return 0;
 302 }
 303
 304
 305 /* Is this a UNIX file specification?
 306  *   No longer a simple check with EFS file specs
 307  *   For now, not a full check, but need to
 308  *   handle POSIX ^UP^ specifications
 309  *   Fixing to handle ^/ cases would require
 310  *   changes to many other conversion routines.
 311  */
 312
 313 static int is_unix_filespec(const char *path)
 314 {
 315 int ret_val;
 316 const char * pch1;
 317
 318     ret_val = 0;
 319     if (strncmp(path,"\"^UP^",5) != 0) {
 320         pch1 = strchr(path, '/');
 321         if (pch1 != NULL)
 322             ret_val = 1;
 323         else {
 324
 325             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 326             if (decc_filename_unix_report || decc_filename_unix_only) {
 327             if (strcmp(path,".") == 0)
 328                 ret_val = 1;
 329             }
 330         }
 331     }
 332     return ret_val;
 333 }
 334
 335 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 336  */
 337
 338 static void ucs2_to_vtf7
 339    (char *outspec,
 340     unsigned long ucs2_char,
 341     int * output_cnt)
 342 {
 343 unsigned char * ucs_ptr;
 344 int hex;
 345
 346     ucs_ptr = (unsigned char *)&ucs2_char;
 347
 348     outspec[0] = '^';
 349     outspec[1] = 'U';
 350     hex = (ucs_ptr[1] >> 4) & 0xf;
 351     if (hex < 0xA)
 352         outspec[2] = hex + '0';
 353     else
 354         outspec[2] = (hex - 9) + 'A';
 355     hex = ucs_ptr[1] & 0xF;
 356     if (hex < 0xA)
 357         outspec[3] = hex + '0';
 358     else {
 359         outspec[3] = (hex - 9) + 'A';
 360     }
 361     hex = (ucs_ptr[0] >> 4) & 0xf;
 362     if (hex < 0xA)
 363         outspec[4] = hex + '0';
 364     else
 365         outspec[4] = (hex - 9) + 'A';
 366     hex = ucs_ptr[1] & 0xF;
 367     if (hex < 0xA)
 368         outspec[5] = hex + '0';
 369     else {
 370         outspec[5] = (hex - 9) + 'A';
 371     }
 372     *output_cnt = 6;
 373 }
 374
 375
 376 /* This handles the conversion of a UNIX extended character set to a ^
 377  * escaped VMS character.
 378  * in a UNIX file specification.
 379  *
 380  * The output count variable contains the number of characters added
 381  * to the output string.
 382  *
 383  * The return value is the number of characters read from the input string
 384  */
 385 static int copy_expand_unix_filename_escape
 386   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 387 {
 388 int count;
 389 int utf8_flag;
 390
 391     utf8_flag = 0;
 392     if (utf8_fl)
 393       utf8_flag = *utf8_fl;
 394
 395     count = 0;
 396     *output_cnt = 0;
 397     if (*inspec >= 0x80) {
 398         if (utf8_fl && vms_vtf7_filenames) {
 399         unsigned long ucs_char;
 400
 401             ucs_char = 0;
 402
 403             if ((*inspec & 0xE0) == 0xC0) {
 404                 /* 2 byte Unicode */
 405                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 406                 if (ucs_char >= 0x80) {
 407                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 408                     return 2;
 409                 }
 410             } else if ((*inspec & 0xF0) == 0xE0) {
 411                 /* 3 byte Unicode */
 412                 ucs_char = ((inspec[0] & 0xF) << 12) +
 413                    ((inspec[1] & 0x3f) << 6) +
 414                    (inspec[2] & 0x3f);
 415                 if (ucs_char >= 0x800) {
 416                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 417                     return 3;
 418                 }
 419
 420 #if 0 /* I do not see longer sequences supported by OpenVMS */
 421       /* Maybe some one can fix this later */
 422             } else if ((*inspec & 0xF8) == 0xF0) {
 423                 /* 4 byte Unicode */
 424                 /* UCS-4 to UCS-2 */
 425             } else if ((*inspec & 0xFC) == 0xF8) {
 426                 /* 5 byte Unicode */
 427                 /* UCS-4 to UCS-2 */
 428             } else if ((*inspec & 0xFE) == 0xFC) {
 429                 /* 6 byte Unicode */
 430                 /* UCS-4 to UCS-2 */
 431 #endif
 432             }
 433         }
 434
 435         /* High bit set, but not a Unicode character! */
 436
 437         /* Non printing DECMCS or ISO Latin-1 character? */
 438         if ((unsigned char)*inspec <= 0x9F) {
 439             int hex;
 440             outspec[0] = '^';
 441             outspec++;
 442             hex = (*inspec >> 4) & 0xF;
 443             if (hex < 0xA)
 444                 outspec[1] = hex + '0';
 445             else {
 446                 outspec[1] = (hex - 9) + 'A';
 447             }
 448             hex = *inspec & 0xF;
 449             if (hex < 0xA)
 450                 outspec[2] = hex + '0';
 451             else {
 452                 outspec[2] = (hex - 9) + 'A';
 453             }
 454             *output_cnt = 3;
 455             return 1;
 456         } else if ((unsigned char)*inspec == 0xA0) {
 457             outspec[0] = '^';
 458             outspec[1] = 'A';
 459             outspec[2] = '0';
 460             *output_cnt = 3;
 461             return 1;
 462         } else if ((unsigned char)*inspec == 0xFF) {
 463             outspec[0] = '^';
 464             outspec[1] = 'F';
 465             outspec[2] = 'F';
 466             *output_cnt = 3;
 467             return 1;
 468         }
 469         *outspec = *inspec;
 470         *output_cnt = 1;
 471         return 1;
 472     }
 473
 474     /* Is this a macro that needs to be passed through?
 475      * Macros start with $( and an alpha character, followed
 476      * by a string of alpha numeric characters ending with a )
 477      * If this does not match, then encode it as ODS-5.
 478      */
 479     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 480     int tcnt;
 481
 482         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 483             tcnt = 3;
 484             outspec[0] = inspec[0];
 485             outspec[1] = inspec[1];
 486             outspec[2] = inspec[2];
 487
 488             while(isalnum(inspec[tcnt]) ||
 489                   (inspec[2] == '.') || (inspec[2] == '_')) {
 490                 outspec[tcnt] = inspec[tcnt];
 491                 tcnt++;
 492             }
 493             if (inspec[tcnt] == ')') {
 494                 outspec[tcnt] = inspec[tcnt];
 495                 tcnt++;
 496                 *output_cnt = tcnt;
 497                 return tcnt;
 498             }
 499         }
 500     }
 501
 502     switch (*inspec) {
 503     case 0x7f:
 504         outspec[0] = '^';
 505         outspec[1] = '7';
 506         outspec[2] = 'F';
 507         *output_cnt = 3;
 508         return 1;
 509         break;
 510     case '?':
 511         if (decc_efs_charset == 0)
 512           outspec[0] = '%';
 513         else
 514           outspec[0] = '?';
 515         *output_cnt = 1;
 516         return 1;
 517         break;
 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     case '%':
 536     case '^':
 537     case '\\':
 538         /* Don't escape again if following character is
 539          * already something we escape.
 540          */
 541         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 542             *outspec = *inspec;
 543             *output_cnt = 1;
 544             return 1;
 545             break;
 546         }
 547         /* But otherwise fall through and escape it. */
 548     case '=':
 549         /* Assume that this is to be escaped */
 550         outspec[0] = '^';
 551         outspec[1] = *inspec;
 552         *output_cnt = 2;
 553         return 1;
 554         break;
 555     case ' ': /* space */
 556         /* Assume that this is to be escaped */
 557         outspec[0] = '^';
 558         outspec[1] = '_';
 559         *output_cnt = 2;
 560         return 1;
 561         break;
 562     default:
 563         *outspec = *inspec;
 564         *output_cnt = 1;
 565         return 1;
 566         break;
 567     }
 568     return 0;
 569 }
 570
 571
 572 /* This handles the expansion of a '^' prefix to the proper character
 573  * in a UNIX file specification.
 574  *
 575  * The output count variable contains the number of characters added
 576  * to the output string.
 577  *
 578  * The return value is the number of characters read from the input
 579  * string
 580  */
 581 static int copy_expand_vms_filename_escape
 582   (char *outspec, const char *inspec, int *output_cnt)
 583 {
 584 int count;
 585 int scnt;
 586
 587     count = 0;
 588     *output_cnt = 0;
 589     if (*inspec == '^') {
 590         inspec++;
 591         switch (*inspec) {
 592         /* Spaces and non-trailing dots should just be passed through,
 593          * but eat the escape character.
 594          */
 595         case '.':
 596             *outspec = *inspec;
 597             count += 2;
 598             (*output_cnt)++;
 599             break;
 600         case '_': /* space */
 601             *outspec = ' ';
 602             count += 2;
 603             (*output_cnt)++;
 604             break;
 605         case '^':
 606             /* Hmm.  Better leave the escape escaped. */
 607             outspec[0] = '^';
 608             outspec[1] = '^';
 609             count += 2;
 610             (*output_cnt) += 2;
 611             break;
 612         case 'U': /* Unicode - FIX-ME this is wrong. */
 613             inspec++;
 614             count++;
 615             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 616             if (scnt == 4) {
 617                 unsigned int c1, c2;
 618                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 619                 outspec[0] = c1 & 0xff;
 620                 outspec[1] = c2 & 0xff;
 621                 if (scnt > 1) {
 622                     (*output_cnt) += 2;
 623                     count += 4;
 624                 }
 625             }
 626             else {
 627                 /* Error - do best we can to continue */
 628                 *outspec = 'U';
 629                 outspec++;
 630                 (*output_cnt++);
 631                 *outspec = *inspec;
 632                 count++;
 633                 (*output_cnt++);
 634             }
 635             break;
 636         default:
 637             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 638             if (scnt == 2) {
 639                 /* Hex encoded */
 640                 unsigned int c1;
 641                 scnt = sscanf(inspec, "%2x", &c1);
 642                 outspec[0] = c1 & 0xff;
 643                 if (scnt > 0) {
 644                     (*output_cnt++);
 645                     count += 2;
 646                 }
 647             }
 648             else {
 649                 *outspec = *inspec;
 650                 count++;
 651                 (*output_cnt++);
 652             }
 653         }
 654     }
 655     else {
 656         *outspec = *inspec;
 657         count++;
 658         (*output_cnt)++;
 659     }
 660     return count;
 661 }
 662
 663 /* vms_split_path - Verify that the input file specification is a
 664  * VMS format file specification, and provide pointers to the components of
 665  * it.  With EFS format filenames, this is virtually the only way to
 666  * parse a VMS path specification into components.
 667  *
 668  * If the sum of the components do not add up to the length of the
 669  * string, then the passed file specification is probably a UNIX style
 670  * path.
 671  */
 672 static int vms_split_path
 673    (const char * path,
 674     char * * volume,
 675     int * vol_len,
 676     char * * root,
 677     int * root_len,
 678     char * * dir,
 679     int * dir_len,
 680     char * * name,
 681     int * name_len,
 682     char * * ext,
 683     int * ext_len,
 684     char * * version,
 685     int * ver_len)
 686 {
 687 struct dsc$descriptor path_desc;
 688 int status;
 689 unsigned long flags;
 690 int ret_stat;
 691 struct filescan_itmlst_2 item_list[9];
 692 const int filespec = 0;
 693 const int nodespec = 1;
 694 const int devspec = 2;
 695 const int rootspec = 3;
 696 const int dirspec = 4;
 697 const int namespec = 5;
 698 const int typespec = 6;
 699 const int verspec = 7;
 700
 701     /* Assume the worst for an easy exit */
 702     ret_stat = -1;
 703     *volume = NULL;
 704     *vol_len = 0;
 705     *root = NULL;
 706     *root_len = 0;
 707     *dir = NULL;
 708     *name = NULL;
 709     *name_len = 0;
 710     *ext = NULL;
 711     *ext_len = 0;
 712     *version = NULL;
 713     *ver_len = 0;
 714
 715     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 716     path_desc.dsc$w_length = strlen(path);
 717     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 718     path_desc.dsc$b_class = DSC$K_CLASS_S;
 719
 720     /* Get the total length, if it is shorter than the string passed
 721      * then this was probably not a VMS formatted file specification
 722      */
 723     item_list[filespec].itmcode = FSCN$_FILESPEC;
 724     item_list[filespec].length = 0;
 725     item_list[filespec].component = NULL;
 726
 727     /* If the node is present, then it gets considered as part of the
 728      * volume name to hopefully make things simple.
 729      */
 730     item_list[nodespec].itmcode = FSCN$_NODE;
 731     item_list[nodespec].length = 0;
 732     item_list[nodespec].component = NULL;
 733
 734     item_list[devspec].itmcode = FSCN$_DEVICE;
 735     item_list[devspec].length = 0;
 736     item_list[devspec].component = NULL;
 737
 738     /* root is a special case,  adding it to either the directory or
 739      * the device components will probably complicate things for the
 740      * callers of this routine, so leave it separate.
 741      */
 742     item_list[rootspec].itmcode = FSCN$_ROOT;
 743     item_list[rootspec].length = 0;
 744     item_list[rootspec].component = NULL;
 745
 746     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 747     item_list[dirspec].length = 0;
 748     item_list[dirspec].component = NULL;
 749
 750     item_list[namespec].itmcode = FSCN$_NAME;
 751     item_list[namespec].length = 0;
 752     item_list[namespec].component = NULL;
 753
 754     item_list[typespec].itmcode = FSCN$_TYPE;
 755     item_list[typespec].length = 0;
 756     item_list[typespec].component = NULL;
 757
 758     item_list[verspec].itmcode = FSCN$_VERSION;
 759     item_list[verspec].length = 0;
 760     item_list[verspec].component = NULL;
 761
 762     item_list[8].itmcode = 0;
 763     item_list[8].length = 0;
 764     item_list[8].component = NULL;
 765
 766     status = sys$filescan
 767        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 768         &flags, NULL, NULL);
 769     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 770
 771     /* If we parsed it successfully these two lengths should be the same */
 772     if (path_desc.dsc$w_length != item_list[filespec].length)
 773         return ret_stat;
 774
 775     /* If we got here, then it is a VMS file specification */
 776     ret_stat = 0;
 777
 778     /* set the volume name */
 779     if (item_list[nodespec].length > 0) {
 780         *volume = item_list[nodespec].component;
 781         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 782     }
 783     else {
 784         *volume = item_list[devspec].component;
 785         *vol_len = item_list[devspec].length;
 786     }
 787
 788     *root = item_list[rootspec].component;
 789     *root_len = item_list[rootspec].length;
 790
 791     *dir = item_list[dirspec].component;
 792     *dir_len = item_list[dirspec].length;
 793
 794     /* Now fun with versions and EFS file specifications
 795      * The parser can not tell the difference when a "." is a version
 796      * delimiter or a part of the file specification.
 797      */
 798     if ((decc_efs_charset) &&
 799         (item_list[verspec].length > 0) &&
 800         (item_list[verspec].component[0] == '.')) {
 801         *name = item_list[namespec].component;
 802         *name_len = item_list[namespec].length + item_list[typespec].length;
 803         *ext = item_list[verspec].component;
 804         *ext_len = item_list[verspec].length;
 805         *version = NULL;
 806         *ver_len = 0;
 807     }
 808     else {
 809         *name = item_list[namespec].component;
 810         *name_len = item_list[namespec].length;
 811         *ext = item_list[typespec].component;
 812         *ext_len = item_list[typespec].length;
 813         *version = item_list[verspec].component;
 814         *ver_len = item_list[verspec].length;
 815     }
 816     return ret_stat;
 817 }
 818
 819 /* Routine to determine if the file specification ends with .dir */
 820 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 821
 822     /* e_len must be 4, and version must be <= 2 characters */
 823     if (e_len != 4 || vs_len > 2)
 824         return 0;
 825
 826     /* If a version number is present, it needs to be one */
 827     if ((vs_len == 2) && (vs_spec[1] != '1'))
 828         return 0;
 829
 830     /* Look for the DIR on the extension */
 831     if (vms_process_case_tolerant) {
 832         if ((toupper(e_spec[1]) == 'D') &&
 833             (toupper(e_spec[2]) == 'I') &&
 834             (toupper(e_spec[3]) == 'R')) {
 835             return 1;
 836         }
 837     } else {
 838         /* Directory extensions are supposed to be in upper case only */
 839         /* I would not be surprised if this rule can not be enforced */
 840         /* if and when someone fully debugs the case sensitive mode */
 841         if ((e_spec[1] == 'D') &&
 842             (e_spec[2] == 'I') &&
 843             (e_spec[3] == 'R')) {
 844             return 1;
 845         }
 846     }
 847     return 0;
 848 }
 849
 850
 851 /* my_maxidx
 852  * Routine to retrieve the maximum equivalence index for an input
 853  * logical name.  Some calls to this routine have no knowledge if
 854  * the variable is a logical or not.  So on error we return a max
 855  * index of zero.
 856  */
 857 /*{{{int my_maxidx(const char *lnm) */
 858 static int
 859 my_maxidx(const char *lnm)
 860 {
 861     int status;
 862     int midx;
 863     int attr = LNM$M_CASE_BLIND;
 864     struct dsc$descriptor lnmdsc;
 865     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 866                                 {0, 0, 0, 0}};
 867
 868     lnmdsc.dsc$w_length = strlen(lnm);
 869     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 870     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 871     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 872
 873     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 874     if ((status & 1) == 0)
 875        midx = 0;
 876
 877     return (midx);
 878 }
 879 /*}}}*/
 880
 881 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 882 int
 883 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 884   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 885 {
 886     const char *cp1;
 887     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 888     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 889     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 890     int midx;
 891     unsigned char acmode;
 892     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 893                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 894     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 895                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 896                                  {0, 0, 0, 0}};
 897     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 898 #if defined(PERL_IMPLICIT_CONTEXT)
 899     pTHX = NULL;
 900     if (PL_curinterp) {
 901       aTHX = PERL_GET_INTERP;
 902     } else {
 903       aTHX = NULL;
 904     }
 905 #endif
 906
 907     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 908       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 909     }
 910     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 911       *cp2 = _toupper(*cp1);
 912       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 913         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 914         return 0;
 915       }
 916     }
 917     lnmdsc.dsc$w_length = cp1 - lnm;
 918     lnmdsc.dsc$a_pointer = uplnm;
 919     uplnm[lnmdsc.dsc$w_length] = '\0';
 920     secure = flags & PERL__TRNENV_SECURE;
 921     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 922     if (!tabvec || !*tabvec) tabvec = env_tables;
 923
 924     for (curtab = 0; tabvec[curtab]; curtab++) {
 925       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 926         if (!ivenv && !secure) {
 927           char *eq;
 928           int i;
 929           if (!environ) {
 930             ivenv = 1;
 931 #if defined(PERL_IMPLICIT_CONTEXT)
 932             if (aTHX == NULL) {
 933                 fprintf(stderr,
 934                     "Can't read CRTL environ\n");
 935             } else
 936 #endif
 937                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 938             continue;
 939           }
 940           retsts = SS$_NOLOGNAM;
 941           for (i = 0; environ[i]; i++) {
 942             if ((eq = strchr(environ[i],'=')) &&
 943                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 944                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 945               eq++;
 946               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 947               if (!eqvlen) continue;
 948               retsts = SS$_NORMAL;
 949               break;
 950             }
 951           }
 952           if (retsts != SS$_NOLOGNAM) break;
 953         }
 954       }
 955       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 956                !str$case_blind_compare(&tmpdsc,&clisym)) {
 957         if (!ivsym && !secure) {
 958           unsigned short int deflen = LNM$C_NAMLENGTH;
 959           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 960           /* dynamic dsc to accommodate possible long value */
 961           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 962           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 963           if (retsts & 1) {
 964             if (eqvlen > MAX_DCL_SYMBOL) {
 965               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 966               eqvlen = MAX_DCL_SYMBOL;
 967               /* Special hack--we might be called before the interpreter's */
 968               /* fully initialized, in which case either thr or PL_curcop */
 969               /* might be bogus. We have to check, since ckWARN needs them */
 970               /* both to be valid if running threaded */
 971 #if defined(PERL_IMPLICIT_CONTEXT)
 972               if (aTHX == NULL) {
 973                   fprintf(stderr,
 974                      "Value of CLI symbol \"%s\" too long",lnm);
 975               } else
 976 #endif
 977                 if (ckWARN(WARN_MISC)) {
 978                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 979                 }
 980             }
 981             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 982           }
 983           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
 984           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 985           if (retsts == LIB$_NOSUCHSYM) continue;
 986           break;
 987         }
 988       }
 989       else if (!ivlnm) {
 990         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 991           midx = my_maxidx(lnm);
 992           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 993             lnmlst[1].bufadr = cp2;
 994             eqvlen = 0;
 995             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 996             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 997             if (retsts == SS$_NOLOGNAM) break;
 998             /* PPFs have a prefix */
 999             if (
1000 #if INTSIZE == 4
1001                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1002 #endif
1003                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1004                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1005                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1006                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1007                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1008               memmove(eqv,eqv+4,eqvlen-4);
1009               eqvlen -= 4;
1010             }
1011             cp2 += eqvlen;
1012             *cp2 = '\0';
1013           }
1014           if ((retsts == SS$_IVLOGNAM) ||
1015               (retsts == SS$_NOLOGNAM)) { continue; }
1016         }
1017         else {
1018           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1019           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1020           if (retsts == SS$_NOLOGNAM) continue;
1021           eqv[eqvlen] = '\0';
1022         }
1023         eqvlen = strlen(eqv);
1024         break;
1025       }
1026     }
1027     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1028     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1029              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1030              retsts == SS$_NOLOGNAM) {
1031       set_errno(EINVAL);  set_vaxc_errno(retsts);
1032     }
1033     else _ckvmssts_noperl(retsts);
1034     return 0;
1035 }  /* end of vmstrnenv */
1036 /*}}}*/
1037
1038 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1039 /* Define as a function so we can access statics. */
1040 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1041 {
1042     int flags = 0;
1043
1044 #if defined(PERL_IMPLICIT_CONTEXT)
1045     if (aTHX != NULL)
1046 #endif
1047 #ifdef SECURE_INTERNAL_GETENV
1048         flags = (PL_curinterp ? TAINTING_get : will_taint) ?
1049                  PERL__TRNENV_SECURE : 0;
1050 #endif
1051
1052     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1053 }
1054 /*}}}*/
1055
1056 /* my_getenv
1057  * Note: Uses Perl temp to store result so char * can be returned to
1058  * caller; this pointer will be invalidated at next Perl statement
1059  * transition.
1060  * We define this as a function rather than a macro in terms of my_getenv_len()
1061  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1062  * allocate SVs).
1063  */
1064 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1065 char *
1066 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1067 {
1068     const char *cp1;
1069     static char *__my_getenv_eqv = NULL;
1070     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1071     unsigned long int idx = 0;
1072     int success, secure, saverr, savvmserr;
1073     int midx, flags;
1074     SV *tmpsv;
1075
1076     midx = my_maxidx(lnm) + 1;
1077
1078     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1079       /* Set up a temporary buffer for the return value; Perl will
1080        * clean it up at the next statement transition */
1081       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1082       if (!tmpsv) return NULL;
1083       eqv = SvPVX(tmpsv);
1084     }
1085     else {
1086       /* Assume no interpreter ==> single thread */
1087       if (__my_getenv_eqv != NULL) {
1088         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1089       }
1090       else {
1091         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1092       }
1093       eqv = __my_getenv_eqv;
1094     }
1095
1096     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1097     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1098       int len;
1099       getcwd(eqv,LNM$C_NAMLENGTH);
1100
1101       len = strlen(eqv);
1102
1103       /* Get rid of "000000/ in rooted filespecs */
1104       if (len > 7) {
1105         char * zeros;
1106         zeros = strstr(eqv, "/000000/");
1107         if (zeros != NULL) {
1108           int mlen;
1109           mlen = len - (zeros - eqv) - 7;
1110           memmove(zeros, &zeros[7], mlen);
1111           len = len - 7;
1112           eqv[len] = '\0';
1113         }
1114       }
1115       return eqv;
1116     }
1117     else {
1118       /* Impose security constraints only if tainting */
1119       if (sys) {
1120         /* Impose security constraints only if tainting */
1121         secure = PL_curinterp ? TAINTING_get : will_taint;
1122         saverr = errno;  savvmserr = vaxc$errno;
1123       }
1124       else {
1125         secure = 0;
1126       }
1127
1128       flags =
1129 #ifdef SECURE_INTERNAL_GETENV
1130               secure ? PERL__TRNENV_SECURE : 0
1131 #else
1132               0
1133 #endif
1134       ;
1135
1136       /* For the getenv interface we combine all the equivalence names
1137        * of a search list logical into one value to acquire a maximum
1138        * value length of 255*128 (assuming %ENV is using logicals).
1139        */
1140       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1141
1142       /* If the name contains a semicolon-delimited index, parse it
1143        * off and make sure we only retrieve the equivalence name for
1144        * that index.  */
1145       if ((cp2 = strchr(lnm,';')) != NULL) {
1146         my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1147         idx = strtoul(cp2+1,NULL,0);
1148         lnm = uplnm;
1149         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1150       }
1151
1152       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1153
1154       /* Discard NOLOGNAM on internal calls since we're often looking
1155        * for an optional name, and this "error" often shows up as the
1156        * (bogus) exit status for a die() call later on.  */
1157       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1158       return success ? eqv : NULL;
1159     }
1160
1161 }  /* end of my_getenv() */
1162 /*}}}*/
1163
1164
1165 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1166 char *
1167 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1168 {
1169     const char *cp1;
1170     char *buf, *cp2;
1171     unsigned long idx = 0;
1172     int midx, flags;
1173     static char *__my_getenv_len_eqv = NULL;
1174     int secure, saverr, savvmserr;
1175     SV *tmpsv;
1176
1177     midx = my_maxidx(lnm) + 1;
1178
1179     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1180       /* Set up a temporary buffer for the return value; Perl will
1181        * clean it up at the next statement transition */
1182       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1183       if (!tmpsv) return NULL;
1184       buf = SvPVX(tmpsv);
1185     }
1186     else {
1187       /* Assume no interpreter ==> single thread */
1188       if (__my_getenv_len_eqv != NULL) {
1189         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1190       }
1191       else {
1192         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1193       }
1194       buf = __my_getenv_len_eqv;
1195     }
1196
1197     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1198     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1199     char * zeros;
1200
1201       getcwd(buf,LNM$C_NAMLENGTH);
1202       *len = strlen(buf);
1203
1204       /* Get rid of "000000/ in rooted filespecs */
1205       if (*len > 7) {
1206       zeros = strstr(buf, "/000000/");
1207       if (zeros != NULL) {
1208         int mlen;
1209         mlen = *len - (zeros - buf) - 7;
1210         memmove(zeros, &zeros[7], mlen);
1211         *len = *len - 7;
1212         buf[*len] = '\0';
1213         }
1214       }
1215       return buf;
1216     }
1217     else {
1218       if (sys) {
1219         /* Impose security constraints only if tainting */
1220         secure = PL_curinterp ? TAINTING_get : will_taint;
1221         saverr = errno;  savvmserr = vaxc$errno;
1222       }
1223       else {
1224         secure = 0;
1225       }
1226
1227       flags =
1228 #ifdef SECURE_INTERNAL_GETENV
1229               secure ? PERL__TRNENV_SECURE : 0
1230 #else
1231               0
1232 #endif
1233       ;
1234
1235       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1236
1237       if ((cp2 = strchr(lnm,';')) != NULL) {
1238         my_strlcpy(buf, lnm, cp2 - lnm + 1);
1239         idx = strtoul(cp2+1,NULL,0);
1240         lnm = buf;
1241         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1242       }
1243
1244       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1245
1246       /* Get rid of "000000/ in rooted filespecs */
1247       if (*len > 7) {
1248       char * zeros;
1249         zeros = strstr(buf, "/000000/");
1250         if (zeros != NULL) {
1251           int mlen;
1252           mlen = *len - (zeros - buf) - 7;
1253           memmove(zeros, &zeros[7], mlen);
1254           *len = *len - 7;
1255           buf[*len] = '\0';
1256         }
1257       }
1258
1259       /* Discard NOLOGNAM on internal calls since we're often looking
1260        * for an optional name, and this "error" often shows up as the
1261        * (bogus) exit status for a die() call later on.  */
1262       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1263       return *len ? buf : NULL;
1264     }
1265
1266 }  /* end of my_getenv_len() */
1267 /*}}}*/
1268
1269 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1270
1271 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1272
1273 /*{{{ void prime_env_iter() */
1274 void
1275 prime_env_iter(void)
1276 /* Fill the %ENV associative array with all logical names we can
1277  * find, in preparation for iterating over it.
1278  */
1279 {
1280   static int primed = 0;
1281   HV *seenhv = NULL, *envhv;
1282   SV *sv = NULL;
1283   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1284   unsigned short int chan;
1285 #ifndef CLI$M_TRUSTED
1286 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1287 #endif
1288   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1289   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1290   long int i;
1291   bool have_sym = FALSE, have_lnm = FALSE;
1292   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1293   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1294   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1295   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1296   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1297 #if defined(PERL_IMPLICIT_CONTEXT)
1298   pTHX;
1299 #endif
1300 #if defined(USE_ITHREADS)
1301   static perl_mutex primenv_mutex;
1302   MUTEX_INIT(&primenv_mutex);
1303 #endif
1304
1305 #if defined(PERL_IMPLICIT_CONTEXT)
1306     /* We jump through these hoops because we can be called at */
1307     /* platform-specific initialization time, which is before anything is */
1308     /* set up--we can't even do a plain dTHX since that relies on the */
1309     /* interpreter structure to be initialized */
1310     if (PL_curinterp) {
1311       aTHX = PERL_GET_INTERP;
1312     } else {
1313       /* we never get here because the NULL pointer will cause the */
1314       /* several of the routines called by this routine to access violate */
1315
1316       /* This routine is only called by hv.c/hv_iterinit which has a */
1317       /* context, so the real fix may be to pass it through instead of */
1318       /* the hoops above */
1319       aTHX = NULL;
1320     }
1321 #endif
1322
1323   if (primed || !PL_envgv) return;
1324   MUTEX_LOCK(&primenv_mutex);
1325   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1326   envhv = GvHVn(PL_envgv);
1327   /* Perform a dummy fetch as an lval to insure that the hash table is
1328    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1329   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1330
1331   for (i = 0; env_tables[i]; i++) {
1332      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1333          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1334      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1335   }
1336   if (have_sym || have_lnm) {
1337     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1338     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1339     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1340     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1341   }
1342
1343   for (i--; i >= 0; i--) {
1344     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1345       char *start;
1346       int j;
1347       for (j = 0; environ[j]; j++) {
1348         if (!(start = strchr(environ[j],'='))) {
1349           if (ckWARN(WARN_INTERNAL))
1350             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1351         }
1352         else {
1353           start++;
1354           sv = newSVpv(start,0);
1355           SvTAINTED_on(sv);
1356           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1357         }
1358       }
1359       continue;
1360     }
1361     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1362              !str$case_blind_compare(&tmpdsc,&clisym)) {
1363       my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1364       cmddsc.dsc$w_length = 20;
1365       if (env_tables[i]->dsc$w_length == 12 &&
1366           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1367           !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local  *", sizeof(cmd)-12);
1368       flags = defflags | CLI$M_NOLOGNAM;
1369     }
1370     else {
1371       my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1372       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1373         my_strlcat(cmd," /Table=", sizeof(cmd));
1374         cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, env_tables[i]->dsc$w_length + 1);
1375       }
1376       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1377       flags = defflags | CLI$M_NOCLISYM;
1378     }
1379
1380     /* Create a new subprocess to execute each command, to exclude the
1381      * remote possibility that someone could subvert a mbx or file used
1382      * to write multiple commands to a single subprocess.
1383      */
1384     do {
1385       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1386                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1387       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1388       defflags &= ~CLI$M_TRUSTED;
1389     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1390     _ckvmssts(retsts);
1391     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1392     if (seenhv) SvREFCNT_dec(seenhv);
1393     seenhv = newHV();
1394     while (1) {
1395       char *cp1, *cp2, *key;
1396       unsigned long int sts, iosb[2], retlen, keylen;
1397       U32 hash;
1398
1399       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1400       if (sts & 1) sts = iosb[0] & 0xffff;
1401       if (sts == SS$_ENDOFFILE) {
1402         int wakect = 0;
1403         while (substs == 0) { sys$hiber(); wakect++;}
1404         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1405         _ckvmssts(substs);
1406         break;
1407       }
1408       _ckvmssts(sts);
1409       retlen = iosb[0] >> 16;
1410       if (!retlen) continue;  /* blank line */
1411       buf[retlen] = '\0';
1412       if (iosb[1] != subpid) {
1413         if (iosb[1]) {
1414           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1415         }
1416         continue;
1417       }
1418       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1419         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1420
1421       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1422       if (*cp1 == '(' || /* Logical name table name */
1423           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1424       if (*cp1 == '"') cp1++;
1425       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1426       key = cp1;  keylen = cp2 - cp1;
1427       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1428       while (*cp2 && *cp2 != '=') cp2++;
1429       while (*cp2 && *cp2 == '=') cp2++;
1430       while (*cp2 && *cp2 == ' ') cp2++;
1431       if (*cp2 == '"') {  /* String translation; may embed "" */
1432         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1433         cp2++;  cp1--; /* Skip "" surrounding translation */
1434       }
1435       else {  /* Numeric translation */
1436         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1437         cp1--;  /* stop on last non-space char */
1438       }
1439       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1440         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1441         continue;
1442       }
1443       PERL_HASH(hash,key,keylen);
1444
1445       if (cp1 == cp2 && *cp2 == '.') {
1446         /* A single dot usually means an unprintable character, such as a null
1447          * to indicate a zero-length value.  Get the actual value to make sure.
1448          */
1449         char lnm[LNM$C_NAMLENGTH+1];
1450         char eqv[MAX_DCL_SYMBOL+1];
1451         int trnlen;
1452         strncpy(lnm, key, keylen);
1453         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1454         sv = newSVpvn(eqv, strlen(eqv));
1455       }
1456       else {
1457         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1458       }
1459
1460       SvTAINTED_on(sv);
1461       hv_store(envhv,key,keylen,sv,hash);
1462       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1463     }
1464     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1465       /* get the PPFs for this process, not the subprocess */
1466       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1467       char eqv[LNM$C_NAMLENGTH+1];
1468       int trnlen, i;
1469       for (i = 0; ppfs[i]; i++) {
1470         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1471         sv = newSVpv(eqv,trnlen);
1472         SvTAINTED_on(sv);
1473         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1474       }
1475     }
1476   }
1477   primed = 1;
1478   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1479   if (buf) Safefree(buf);
1480   if (seenhv) SvREFCNT_dec(seenhv);
1481   MUTEX_UNLOCK(&primenv_mutex);
1482   return;
1483
1484 }  /* end of prime_env_iter */
1485 /*}}}*/
1486
1487
1488 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1489 /* Define or delete an element in the same "environment" as
1490  * vmstrnenv().  If an element is to be deleted, it's removed from
1491  * the first place it's found.  If it's to be set, it's set in the
1492  * place designated by the first element of the table vector.
1493  * Like setenv() returns 0 for success, non-zero on error.
1494  */
1495 int
1496 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1497 {
1498     const char *cp1;
1499     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1500     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1501     int nseg = 0, j;
1502     unsigned long int retsts, usermode = PSL$C_USER;
1503     struct itmlst_3 *ile, *ilist;
1504     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1505                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1506                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1507     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1508     $DESCRIPTOR(local,"_LOCAL");
1509
1510     if (!lnm) {
1511         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1512         return SS$_IVLOGNAM;
1513     }
1514
1515     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1516       *cp2 = _toupper(*cp1);
1517       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1518         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1519         return SS$_IVLOGNAM;
1520       }
1521     }
1522     lnmdsc.dsc$w_length = cp1 - lnm;
1523     if (!tabvec || !*tabvec) tabvec = env_tables;
1524
1525     if (!eqv) {  /* we're deleting n element */
1526       for (curtab = 0; tabvec[curtab]; curtab++) {
1527         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1528         int i;
1529           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1530             if ((cp1 = strchr(environ[i],'=')) &&
1531                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1532                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1533 #ifdef HAS_SETENV
1534               return setenv(lnm,"",1) ? vaxc$errno : 0;
1535             }
1536           }
1537           ivenv = 1; retsts = SS$_NOLOGNAM;
1538 #else
1539               if (ckWARN(WARN_INTERNAL))
1540                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1541               ivenv = 1; retsts = SS$_NOSUCHPGM;
1542               break;
1543             }
1544           }
1545 #endif
1546         }
1547         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1548                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1549           unsigned int symtype;
1550           if (tabvec[curtab]->dsc$w_length == 12 &&
1551               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1552               !str$case_blind_compare(&tmpdsc,&local))
1553             symtype = LIB$K_CLI_LOCAL_SYM;
1554           else symtype = LIB$K_CLI_GLOBAL_SYM;
1555           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1556           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1557           if (retsts == LIB$_NOSUCHSYM) continue;
1558           break;
1559         }
1560         else if (!ivlnm) {
1561           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1562           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1563           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1564           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1565           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1566         }
1567       }
1568     }
1569     else {  /* we're defining a value */
1570       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1571 #ifdef HAS_SETENV
1572         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1573 #else
1574         if (ckWARN(WARN_INTERNAL))
1575           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1576         retsts = SS$_NOSUCHPGM;
1577 #endif
1578       }
1579       else {
1580         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1581         eqvdsc.dsc$w_length  = strlen(eqv);
1582         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1583             !str$case_blind_compare(&tmpdsc,&clisym)) {
1584           unsigned int symtype;
1585           if (tabvec[0]->dsc$w_length == 12 &&
1586               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1587                !str$case_blind_compare(&tmpdsc,&local))
1588             symtype = LIB$K_CLI_LOCAL_SYM;
1589           else symtype = LIB$K_CLI_GLOBAL_SYM;
1590           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1591         }
1592         else {
1593           if (!*eqv) eqvdsc.dsc$w_length = 1;
1594           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1595
1596             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1597             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1598               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1599                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1600               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1601               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1602             }
1603
1604             Newx(ilist,nseg+1,struct itmlst_3);
1605             ile = ilist;
1606             if (!ile) {
1607               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1608               return SS$_INSFMEM;
1609             }
1610             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1611
1612             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1613               ile->itmcode = LNM$_STRING;
1614               ile->bufadr = c;
1615               if ((j+1) == nseg) {
1616                 ile->buflen = strlen(c);
1617                 /* in case we are truncating one that's too long */
1618                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1619               }
1620               else {
1621                 ile->buflen = LNM$C_NAMLENGTH;
1622               }
1623             }
1624
1625             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1626             Safefree (ilist);
1627           }
1628           else {
1629             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1630           }
1631         }
1632       }
1633     }
1634     if (!(retsts & 1)) {
1635       switch (retsts) {
1636         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1637         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1638           set_errno(EVMSERR); break;
1639         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1640         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1641           set_errno(EINVAL); break;
1642         case SS$_NOPRIV:
1643           set_errno(EACCES); break;
1644         default:
1645           _ckvmssts(retsts);
1646           set_errno(EVMSERR);
1647        }
1648        set_vaxc_errno(retsts);
1649        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1650     }
1651     else {
1652       /* We reset error values on success because Perl does an hv_fetch()
1653        * before each hv_store(), and if the thing we're setting didn't
1654        * previously exist, we've got a leftover error message.  (Of course,
1655        * this fails in the face of
1656        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1657        * in that the error reported in $! isn't spurious,
1658        * but it's right more often than not.)
1659        */
1660       set_errno(0); set_vaxc_errno(retsts);
1661       return 0;
1662     }
1663
1664 }  /* end of vmssetenv() */
1665 /*}}}*/
1666
1667 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1668 /* This has to be a function since there's a prototype for it in proto.h */
1669 void
1670 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1671 {
1672     if (lnm && *lnm) {
1673       int len = strlen(lnm);
1674       if  (len == 7) {
1675         char uplnm[8];
1676         int i;
1677         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1678         if (!strcmp(uplnm,"DEFAULT")) {
1679           if (eqv && *eqv) my_chdir(eqv);
1680           return;
1681         }
1682     }
1683   }
1684   (void) vmssetenv(lnm,eqv,NULL);
1685 }
1686 /*}}}*/
1687
1688 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1689 /*  vmssetuserlnm
1690  *  sets a user-mode logical in the process logical name table
1691  *  used for redirection of sys$error
1692  */
1693 void
1694 Perl_vmssetuserlnm(const char *name, const char *eqv)
1695 {
1696     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1697     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1698     unsigned long int iss, attr = LNM$M_CONFINE;
1699     unsigned char acmode = PSL$C_USER;
1700     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1701                                  {0, 0, 0, 0}};
1702     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1703     d_name.dsc$w_length = strlen(name);
1704
1705     lnmlst[0].buflen = strlen(eqv);
1706     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1707
1708     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1709     if (!(iss&1)) lib$signal(iss);
1710 }
1711 /*}}}*/
1712
1713
1714 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1715 /* my_crypt - VMS password hashing
1716  * my_crypt() provides an interface compatible with the Unix crypt()
1717  * C library function, and uses sys$hash_password() to perform VMS
1718  * password hashing.  The quadword hashed password value is returned
1719  * as a NUL-terminated 8 character string.  my_crypt() does not change
1720  * the case of its string arguments; in order to match the behavior
1721  * of LOGINOUT et al., alphabetic characters in both arguments must
1722  *  be upcased by the caller.
1723  *
1724  * - fix me to call ACM services when available
1725  */
1726 char *
1727 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1728 {
1729 #   ifndef UAI$C_PREFERRED_ALGORITHM
1730 #     define UAI$C_PREFERRED_ALGORITHM 127
1731 #   endif
1732     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1733     unsigned short int salt = 0;
1734     unsigned long int sts;
1735     struct const_dsc {
1736         unsigned short int dsc$w_length;
1737         unsigned char      dsc$b_type;
1738         unsigned char      dsc$b_class;
1739         const char *       dsc$a_pointer;
1740     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1741        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1742     struct itmlst_3 uailst[3] = {
1743         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1744         { sizeof salt, UAI$_SALT,    &salt, 0},
1745         { 0,           0,            NULL,  NULL}};
1746     static char hash[9];
1747
1748     usrdsc.dsc$w_length = strlen(usrname);
1749     usrdsc.dsc$a_pointer = usrname;
1750     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1751       switch (sts) {
1752         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1753           set_errno(EACCES);
1754           break;
1755         case RMS$_RNF:
1756           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1757           break;
1758         default:
1759           set_errno(EVMSERR);
1760       }
1761       set_vaxc_errno(sts);
1762       if (sts != RMS$_RNF) return NULL;
1763     }
1764
1765     txtdsc.dsc$w_length = strlen(textpasswd);
1766     txtdsc.dsc$a_pointer = textpasswd;
1767     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1768       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1769     }
1770
1771     return (char *) hash;
1772
1773 }  /* end of my_crypt() */
1774 /*}}}*/
1775
1776
1777 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1778 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1779 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1780
1781 /* fixup barenames that are directories for internal use.
1782  * There have been problems with the consistent handling of UNIX
1783  * style directory names when routines are presented with a name that
1784  * has no directory delimiters at all.  So this routine will eventually
1785  * fix the issue.
1786  */
1787 static char * fixup_bare_dirnames(const char * name)
1788 {
1789   if (decc_disable_to_vms_logname_translation) {
1790 /* fix me */
1791   }
1792   return NULL;
1793 }
1794
1795 /* 8.3, remove() is now broken on symbolic links */
1796 static int rms_erase(const char * vmsname);
1797
1798
1799 /* mp_do_kill_file
1800  * A little hack to get around a bug in some implementation of remove()
1801  * that do not know how to delete a directory
1802  *
1803  * Delete any file to which user has control access, regardless of whether
1804  * delete access is explicitly allowed.
1805  * Limitations: User must have write access to parent directory.
1806  *              Does not block signals or ASTs; if interrupted in midstream
1807  *              may leave file with an altered ACL.
1808  * HANDLE WITH CARE!
1809  */
1810 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1811 static int
1812 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1813 {
1814     char *vmsname;
1815     char *rslt;
1816     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1817     unsigned long int cxt = 0, aclsts, fndsts;
1818     int rmsts = -1;
1819     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1820     struct myacedef {
1821       unsigned char myace$b_length;
1822       unsigned char myace$b_type;
1823       unsigned short int myace$w_flags;
1824       unsigned long int myace$l_access;
1825       unsigned long int myace$l_ident;
1826     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1827                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1828       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1829      struct itmlst_3
1830        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1831                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1832        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1833        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1834        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1835        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1836
1837     /* Expand the input spec using RMS, since the CRTL remove() and
1838      * system services won't do this by themselves, so we may miss
1839      * a file "hiding" behind a logical name or search list. */
1840     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1841     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1842
1843     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1844     if (rslt == NULL) {
1845         PerlMem_free(vmsname);
1846         return -1;
1847       }
1848
1849     /* Erase the file */
1850     rmsts = rms_erase(vmsname);
1851
1852     /* Did it succeed */
1853     if ($VMS_STATUS_SUCCESS(rmsts)) {
1854         PerlMem_free(vmsname);
1855         return 0;
1856       }
1857
1858     /* If not, can changing protections help? */
1859     if (rmsts != RMS$_PRV) {
1860       set_vaxc_errno(rmsts);
1861       PerlMem_free(vmsname);
1862       return -1;
1863     }
1864
1865     /* No, so we get our own UIC to use as a rights identifier,
1866      * and the insert an ACE at the head of the ACL which allows us
1867      * to delete the file.
1868      */
1869     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1870     fildsc.dsc$w_length = strlen(vmsname);
1871     fildsc.dsc$a_pointer = vmsname;
1872     cxt = 0;
1873     newace.myace$l_ident = oldace.myace$l_ident;
1874     rmsts = -1;
1875     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1876       switch (aclsts) {
1877         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1878           set_errno(ENOENT); break;
1879         case RMS$_DIR:
1880           set_errno(ENOTDIR); break;
1881         case RMS$_DEV:
1882           set_errno(ENODEV); break;
1883         case RMS$_SYN: case SS$_INVFILFOROP:
1884           set_errno(EINVAL); break;
1885         case RMS$_PRV:
1886           set_errno(EACCES); break;
1887         default:
1888           _ckvmssts_noperl(aclsts);
1889       }
1890       set_vaxc_errno(aclsts);
1891       PerlMem_free(vmsname);
1892       return -1;
1893     }
1894     /* Grab any existing ACEs with this identifier in case we fail */
1895     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1896     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1897                     || fndsts == SS$_NOMOREACE ) {
1898       /* Add the new ACE . . . */
1899       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1900         goto yourroom;
1901
1902       rmsts = rms_erase(vmsname);
1903       if ($VMS_STATUS_SUCCESS(rmsts)) {
1904         rmsts = 0;
1905         }
1906         else {
1907         rmsts = -1;
1908         /* We blew it - dir with files in it, no write priv for
1909          * parent directory, etc.  Put things back the way they were. */
1910         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1911           goto yourroom;
1912         if (fndsts & 1) {
1913           addlst[0].bufadr = &oldace;
1914           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1915             goto yourroom;
1916         }
1917       }
1918     }
1919
1920     yourroom:
1921     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1922     /* We just deleted it, so of course it's not there.  Some versions of
1923      * VMS seem to return success on the unlock operation anyhow (after all
1924      * the unlock is successful), but others don't.
1925      */
1926     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1927     if (aclsts & 1) aclsts = fndsts;
1928     if (!(aclsts & 1)) {
1929       set_errno(EVMSERR);
1930       set_vaxc_errno(aclsts);
1931     }
1932
1933     PerlMem_free(vmsname);
1934     return rmsts;
1935
1936 }  /* end of kill_file() */
1937 /*}}}*/
1938
1939
1940 /*{{{int do_rmdir(char *name)*/
1941 int
1942 Perl_do_rmdir(pTHX_ const char *name)
1943 {
1944     char * dirfile;
1945     int retval;
1946     Stat_t st;
1947
1948     /* lstat returns a VMS fileified specification of the name */
1949     /* that is looked up, and also lets verifies that this is a directory */
1950
1951     retval = flex_lstat(name, &st);
1952     if (retval != 0) {
1953         char * ret_spec;
1954
1955         /* Due to a historical feature, flex_stat/lstat can not see some */
1956         /* Unix format file names that the rest of the CRTL can see */
1957         /* Fixing that feature will cause some perl tests to fail */
1958         /* So try this one more time. */
1959
1960         retval = lstat(name, &st.crtl_stat);
1961         if (retval != 0)
1962             return -1;
1963
1964         /* force it to a file spec for the kill file to work. */
1965         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1966         if (ret_spec == NULL) {
1967             errno = EIO;
1968             return -1;
1969         }
1970     }
1971
1972     if (!S_ISDIR(st.st_mode)) {
1973         errno = ENOTDIR;
1974         retval = -1;
1975     }
1976     else {
1977         dirfile = st.st_devnam;
1978
1979         /* It may be possible for flex_stat to find a file and vmsify() to */
1980         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
1981         /* with that case, so fail it */
1982         if (dirfile[0] == 0) {
1983             errno = EIO;
1984             return -1;
1985         }
1986
1987         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1988     }
1989
1990     return retval;
1991
1992 }  /* end of do_rmdir */
1993 /*}}}*/
1994
1995 /* kill_file
1996  * Delete any file to which user has control access, regardless of whether
1997  * delete access is explicitly allowed.
1998  * Limitations: User must have write access to parent directory.
1999  *              Does not block signals or ASTs; if interrupted in midstream
2000  *              may leave file with an altered ACL.
2001  * HANDLE WITH CARE!
2002  */
2003 /*{{{int kill_file(char *name)*/
2004 int
2005 Perl_kill_file(pTHX_ const char *name)
2006 {
2007     char * vmsfile;
2008     Stat_t st;
2009     int rmsts;
2010
2011     /* Convert the filename to VMS format and see if it is a directory */
2012     /* flex_lstat returns a vmsified file specification */
2013     rmsts = flex_lstat(name, &st);
2014     if (rmsts != 0) {
2015
2016         /* Due to a historical feature, flex_stat/lstat can not see some */
2017         /* Unix format file names that the rest of the CRTL can see when */
2018         /* ODS-2 file specifications are in use. */
2019         /* Fixing that feature will cause some perl tests to fail */
2020         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2021         st.st_mode = 0;
2022         vmsfile = (char *) name; /* cast ok */
2023
2024     } else {
2025         vmsfile = st.st_devnam;
2026         if (vmsfile[0] == 0) {
2027             /* It may be possible for flex_stat to find a file and vmsify() */
2028             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2029             /* deal with that case, so fail it */
2030             errno = EIO;
2031             return -1;
2032         }
2033     }
2034
2035     /* Remove() is allowed to delete directories, according to the X/Open
2036      * specifications.
2037      * This may need special handling to work with the ACL hacks.
2038      */
2039     if (S_ISDIR(st.st_mode)) {
2040         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2041         return rmsts;
2042     }
2043
2044     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2045
2046     /* Need to delete all versions ? */
2047     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2048         int i = 0;
2049
2050         /* Just use lstat() here as do not need st_dev */
2051         /* and we know that the file is in VMS format or that */
2052         /* because of a historical bug, flex_stat can not see the file */
2053         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2054             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2055             if (rmsts != 0)
2056                 break;
2057             i++;
2058
2059             /* Make sure that we do not loop forever */
2060             if (i > 32767) {
2061                 errno = EIO;
2062                 rmsts = -1;
2063                 break;
2064             }
2065         }
2066     }
2067
2068     return rmsts;
2069
2070 }  /* end of kill_file() */
2071 /*}}}*/
2072
2073
2074 /*{{{int my_mkdir(char *,Mode_t)*/
2075 int
2076 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2077 {
2078   STRLEN dirlen = strlen(dir);
2079
2080   /* zero length string sometimes gives ACCVIO */
2081   if (dirlen == 0) return -1;
2082
2083   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2084    * null file name/type.  However, it's commonplace under Unix,
2085    * so we'll allow it for a gain in portability.
2086    */
2087   if (dir[dirlen-1] == '/') {
2088     char *newdir = savepvn(dir,dirlen-1);
2089     int ret = mkdir(newdir,mode);
2090     Safefree(newdir);
2091     return ret;
2092   }
2093   else return mkdir(dir,mode);
2094 }  /* end of my_mkdir */
2095 /*}}}*/
2096
2097 /*{{{int my_chdir(char *)*/
2098 int
2099 Perl_my_chdir(pTHX_ const char *dir)
2100 {
2101   STRLEN dirlen = strlen(dir);
2102   const char *dir1 = dir;
2103
2104   /* zero length string sometimes gives ACCVIO */
2105   if (dirlen == 0) {
2106     SETERRNO(EINVAL, SS$_BADPARAM);
2107     return -1;
2108   }
2109
2110   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2111    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2112    * so that existing scripts do not need to be changed.
2113    */
2114   while ((dirlen > 0) && (*dir1 == ' ')) {
2115     dir1++;
2116     dirlen--;
2117   }
2118
2119   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2120    * that implies
2121    * null file name/type.  However, it's commonplace under Unix,
2122    * so we'll allow it for a gain in portability.
2123    *
2124    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2125    */
2126   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2127       char *newdir;
2128       int ret;
2129       newdir = (char *)PerlMem_malloc(dirlen);
2130       if (newdir ==NULL)
2131           _ckvmssts_noperl(SS$_INSFMEM);
2132       memcpy(newdir, dir1, dirlen-1);
2133       newdir[dirlen-1] = '\0';
2134       ret = chdir(newdir);
2135       PerlMem_free(newdir);
2136       return ret;
2137   }
2138   else return chdir(dir1);
2139 }  /* end of my_chdir */
2140 /*}}}*/
2141
2142
2143 /*{{{int my_chmod(char *, mode_t)*/
2144 int
2145 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2146 {
2147   Stat_t st;
2148   int ret = -1;
2149   char * changefile;
2150   STRLEN speclen = strlen(file_spec);
2151
2152   /* zero length string sometimes gives ACCVIO */
2153   if (speclen == 0) return -1;
2154
2155   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2156    * that implies null file name/type.  However, it's commonplace under Unix,
2157    * so we'll allow it for a gain in portability.
2158    *
2159    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2160    * in VMS file.dir notation.
2161    */
2162   changefile = (char *) file_spec; /* cast ok */
2163   ret = flex_lstat(file_spec, &st);
2164   if (ret != 0) {
2165
2166         /* Due to a historical feature, flex_stat/lstat can not see some */
2167         /* Unix format file names that the rest of the CRTL can see when */
2168         /* ODS-2 file specifications are in use. */
2169         /* Fixing that feature will cause some perl tests to fail */
2170         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2171         st.st_mode = 0;
2172
2173   } else {
2174       /* It may be possible to get here with nothing in st_devname */
2175       /* chmod still may work though */
2176       if (st.st_devnam[0] != 0) {
2177           changefile = st.st_devnam;
2178       }
2179   }
2180   ret = chmod(changefile, mode);
2181   return ret;
2182 }  /* end of my_chmod */
2183 /*}}}*/
2184
2185
2186 /*{{{FILE *my_tmpfile()*/
2187 FILE *
2188 my_tmpfile(void)
2189 {
2190   FILE *fp;
2191   char *cp;
2192
2193   if ((fp = tmpfile())) return fp;
2194
2195   cp = (char *)PerlMem_malloc(L_tmpnam+24);
2196   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2197
2198   if (decc_filename_unix_only == 0)
2199     strcpy(cp,"Sys$Scratch:");
2200   else
2201     strcpy(cp,"/tmp/");
2202   tmpnam(cp+strlen(cp));
2203   strcat(cp,".Perltmp");
2204   fp = fopen(cp,"w+","fop=dlt");
2205   PerlMem_free(cp);
2206   return fp;
2207 }
2208 /*}}}*/
2209
2210
2211 /*
2212  * The C RTL's sigaction fails to check for invalid signal numbers so we
2213  * help it out a bit.  The docs are correct, but the actual routine doesn't
2214  * do what the docs say it will.
2215  */
2216 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2217 int
2218 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2219                    struct sigaction* oact)
2220 {
2221   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2222         SETERRNO(EINVAL, SS$_INVARG);
2223         return -1;
2224   }
2225   return sigaction(sig, act, oact);
2226 }
2227 /*}}}*/
2228
2229 #ifdef KILL_BY_SIGPRC
2230 #include <errnodef.h>
2231
2232 /* We implement our own kill() using the undocumented system service
2233    sys$sigprc for one of two reasons:
2234
2235    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2236    target process to do a sys$exit, which usually can't be handled
2237    gracefully...certainly not by Perl and the %SIG{} mechanism.
2238
2239    2.) If the kill() in the CRTL can't be called from a signal
2240    handler without disappearing into the ether, i.e., the signal
2241    it purportedly sends is never trapped. Still true as of VMS 7.3.
2242
2243    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2244    in the target process rather than calling sys$exit.
2245
2246    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2247    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2248    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2249    with condition codes C$_SIG0+nsig*8, catching the exception on the
2250    target process and resignaling with appropriate arguments.
2251
2252    But we don't have that VMS 7.0+ exception handler, so if you
2253    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2254
2255    Also note that SIGTERM is listed in the docs as being "unimplemented",
2256    yet always seems to be signaled with a VMS condition code of 4 (and
2257    correctly handled for that code).  So we hardwire it in.
2258
2259    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2260    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2261    than signalling with an unrecognized (and unhandled by CRTL) code.
2262 */
2263
2264 #define _MY_SIG_MAX 28
2265
2266 static unsigned int
2267 Perl_sig_to_vmscondition_int(int sig)
2268 {
2269     static unsigned int sig_code[_MY_SIG_MAX+1] =
2270     {
2271         0,                  /*  0 ZERO     */
2272         SS$_HANGUP,         /*  1 SIGHUP   */
2273         SS$_CONTROLC,       /*  2 SIGINT   */
2274         SS$_CONTROLY,       /*  3 SIGQUIT  */
2275         SS$_RADRMOD,        /*  4 SIGILL   */
2276         SS$_BREAK,          /*  5 SIGTRAP  */
2277         SS$_OPCCUS,         /*  6 SIGABRT  */
2278         SS$_COMPAT,         /*  7 SIGEMT   */
2279 #ifdef __VAX
2280         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2281 #else
2282         SS$_HPARITH,        /*  8 SIGFPE AXP */
2283 #endif
2284         SS$_ABORT,          /*  9 SIGKILL  */
2285         SS$_ACCVIO,         /* 10 SIGBUS   */
2286         SS$_ACCVIO,         /* 11 SIGSEGV  */
2287         SS$_BADPARAM,       /* 12 SIGSYS   */
2288         SS$_NOMBX,          /* 13 SIGPIPE  */
2289         SS$_ASTFLT,         /* 14 SIGALRM  */
2290         4,                  /* 15 SIGTERM  */
2291         0,                  /* 16 SIGUSR1  */
2292         0,                  /* 17 SIGUSR2  */
2293         0,                  /* 18 */
2294         0,                  /* 19 */
2295         0,                  /* 20 SIGCHLD  */
2296         0,                  /* 21 SIGCONT  */
2297         0,                  /* 22 SIGSTOP  */
2298         0,                  /* 23 SIGTSTP  */
2299         0,                  /* 24 SIGTTIN  */
2300         0,                  /* 25 SIGTTOU  */
2301         0,                  /* 26 */
2302         0,                  /* 27 */
2303         0                   /* 28 SIGWINCH  */
2304     };
2305
2306     static int initted = 0;
2307     if (!initted) {
2308         initted = 1;
2309         sig_code[16] = C$_SIGUSR1;
2310         sig_code[17] = C$_SIGUSR2;
2311         sig_code[20] = C$_SIGCHLD;
2312 #if __CRTL_VER >= 70300000
2313         sig_code[28] = C$_SIGWINCH;
2314 #endif
2315     }
2316
2317     if (sig < _SIG_MIN) return 0;
2318     if (sig > _MY_SIG_MAX) return 0;
2319     return sig_code[sig];
2320 }
2321
2322 unsigned int
2323 Perl_sig_to_vmscondition(int sig)
2324 {
2325 #ifdef SS$_DEBUG
2326     if (vms_debug_on_exception != 0)
2327         lib$signal(SS$_DEBUG);
2328 #endif
2329     return Perl_sig_to_vmscondition_int(sig);
2330 }
2331
2332
2333 #define sys$sigprc SYS$SIGPRC
2334 #ifdef __cplusplus
2335 extern "C" {
2336 #endif
2337 int sys$sigprc(unsigned int *pidadr,
2338                struct dsc$descriptor_s *prcname,
2339                unsigned int code);
2340 #ifdef __cplusplus
2341 }
2342 #endif
2343
2344 int
2345 Perl_my_kill(int pid, int sig)
2346 {
2347     int iss;
2348     unsigned int code;
2349
2350      /* sig 0 means validate the PID */
2351     /*------------------------------*/
2352     if (sig == 0) {
2353         const unsigned long int jpicode = JPI$_PID;
2354         pid_t ret_pid;
2355         int status;
2356         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2357         if ($VMS_STATUS_SUCCESS(status))
2358            return 0;
2359         switch (status) {
2360         case SS$_NOSUCHNODE:
2361         case SS$_UNREACHABLE:
2362         case SS$_NONEXPR:
2363            errno = ESRCH;
2364            break;
2365         case SS$_NOPRIV:
2366            errno = EPERM;
2367            break;
2368         default:
2369            errno = EVMSERR;
2370         }
2371         vaxc$errno=status;
2372         return -1;
2373     }
2374
2375     code = Perl_sig_to_vmscondition_int(sig);
2376
2377     if (!code) {
2378         SETERRNO(EINVAL, SS$_BADPARAM);
2379         return -1;
2380     }
2381
2382     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2383      * signals are to be sent to multiple processes.
2384      *  pid = 0 - all processes in group except ones that the system exempts
2385      *  pid = -1 - all processes except ones that the system exempts
2386      *  pid = -n - all processes in group (abs(n)) except ...
2387      * For now, just report as not supported.
2388      */
2389
2390     if (pid <= 0) {
2391         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2392         return -1;
2393     }
2394
2395     iss = sys$sigprc((unsigned int *)&pid,0,code);
2396     if (iss&1) return 0;
2397
2398     switch (iss) {
2399       case SS$_NOPRIV:
2400         set_errno(EPERM);  break;
2401       case SS$_NONEXPR:
2402       case SS$_NOSUCHNODE:
2403       case SS$_UNREACHABLE:
2404         set_errno(ESRCH);  break;
2405       case SS$_INSFMEM:
2406         set_errno(ENOMEM); break;
2407       default:
2408         _ckvmssts_noperl(iss);
2409         set_errno(EVMSERR);
2410     }
2411     set_vaxc_errno(iss);
2412
2413     return -1;
2414 }
2415 #endif
2416
2417 /* Routine to convert a VMS status code to a UNIX status code.
2418 ** More tricky than it appears because of conflicting conventions with
2419 ** existing code.
2420 **
2421 ** VMS status codes are a bit mask, with the least significant bit set for
2422 ** success.
2423 **
2424 ** Special UNIX status of EVMSERR indicates that no translation is currently
2425 ** available, and programs should check the VMS status code.
2426 **
2427 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2428 ** decoding.
2429 */
2430
2431 #ifndef C_FACILITY_NO
2432 #define C_FACILITY_NO 0x350000
2433 #endif
2434 #ifndef DCL_IVVERB
2435 #define DCL_IVVERB 0x38090
2436 #endif
2437
2438 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2439 {
2440 int facility;
2441 int fac_sp;
2442 int msg_no;
2443 int msg_status;
2444 int unix_status;
2445
2446   /* Assume the best or the worst */
2447   if (vms_status & STS$M_SUCCESS)
2448     unix_status = 0;
2449   else
2450     unix_status = EVMSERR;
2451
2452   msg_status = vms_status & ~STS$M_CONTROL;
2453
2454   facility = vms_status & STS$M_FAC_NO;
2455   fac_sp = vms_status & STS$M_FAC_SP;
2456   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2457
2458   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2459     switch(msg_no) {
2460     case SS$_NORMAL:
2461         unix_status = 0;
2462         break;
2463     case SS$_ACCVIO:
2464         unix_status = EFAULT;
2465         break;
2466     case SS$_DEVOFFLINE:
2467         unix_status = EBUSY;
2468         break;
2469     case SS$_CLEARED:
2470         unix_status = ENOTCONN;
2471         break;
2472     case SS$_IVCHAN:
2473     case SS$_IVLOGNAM:
2474     case SS$_BADPARAM:
2475     case SS$_IVLOGTAB:
2476     case SS$_NOLOGNAM:
2477     case SS$_NOLOGTAB:
2478     case SS$_INVFILFOROP:
2479     case SS$_INVARG:
2480     case SS$_NOSUCHID:
2481     case SS$_IVIDENT:
2482         unix_status = EINVAL;
2483         break;
2484     case SS$_UNSUPPORTED:
2485         unix_status = ENOTSUP;
2486         break;
2487     case SS$_FILACCERR:
2488     case SS$_NOGRPPRV:
2489     case SS$_NOSYSPRV:
2490         unix_status = EACCES;
2491         break;
2492     case SS$_DEVICEFULL:
2493         unix_status = ENOSPC;
2494         break;
2495     case SS$_NOSUCHDEV:
2496         unix_status = ENODEV;
2497         break;
2498     case SS$_NOSUCHFILE:
2499     case SS$_NOSUCHOBJECT:
2500         unix_status = ENOENT;
2501         break;
2502     case SS$_ABORT:                                 /* Fatal case */
2503     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2504     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2505         unix_status = EINTR;
2506         break;
2507     case SS$_BUFFEROVF:
2508         unix_status = E2BIG;
2509         break;
2510     case SS$_INSFMEM:
2511         unix_status = ENOMEM;
2512         break;
2513     case SS$_NOPRIV:
2514         unix_status = EPERM;
2515         break;
2516     case SS$_NOSUCHNODE:
2517     case SS$_UNREACHABLE:
2518         unix_status = ESRCH;
2519         break;
2520     case SS$_NONEXPR:
2521         unix_status = ECHILD;
2522         break;
2523     default:
2524         if ((facility == 0) && (msg_no < 8)) {
2525           /* These are not real VMS status codes so assume that they are
2526           ** already UNIX status codes
2527           */
2528           unix_status = msg_no;
2529           break;
2530         }
2531     }
2532   }
2533   else {
2534     /* Translate a POSIX exit code to a UNIX exit code */
2535     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2536         unix_status = (msg_no & 0x07F8) >> 3;
2537     }
2538     else {
2539
2540          /* Documented traditional behavior for handling VMS child exits */
2541         /*--------------------------------------------------------------*/
2542         if (child_flag != 0) {
2543
2544              /* Success / Informational return 0 */
2545             /*----------------------------------*/
2546             if (msg_no & STS$K_SUCCESS)
2547                 return 0;
2548
2549              /* Warning returns 1 */
2550             /*-------------------*/
2551             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2552                 return 1;
2553
2554              /* Everything else pass through the severity bits */
2555             /*------------------------------------------------*/
2556             return (msg_no & STS$M_SEVERITY);
2557         }
2558
2559          /* Normal VMS status to ERRNO mapping attempt */
2560         /*--------------------------------------------*/
2561         switch(msg_status) {
2562         /* case RMS$_EOF: */ /* End of File */
2563         case RMS$_FNF:  /* File Not Found */
2564         case RMS$_DNF:  /* Dir Not Found */
2565                 unix_status = ENOENT;
2566                 break;
2567         case RMS$_RNF:  /* Record Not Found */
2568                 unix_status = ESRCH;
2569                 break;
2570         case RMS$_DIR:
2571                 unix_status = ENOTDIR;
2572                 break;
2573         case RMS$_DEV:
2574                 unix_status = ENODEV;
2575                 break;
2576         case RMS$_IFI:
2577         case RMS$_FAC:
2578         case RMS$_ISI:
2579                 unix_status = EBADF;
2580                 break;
2581         case RMS$_FEX:
2582                 unix_status = EEXIST;
2583                 break;
2584         case RMS$_SYN:
2585         case RMS$_FNM:
2586         case LIB$_INVSTRDES:
2587         case LIB$_INVARG:
2588         case LIB$_NOSUCHSYM:
2589         case LIB$_INVSYMNAM:
2590         case DCL_IVVERB:
2591                 unix_status = EINVAL;
2592                 break;
2593         case CLI$_BUFOVF:
2594         case RMS$_RTB:
2595         case CLI$_TKNOVF:
2596         case CLI$_RSLOVF:
2597                 unix_status = E2BIG;
2598                 break;
2599         case RMS$_PRV:  /* No privilege */
2600         case RMS$_ACC:  /* ACP file access failed */
2601         case RMS$_WLK:  /* Device write locked */
2602                 unix_status = EACCES;
2603                 break;
2604         case RMS$_MKD:  /* Failed to mark for delete */
2605                 unix_status = EPERM;
2606                 break;
2607         /* case RMS$_NMF: */  /* No more files */
2608         }
2609     }
2610   }
2611
2612   return unix_status;
2613 }
2614
2615 /* Try to guess at what VMS error status should go with a UNIX errno
2616  * value.  This is hard to do as there could be many possible VMS
2617  * error statuses that caused the errno value to be set.
2618  */
2619
2620 int Perl_unix_status_to_vms(int unix_status)
2621 {
2622 int test_unix_status;
2623
2624      /* Trivial cases first */
2625     /*---------------------*/
2626     if (unix_status == EVMSERR)
2627         return vaxc$errno;
2628
2629      /* Is vaxc$errno sane? */
2630     /*---------------------*/
2631     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2632     if (test_unix_status == unix_status)
2633         return vaxc$errno;
2634
2635      /* If way out of range, must be VMS code already */
2636     /*-----------------------------------------------*/
2637     if (unix_status > EVMSERR)
2638         return unix_status;
2639
2640      /* If out of range, punt */
2641     /*-----------------------*/
2642     if (unix_status > __ERRNO_MAX)
2643         return SS$_ABORT;
2644
2645
2646      /* Ok, now we have to do it the hard way. */
2647     /*----------------------------------------*/
2648     switch(unix_status) {
2649     case 0:     return SS$_NORMAL;
2650     case EPERM: return SS$_NOPRIV;
2651     case ENOENT: return SS$_NOSUCHOBJECT;
2652     case ESRCH: return SS$_UNREACHABLE;
2653     case EINTR: return SS$_ABORT;
2654     /* case EIO: */
2655     /* case ENXIO:  */
2656     case E2BIG: return SS$_BUFFEROVF;
2657     /* case ENOEXEC */
2658     case EBADF: return RMS$_IFI;
2659     case ECHILD: return SS$_NONEXPR;
2660     /* case EAGAIN */
2661     case ENOMEM: return SS$_INSFMEM;
2662     case EACCES: return SS$_FILACCERR;
2663     case EFAULT: return SS$_ACCVIO;
2664     /* case ENOTBLK */
2665     case EBUSY: return SS$_DEVOFFLINE;
2666     case EEXIST: return RMS$_FEX;
2667     /* case EXDEV */
2668     case ENODEV: return SS$_NOSUCHDEV;
2669     case ENOTDIR: return RMS$_DIR;
2670     /* case EISDIR */
2671     case EINVAL: return SS$_INVARG;
2672     /* case ENFILE */
2673     /* case EMFILE */
2674     /* case ENOTTY */
2675     /* case ETXTBSY */
2676     /* case EFBIG */
2677     case ENOSPC: return SS$_DEVICEFULL;
2678     case ESPIPE: return LIB$_INVARG;
2679     /* case EROFS: */
2680     /* case EMLINK: */
2681     /* case EPIPE: */
2682     /* case EDOM */
2683     case ERANGE: return LIB$_INVARG;
2684     /* case EWOULDBLOCK */
2685     /* case EINPROGRESS */
2686     /* case EALREADY */
2687     /* case ENOTSOCK */
2688     /* case EDESTADDRREQ */
2689     /* case EMSGSIZE */
2690     /* case EPROTOTYPE */
2691     /* case ENOPROTOOPT */
2692     /* case EPROTONOSUPPORT */
2693     /* case ESOCKTNOSUPPORT */
2694     /* case EOPNOTSUPP */
2695     /* case EPFNOSUPPORT */
2696     /* case EAFNOSUPPORT */
2697     /* case EADDRINUSE */
2698     /* case EADDRNOTAVAIL */
2699     /* case ENETDOWN */
2700     /* case ENETUNREACH */
2701     /* case ENETRESET */
2702     /* case ECONNABORTED */
2703     /* case ECONNRESET */
2704     /* case ENOBUFS */
2705     /* case EISCONN */
2706     case ENOTCONN: return SS$_CLEARED;
2707     /* case ESHUTDOWN */
2708     /* case ETOOMANYREFS */
2709     /* case ETIMEDOUT */
2710     /* case ECONNREFUSED */
2711     /* case ELOOP */
2712     /* case ENAMETOOLONG */
2713     /* case EHOSTDOWN */
2714     /* case EHOSTUNREACH */
2715     /* case ENOTEMPTY */
2716     /* case EPROCLIM */
2717     /* case EUSERS  */
2718     /* case EDQUOT  */
2719     /* case ENOMSG  */
2720     /* case EIDRM */
2721     /* case EALIGN */
2722     /* case ESTALE */
2723     /* case EREMOTE */
2724     /* case ENOLCK */
2725     /* case ENOSYS */
2726     /* case EFTYPE */
2727     /* case ECANCELED */
2728     /* case EFAIL */
2729     /* case EINPROG */
2730     case ENOTSUP:
2731         return SS$_UNSUPPORTED;
2732     /* case EDEADLK */
2733     /* case ENWAIT */
2734     /* case EILSEQ */
2735     /* case EBADCAT */
2736     /* case EBADMSG */
2737     /* case EABANDONED */
2738     default:
2739         return SS$_ABORT; /* punt */
2740     }
2741 }
2742
2743
2744 /* default piping mailbox size */
2745 #ifdef __VAX
2746 #  define PERL_BUFSIZ        512
2747 #else
2748 #  define PERL_BUFSIZ        8192
2749 #endif
2750
2751
2752 static void
2753 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2754 {
2755   unsigned long int mbxbufsiz;
2756   static unsigned long int syssize = 0;
2757   unsigned long int dviitm = DVI$_DEVNAM;
2758   char csize[LNM$C_NAMLENGTH+1];
2759   int sts;
2760
2761   if (!syssize) {
2762     unsigned long syiitm = SYI$_MAXBUF;
2763     /*
2764      * Get the SYSGEN parameter MAXBUF
2765      *
2766      * If the logical 'PERL_MBX_SIZE' is defined
2767      * use the value of the logical instead of PERL_BUFSIZ, but
2768      * keep the size between 128 and MAXBUF.
2769      *
2770      */
2771     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2772   }
2773
2774   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2775       mbxbufsiz = atoi(csize);
2776   } else {
2777       mbxbufsiz = PERL_BUFSIZ;
2778   }
2779   if (mbxbufsiz < 128) mbxbufsiz = 128;
2780   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2781
2782   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2783
2784   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2785   _ckvmssts_noperl(sts);
2786   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2787
2788 }  /* end of create_mbx() */
2789
2790
2791 /*{{{  my_popen and my_pclose*/
2792
2793 typedef struct _iosb           IOSB;
2794 typedef struct _iosb*         pIOSB;
2795 typedef struct _pipe           Pipe;
2796 typedef struct _pipe*         pPipe;
2797 typedef struct pipe_details    Info;
2798 typedef struct pipe_details*  pInfo;
2799 typedef struct _srqp            RQE;
2800 typedef struct _srqp*          pRQE;
2801 typedef struct _tochildbuf      CBuf;
2802 typedef struct _tochildbuf*    pCBuf;
2803
2804 struct _iosb {
2805     unsigned short status;
2806     unsigned short count;
2807     unsigned long  dvispec;
2808 };
2809
2810 #pragma member_alignment save
2811 #pragma nomember_alignment quadword
2812 struct _srqp {          /* VMS self-relative queue entry */
2813     unsigned long qptr[2];
2814 };
2815 #pragma member_alignment restore
2816 static RQE  RQE_ZERO = {0,0};
2817
2818 struct _tochildbuf {
2819     RQE             q;
2820     int             eof;
2821     unsigned short  size;
2822     char            *buf;
2823 };
2824
2825 struct _pipe {
2826     RQE            free;
2827     RQE            wait;
2828     int            fd_out;
2829     unsigned short chan_in;
2830     unsigned short chan_out;
2831     char          *buf;
2832     unsigned int   bufsize;
2833     IOSB           iosb;
2834     IOSB           iosb2;
2835     int           *pipe_done;
2836     int            retry;
2837     int            type;
2838     int            shut_on_empty;
2839     int            need_wake;
2840     pPipe         *home;
2841     pInfo          info;
2842     pCBuf          curr;
2843     pCBuf          curr2;
2844 #if defined(PERL_IMPLICIT_CONTEXT)
2845     void            *thx;           /* Either a thread or an interpreter */
2846                                     /* pointer, depending on how we're built */
2847 #endif
2848 };
2849
2850
2851 struct pipe_details
2852 {
2853     pInfo           next;
2854     PerlIO *fp;  /* file pointer to pipe mailbox */
2855     int useFILE; /* using stdio, not perlio */
2856     int pid;   /* PID of subprocess */
2857     int mode;  /* == 'r' if pipe open for reading */
2858     int done;  /* subprocess has completed */
2859     int waiting; /* waiting for completion/closure */
2860     int             closing;        /* my_pclose is closing this pipe */
2861     unsigned long   completion;     /* termination status of subprocess */
2862     pPipe           in;             /* pipe in to sub */
2863     pPipe           out;            /* pipe out of sub */
2864     pPipe           err;            /* pipe of sub's sys$error */
2865     int             in_done;        /* true when in pipe finished */
2866     int             out_done;
2867     int             err_done;
2868     unsigned short  xchan;          /* channel to debug xterm */
2869     unsigned short  xchan_valid;    /* channel is assigned */
2870 };
2871
2872 struct exit_control_block
2873 {
2874     struct exit_control_block *flink;
2875     unsigned long int (*exit_routine)(void);
2876     unsigned long int arg_count;
2877     unsigned long int *status_address;
2878     unsigned long int exit_status;
2879 };
2880
2881 typedef struct _closed_pipes    Xpipe;
2882 typedef struct _closed_pipes*  pXpipe;
2883
2884 struct _closed_pipes {
2885     int             pid;            /* PID of subprocess */
2886     unsigned long   completion;     /* termination status of subprocess */
2887 };
2888 #define NKEEPCLOSED 50
2889 static Xpipe closed_list[NKEEPCLOSED];
2890 static int   closed_index = 0;
2891 static int   closed_num = 0;
2892
2893 #define RETRY_DELAY     "0 ::0.20"
2894 #define MAX_RETRY              50
2895
2896 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2897 static unsigned long mypid;
2898 static unsigned long delaytime[2];
2899
2900 static pInfo open_pipes = NULL;
2901 static $DESCRIPTOR(nl_desc, "NL:");
2902
2903 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2904
2905
2906
2907 static unsigned long int
2908 pipe_exit_routine(void)
2909 {
2910     pInfo info;
2911     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2912     int sts, did_stuff, j;
2913
2914    /*
2915     * Flush any pending i/o, but since we are in process run-down, be
2916     * careful about referencing PerlIO structures that may already have
2917     * been deallocated.  We may not even have an interpreter anymore.
2918     */
2919     info = open_pipes;
2920     while (info) {
2921         if (info->fp) {
2922 #if defined(PERL_IMPLICIT_CONTEXT)
2923            /* We need to use the Perl context of the thread that created */
2924            /* the pipe. */
2925            pTHX;
2926            if (info->err)
2927                aTHX = info->err->thx;
2928            else if (info->out)
2929                aTHX = info->out->thx;
2930            else if (info->in)
2931                aTHX = info->in->thx;
2932 #endif
2933            if (!info->useFILE
2934 #if defined(USE_ITHREADS)
2935              && my_perl
2936 #endif
2937 #ifdef USE_PERLIO
2938              && PL_perlio_fd_refcnt
2939 #endif
2940               )
2941                PerlIO_flush(info->fp);
2942            else
2943                fflush((FILE *)info->fp);
2944         }
2945         info = info->next;
2946     }
2947
2948     /*
2949      next we try sending an EOF...ignore if doesn't work, make sure we
2950      don't hang
2951     */
2952     did_stuff = 0;
2953     info = open_pipes;
2954
2955     while (info) {
2956       _ckvmssts_noperl(sys$setast(0));
2957       if (info->in && !info->in->shut_on_empty) {
2958         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2959                                  0, 0, 0, 0, 0, 0));
2960         info->waiting = 1;
2961         did_stuff = 1;
2962       }
2963       _ckvmssts_noperl(sys$setast(1));
2964       info = info->next;
2965     }
2966
2967     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2968
2969     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2970         int nwait = 0;
2971
2972         info = open_pipes;
2973         while (info) {
2974           _ckvmssts_noperl(sys$setast(0));
2975           if (info->waiting && info->done)
2976                 info->waiting = 0;
2977           nwait += info->waiting;
2978           _ckvmssts_noperl(sys$setast(1));
2979           info = info->next;
2980         }
2981         if (!nwait) break;
2982         sleep(1);
2983     }
2984
2985     did_stuff = 0;
2986     info = open_pipes;
2987     while (info) {
2988       _ckvmssts_noperl(sys$setast(0));
2989       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2990         sts = sys$forcex(&info->pid,0,&abort);
2991         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2992         did_stuff = 1;
2993       }
2994       _ckvmssts_noperl(sys$setast(1));
2995       info = info->next;
2996     }
2997
2998     /* again, wait for effect */
2999
3000     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3001         int nwait = 0;
3002
3003         info = open_pipes;
3004         while (info) {
3005           _ckvmssts_noperl(sys$setast(0));
3006           if (info->waiting && info->done)
3007                 info->waiting = 0;
3008           nwait += info->waiting;
3009           _ckvmssts_noperl(sys$setast(1));
3010           info = info->next;
3011         }
3012         if (!nwait) break;
3013         sleep(1);
3014     }
3015
3016     info = open_pipes;
3017     while (info) {
3018       _ckvmssts_noperl(sys$setast(0));
3019       if (!info->done) {  /* We tried to be nice . . . */
3020         sts = sys$delprc(&info->pid,0);
3021         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3022         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3023       }
3024       _ckvmssts_noperl(sys$setast(1));
3025       info = info->next;
3026     }
3027
3028     while(open_pipes) {
3029
3030 #if defined(PERL_IMPLICIT_CONTEXT)
3031       /* We need to use the Perl context of the thread that created */
3032       /* the pipe. */
3033       pTHX;
3034       if (open_pipes->err)
3035           aTHX = open_pipes->err->thx;
3036       else if (open_pipes->out)
3037           aTHX = open_pipes->out->thx;
3038       else if (open_pipes->in)
3039           aTHX = open_pipes->in->thx;
3040 #endif
3041       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3042       else if (!(sts & 1)) retsts = sts;
3043     }
3044     return retsts;
3045 }
3046
3047 static struct exit_control_block pipe_exitblock =
3048        {(struct exit_control_block *) 0,
3049         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3050
3051 static void pipe_mbxtofd_ast(pPipe p);
3052 static void pipe_tochild1_ast(pPipe p);
3053 static void pipe_tochild2_ast(pPipe p);
3054
3055 static void
3056 popen_completion_ast(pInfo info)
3057 {
3058   pInfo i = open_pipes;
3059   int iss;
3060
3061   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3062   closed_list[closed_index].pid = info->pid;
3063   closed_list[closed_index].completion = info->completion;
3064   closed_index++;
3065   if (closed_index == NKEEPCLOSED)
3066     closed_index = 0;
3067   closed_num++;
3068
3069   while (i) {
3070     if (i == info) break;
3071     i = i->next;
3072   }
3073   if (!i) return;       /* unlinked, probably freed too */
3074
3075   info->done = TRUE;
3076
3077 /*
3078     Writing to subprocess ...
3079             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3080
3081             chan_out may be waiting for "done" flag, or hung waiting
3082             for i/o completion to child...cancel the i/o.  This will
3083             put it into "snarf mode" (done but no EOF yet) that discards
3084             input.
3085
3086     Output from subprocess (stdout, stderr) needs to be flushed and
3087     shut down.   We try sending an EOF, but if the mbx is full the pipe
3088     routine should still catch the "shut_on_empty" flag, telling it to
3089     use immediate-style reads so that "mbx empty" -> EOF.
3090
3091
3092 */
3093   if (info->in && !info->in_done) {               /* only for mode=w */
3094         if (info->in->shut_on_empty && info->in->need_wake) {
3095             info->in->need_wake = FALSE;
3096             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3097         } else {
3098             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3099         }
3100   }
3101
3102   if (info->out && !info->out_done) {             /* were we also piping output? */
3103       info->out->shut_on_empty = TRUE;
3104       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3105       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3106       _ckvmssts_noperl(iss);
3107   }
3108
3109   if (info->err && !info->err_done) {        /* we were piping stderr */
3110         info->err->shut_on_empty = TRUE;
3111         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3112         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3113         _ckvmssts_noperl(iss);
3114   }
3115   _ckvmssts_noperl(sys$setef(pipe_ef));
3116
3117 }
3118
3119 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3120 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3121 static void pipe_infromchild_ast(pPipe p);
3122
3123 /*
3124     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3125     inside an AST routine without worrying about reentrancy and which Perl
3126     memory allocator is being used.
3127
3128     We read data and queue up the buffers, then spit them out one at a
3129     time to the output mailbox when the output mailbox is ready for one.
3130
3131 */
3132 #define INITIAL_TOCHILDQUEUE  2
3133
3134 static pPipe
3135 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3136 {
3137     pPipe p;
3138     pCBuf b;
3139     char mbx1[64], mbx2[64];
3140     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3141                                       DSC$K_CLASS_S, mbx1},
3142                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3143                                       DSC$K_CLASS_S, mbx2};
3144     unsigned int dviitm = DVI$_DEVBUFSIZ;
3145     int j, n;
3146
3147     n = sizeof(Pipe);
3148     _ckvmssts_noperl(lib$get_vm(&n, &p));
3149
3150     create_mbx(&p->chan_in , &d_mbx1);
3151     create_mbx(&p->chan_out, &d_mbx2);
3152     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3153
3154     p->buf           = 0;
3155     p->shut_on_empty = FALSE;
3156     p->need_wake     = FALSE;
3157     p->type          = 0;
3158     p->retry         = 0;
3159     p->iosb.status   = SS$_NORMAL;
3160     p->iosb2.status  = SS$_NORMAL;
3161     p->free          = RQE_ZERO;
3162     p->wait          = RQE_ZERO;
3163     p->curr          = 0;
3164     p->curr2         = 0;
3165     p->info          = 0;
3166 #ifdef PERL_IMPLICIT_CONTEXT
3167     p->thx           = aTHX;
3168 #endif
3169
3170     n = sizeof(CBuf) + p->bufsize;
3171
3172     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3173         _ckvmssts_noperl(lib$get_vm(&n, &b));
3174         b->buf = (char *) b + sizeof(CBuf);
3175         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3176     }
3177
3178     pipe_tochild2_ast(p);
3179     pipe_tochild1_ast(p);
3180     strcpy(wmbx, mbx1);
3181     strcpy(rmbx, mbx2);
3182     return p;
3183 }
3184
3185 /*  reads the MBX Perl is writing, and queues */
3186
3187 static void
3188 pipe_tochild1_ast(pPipe p)
3189 {
3190     pCBuf b = p->curr;
3191     int iss = p->iosb.status;
3192     int eof = (iss == SS$_ENDOFFILE);
3193     int sts;
3194 #ifdef PERL_IMPLICIT_CONTEXT
3195     pTHX = p->thx;
3196 #endif
3197
3198     if (p->retry) {
3199         if (eof) {
3200             p->shut_on_empty = TRUE;
3201             b->eof     = TRUE;
3202             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3203         } else  {
3204             _ckvmssts_noperl(iss);
3205         }
3206
3207         b->eof  = eof;
3208         b->size = p->iosb.count;
3209         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3210         if (p->need_wake) {
3211             p->need_wake = FALSE;
3212             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3213         }
3214     } else {
3215         p->retry = 1;   /* initial call */
3216     }
3217
3218     if (eof) {                  /* flush the free queue, return when done */
3219         int n = sizeof(CBuf) + p->bufsize;
3220         while (1) {
3221             iss = lib$remqti(&p->free, &b);
3222             if (iss == LIB$_QUEWASEMP) return;
3223             _ckvmssts_noperl(iss);
3224             _ckvmssts_noperl(lib$free_vm(&n, &b));
3225         }
3226     }
3227
3228     iss = lib$remqti(&p->free, &b);
3229     if (iss == LIB$_QUEWASEMP) {
3230         int n = sizeof(CBuf) + p->bufsize;
3231         _ckvmssts_noperl(lib$get_vm(&n, &b));
3232         b->buf = (char *) b + sizeof(CBuf);
3233     } else {
3234        _ckvmssts_noperl(iss);
3235     }
3236
3237     p->curr = b;
3238     iss = sys$qio(0,p->chan_in,
3239              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3240              &p->iosb,
3241              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3242     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3243     _ckvmssts_noperl(iss);
3244 }
3245
3246
3247 /* writes queued buffers to output, waits for each to complete before
3248    doing the next */
3249
3250 static void
3251 pipe_tochild2_ast(pPipe p)
3252 {
3253     pCBuf b = p->curr2;
3254     int iss = p->iosb2.status;
3255     int n = sizeof(CBuf) + p->bufsize;
3256     int done = (p->info && p->info->done) ||
3257               iss == SS$_CANCEL || iss == SS$_ABORT;
3258 #if defined(PERL_IMPLICIT_CONTEXT)
3259     pTHX = p->thx;
3260 #endif
3261
3262     do {
3263         if (p->type) {         /* type=1 has old buffer, dispose */
3264             if (p->shut_on_empty) {
3265                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3266             } else {
3267                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3268             }
3269             p->type = 0;
3270         }
3271
3272         iss = lib$remqti(&p->wait, &b);
3273         if (iss == LIB$_QUEWASEMP) {
3274             if (p->shut_on_empty) {
3275                 if (done) {
3276                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3277                     *p->pipe_done = TRUE;
3278                     _ckvmssts_noperl(sys$setef(pipe_ef));
3279                 } else {
3280                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3281                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3282                 }
3283                 return;
3284             }
3285             p->need_wake = TRUE;
3286             return;
3287         }
3288         _ckvmssts_noperl(iss);
3289         p->type = 1;
3290     } while (done);
3291
3292
3293     p->curr2 = b;
3294     if (b->eof) {
3295         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3296             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3297     } else {
3298         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3299             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3300     }
3301
3302     return;
3303
3304 }
3305
3306
3307 static pPipe
3308 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3309 {
3310     pPipe p;
3311     char mbx1[64], mbx2[64];
3312     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3313                                       DSC$K_CLASS_S, mbx1},
3314                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3315                                       DSC$K_CLASS_S, mbx2};
3316     unsigned int dviitm = DVI$_DEVBUFSIZ;
3317
3318     int n = sizeof(Pipe);
3319     _ckvmssts_noperl(lib$get_vm(&n, &p));
3320     create_mbx(&p->chan_in , &d_mbx1);
3321     create_mbx(&p->chan_out, &d_mbx2);
3322
3323     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3324     n = p->bufsize * sizeof(char);
3325     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3326     p->shut_on_empty = FALSE;
3327     p->info   = 0;
3328     p->type   = 0;
3329     p->iosb.status = SS$_NORMAL;
3330 #if defined(PERL_IMPLICIT_CONTEXT)
3331     p->thx = aTHX;
3332 #endif
3333     pipe_infromchild_ast(p);
3334
3335     strcpy(wmbx, mbx1);
3336     strcpy(rmbx, mbx2);
3337     return p;
3338 }
3339
3340 static void
3341 pipe_infromchild_ast(pPipe p)
3342 {
3343     int iss = p->iosb.status;
3344     int eof = (iss == SS$_ENDOFFILE);
3345     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3346     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3347 #if defined(PERL_IMPLICIT_CONTEXT)
3348     pTHX = p->thx;
3349 #endif
3350
3351     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3352         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3353         p->chan_out = 0;
3354     }
3355
3356     /* read completed:
3357             input shutdown if EOF from self (done or shut_on_empty)
3358             output shutdown if closing flag set (my_pclose)
3359             send data/eof from child or eof from self
3360             otherwise, re-read (snarf of data from child)
3361     */
3362
3363     if (p->type == 1) {
3364         p->type = 0;
3365         if (myeof && p->chan_in) {                  /* input shutdown */
3366             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3367             p->chan_in = 0;
3368         }
3369
3370         if (p->chan_out) {
3371             if (myeof || kideof) {      /* pass EOF to parent */
3372                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3373                                          pipe_infromchild_ast, p,
3374                                          0, 0, 0, 0, 0, 0));
3375                 return;
3376             } else if (eof) {       /* eat EOF --- fall through to read*/
3377
3378             } else {                /* transmit data */
3379                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3380                                          pipe_infromchild_ast,p,
3381                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3382                 return;
3383             }
3384         }
3385     }
3386
3387     /*  everything shut? flag as done */
3388
3389     if (!p->chan_in && !p->chan_out) {
3390         *p->pipe_done = TRUE;
3391         _ckvmssts_noperl(sys$setef(pipe_ef));
3392         return;
3393     }
3394
3395     /* write completed (or read, if snarfing from child)
3396             if still have input active,
3397                queue read...immediate mode if shut_on_empty so we get EOF if empty
3398             otherwise,
3399                check if Perl reading, generate EOFs as needed
3400     */
3401
3402     if (p->type == 0) {
3403         p->type = 1;
3404         if (p->chan_in) {
3405             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3406                           pipe_infromchild_ast,p,
3407                           p->buf, p->bufsize, 0, 0, 0, 0);
3408             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3409             _ckvmssts_noperl(iss);
3410         } else {           /* send EOFs for extra reads */
3411             p->iosb.status = SS$_ENDOFFILE;
3412             p->iosb.dvispec = 0;
3413             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3414                                      0, 0, 0,
3415                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3416         }
3417     }
3418 }
3419
3420 static pPipe
3421 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3422 {
3423     pPipe p;
3424     char mbx[64];
3425     unsigned long dviitm = DVI$_DEVBUFSIZ;
3426     struct stat s;
3427     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3428                                       DSC$K_CLASS_S, mbx};
3429     int n = sizeof(Pipe);
3430
3431     /* things like terminals and mbx's don't need this filter */
3432     if (fd && fstat(fd,&s) == 0) {
3433         unsigned long devchar;
3434         char device[65];
3435         unsigned short dev_len;
3436         struct dsc$descriptor_s d_dev;
3437         char * cptr;
3438         struct item_list_3 items[3];
3439         int status;
3440         unsigned short dvi_iosb[4];
3441
3442         cptr = getname(fd, out, 1);
3443         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3444         d_dev.dsc$a_pointer = out;
3445         d_dev.dsc$w_length = strlen(out);
3446         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3447         d_dev.dsc$b_class = DSC$K_CLASS_S;
3448
3449         items[0].len = 4;
3450         items[0].code = DVI$_DEVCHAR;
3451         items[0].bufadr = &devchar;
3452         items[0].retadr = NULL;
3453         items[1].len = 64;
3454         items[1].code = DVI$_FULLDEVNAM;
3455         items[1].bufadr = device;
3456         items[1].retadr = &dev_len;
3457         items[2].len = 0;
3458         items[2].code = 0;
3459
3460         status = sys$getdviw
3461                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3462         _ckvmssts_noperl(status);
3463         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3464             device[dev_len] = 0;
3465
3466             if (!(devchar & DEV$M_DIR)) {
3467                 strcpy(out, device);
3468                 return 0;
3469             }
3470         }
3471     }
3472
3473     _ckvmssts_noperl(lib$get_vm(&n, &p));
3474     p->fd_out = dup(fd);
3475     create_mbx(&p->chan_in, &d_mbx);
3476     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3477     n = (p->bufsize+1) * sizeof(char);
3478     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3479     p->shut_on_empty = FALSE;
3480     p->retry = 0;
3481     p->info  = 0;
3482     strcpy(out, mbx);
3483
3484     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3485                              pipe_mbxtofd_ast, p,
3486                              p->buf, p->bufsize, 0, 0, 0, 0));
3487
3488     return p;
3489 }
3490
3491 static void
3492 pipe_mbxtofd_ast(pPipe p)
3493 {
3494     int iss = p->iosb.status;
3495     int done = p->info->done;
3496     int iss2;
3497     int eof = (iss == SS$_ENDOFFILE);
3498     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3499     int err = !(iss&1) && !eof;
3500 #if defined(PERL_IMPLICIT_CONTEXT)
3501     pTHX = p->thx;
3502 #endif
3503
3504     if (done && myeof) {               /* end piping */
3505         close(p->fd_out);
3506         sys$dassgn(p->chan_in);
3507         *p->pipe_done = TRUE;
3508         _ckvmssts_noperl(sys$setef(pipe_ef));
3509         return;
3510     }
3511
3512     if (!err && !eof) {             /* good data to send to file */
3513         p->buf[p->iosb.count] = '\n';
3514         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3515         if (iss2 < 0) {
3516             p->retry++;
3517             if (p->retry < MAX_RETRY) {
3518                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3519                 return;
3520             }
3521         }
3522         p->retry = 0;
3523     } else if (err) {
3524         _ckvmssts_noperl(iss);
3525     }
3526
3527
3528     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3529           pipe_mbxtofd_ast, p,
3530           p->buf, p->bufsize, 0, 0, 0, 0);
3531     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3532     _ckvmssts_noperl(iss);
3533 }
3534
3535
3536 typedef struct _pipeloc     PLOC;
3537 typedef struct _pipeloc*   pPLOC;
3538
3539 struct _pipeloc {
3540     pPLOC   next;
3541     char    dir[NAM$C_MAXRSS+1];
3542 };
3543 static pPLOC  head_PLOC = 0;
3544
3545 void
3546 free_pipelocs(pTHX_ void *head)
3547 {
3548     pPLOC p, pnext;
3549     pPLOC *pHead = (pPLOC *)head;
3550
3551     p = *pHead;
3552     while (p) {
3553         pnext = p->next;
3554         PerlMem_free(p);
3555         p = pnext;
3556     }
3557     *pHead = 0;
3558 }
3559
3560 static void
3561 store_pipelocs(pTHX)
3562 {
3563     int    i;
3564     pPLOC  p;
3565     AV    *av = 0;
3566     SV    *dirsv;
3567     char  *dir, *x;
3568     char  *unixdir;
3569     char  temp[NAM$C_MAXRSS+1];
3570     STRLEN n_a;
3571
3572     if (head_PLOC)
3573         free_pipelocs(aTHX_ &head_PLOC);
3574
3575 /*  the . directory from @INC comes last */
3576
3577     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3578     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3579     p->next = head_PLOC;
3580     head_PLOC = p;
3581     strcpy(p->dir,"./");
3582
3583 /*  get the directory from $^X */
3584
3585     unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3586     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3587
3588 #ifdef PERL_IMPLICIT_CONTEXT
3589     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3590 #else
3591     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3592 #endif
3593         my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3594         x = strrchr(temp,']');
3595         if (x == NULL) {
3596         x = strrchr(temp,'>');
3597           if (x == NULL) {
3598             /* It could be a UNIX path */
3599             x = strrchr(temp,'/');
3600           }
3601         }
3602         if (x)
3603           x[1] = '\0';
3604         else {
3605           /* Got a bare name, so use default directory */
3606           temp[0] = '.';
3607           temp[1] = '\0';
3608         }
3609
3610         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3611             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3612             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3613             p->next = head_PLOC;
3614             head_PLOC = p;
3615             my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3616         }
3617     }
3618
3619 /*  reverse order of @INC entries, skip "." since entered above */
3620
3621 #ifdef PERL_IMPLICIT_CONTEXT
3622     if (aTHX)
3623 #endif
3624     if (PL_incgv) av = GvAVn(PL_incgv);
3625
3626     for (i = 0; av && i <= AvFILL(av); i++) {
3627         dirsv = *av_fetch(av,i,TRUE);
3628
3629         if (SvROK(dirsv)) continue;
3630         dir = SvPVx(dirsv,n_a);
3631         if (strcmp(dir,".") == 0) continue;
3632         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3633             continue;
3634
3635         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3636         p->next = head_PLOC;
3637         head_PLOC = p;
3638         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3639     }
3640
3641 /* most likely spot (ARCHLIB) put first in the list */
3642
3643 #ifdef ARCHLIB_EXP
3644     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3645         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3646         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3647         p->next = head_PLOC;
3648         head_PLOC = p;
3649         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3650     }
3651 #endif
3652     PerlMem_free(unixdir);
3653 }
3654
3655 static I32
3656 Perl_cando_by_name_int
3657    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3658 #if !defined(PERL_IMPLICIT_CONTEXT)
3659 #define cando_by_name_int               Perl_cando_by_name_int
3660 #else
3661 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3662 #endif
3663
3664 static char *
3665 find_vmspipe(pTHX)
3666 {
3667     static int   vmspipe_file_status = 0;
3668     static char  vmspipe_file[NAM$C_MAXRSS+1];
3669
3670     /* already found? Check and use ... need read+execute permission */
3671
3672     if (vmspipe_file_status == 1) {
3673         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3674          && cando_by_name_int
3675            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3676             return vmspipe_file;
3677         }
3678         vmspipe_file_status = 0;
3679     }
3680
3681     /* scan through stored @INC, $^X */
3682
3683     if (vmspipe_file_status == 0) {
3684         char file[NAM$C_MAXRSS+1];
3685         pPLOC  p = head_PLOC;
3686
3687         while (p) {
3688             char * exp_res;
3689             int dirlen;
3690             dirlen = my_strlcpy(file, p->dir, sizeof(file));
3691             my_strlcat(file, "vmspipe.com", sizeof(file));
3692             p = p->next;
3693
3694             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3695             if (!exp_res) continue;
3696
3697             if (cando_by_name_int
3698                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3699              && cando_by_name_int
3700                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3701                 vmspipe_file_status = 1;
3702                 return vmspipe_file;
3703             }
3704         }
3705         vmspipe_file_status = -1;   /* failed, use tempfiles */
3706     }
3707
3708     return 0;
3709 }
3710
3711 static FILE *
3712 vmspipe_tempfile(pTHX)
3713 {
3714     char file[NAM$C_MAXRSS+1];
3715     FILE *fp;
3716     static int index = 0;
3717     Stat_t s0, s1;
3718     int cmp_result;
3719
3720     /* create a tempfile */
3721
3722     /* we can't go from   W, shr=get to  R, shr=get without
3723        an intermediate vulnerable state, so don't bother trying...
3724
3725        and lib$spawn doesn't shr=put, so have to close the write
3726
3727        So... match up the creation date/time and the FID to
3728        make sure we're dealing with the same file
3729
3730     */
3731
3732     index++;
3733     if (!decc_filename_unix_only) {
3734       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3735       fp = fopen(file,"w");
3736       if (!fp) {
3737         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3738         fp = fopen(file,"w");
3739         if (!fp) {
3740             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3741             fp = fopen(file,"w");
3742         }
3743       }
3744      }
3745      else {
3746       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3747       fp = fopen(file,"w");
3748       if (!fp) {
3749         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3750         fp = fopen(file,"w");
3751         if (!fp) {
3752           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3753           fp = fopen(file,"w");
3754         }
3755       }
3756     }
3757     if (!fp) return 0;  /* we're hosed */
3758
3759     fprintf(fp,"$! 'f$verify(0)'\n");
3760     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3761     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3762     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3763     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3764     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3765     fprintf(fp,"$ perl_del    = \"delete\"\n");
3766     fprintf(fp,"$ pif         = \"if\"\n");
3767     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3768     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3769     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3770     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3771     fprintf(fp,"$!  --- build command line to get max possible length\n");
3772     fprintf(fp,"$c=perl_popen_cmd0\n");
3773     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3774     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3775     fprintf(fp,"$x=perl_popen_cmd3\n");
3776     fprintf(fp,"$c=c+x\n");
3777     fprintf(fp,"$ perl_on\n");
3778     fprintf(fp,"$ 'c'\n");
3779     fprintf(fp,"$ perl_status = $STATUS\n");
3780     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3781     fprintf(fp,"$ perl_exit 'perl_status'\n");
3782     fsync(fileno(fp));
3783
3784     fgetname(fp, file, 1);
3785     fstat(fileno(fp), &s0.crtl_stat);
3786     fclose(fp);
3787
3788     if (decc_filename_unix_only)
3789         int_tounixspec(file, file, NULL);
3790     fp = fopen(file,"r","shr=get");
3791     if (!fp) return 0;
3792     fstat(fileno(fp), &s1.crtl_stat);
3793
3794     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3795     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3796         fclose(fp);
3797         return 0;
3798     }
3799
3800     return fp;
3801 }
3802
3803
3804 static int vms_is_syscommand_xterm(void)
3805 {
3806     const static struct dsc$descriptor_s syscommand_dsc =
3807       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3808
3809     const static struct dsc$descriptor_s decwdisplay_dsc =
3810       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3811
3812     struct item_list_3 items[2];
3813     unsigned short dvi_iosb[4];
3814     unsigned long devchar;
3815     unsigned long devclass;
3816     int status;
3817
3818     /* Very simple check to guess if sys$command is a decterm? */
3819     /* First see if the DECW$DISPLAY: device exists */
3820     items[0].len = 4;
3821     items[0].code = DVI$_DEVCHAR;
3822     items[0].bufadr = &devchar;
3823     items[0].retadr = NULL;
3824     items[1].len = 0;
3825     items[1].code = 0;
3826
3827     status = sys$getdviw
3828         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3829
3830     if ($VMS_STATUS_SUCCESS(status)) {
3831         status = dvi_iosb[0];
3832     }
3833
3834     if (!$VMS_STATUS_SUCCESS(status)) {
3835         SETERRNO(EVMSERR, status);
3836         return -1;
3837     }
3838
3839     /* If it does, then for now assume that we are on a workstation */
3840     /* Now verify that SYS$COMMAND is a terminal */
3841     /* for creating the debugger DECTerm */
3842
3843     items[0].len = 4;
3844     items[0].code = DVI$_DEVCLASS;
3845     items[0].bufadr = &devclass;
3846     items[0].retadr = NULL;
3847     items[1].len = 0;
3848     items[1].code = 0;
3849
3850     status = sys$getdviw
3851         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3852
3853     if ($VMS_STATUS_SUCCESS(status)) {
3854         status = dvi_iosb[0];
3855     }
3856
3857     if (!$VMS_STATUS_SUCCESS(status)) {
3858         SETERRNO(EVMSERR, status);
3859         return -1;
3860     }
3861     else {
3862         if (devclass == DC$_TERM) {
3863             return 0;
3864         }
3865     }
3866     return -1;
3867 }
3868
3869 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3870 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3871 {
3872     int status;
3873     int ret_stat;
3874     char * ret_char;
3875     char device_name[65];
3876     unsigned short device_name_len;
3877     struct dsc$descriptor_s customization_dsc;
3878     struct dsc$descriptor_s device_name_dsc;
3879     const char * cptr;
3880     char customization[200];
3881     char title[40];
3882     pInfo info = NULL;
3883     char mbx1[64];
3884     unsigned short p_chan;
3885     int n;
3886     unsigned short iosb[4];
3887     const char * cust_str =
3888         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3889     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3890                                           DSC$K_CLASS_S, mbx1};
3891
3892      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3893     /*---------------------------------------*/
3894     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3895
3896
3897     /* Make sure that this is from the Perl debugger */
3898     ret_char = strstr(cmd," xterm ");
3899     if (ret_char == NULL)
3900         return NULL;
3901     cptr = ret_char + 7;
3902     ret_char = strstr(cmd,"tty");
3903     if (ret_char == NULL)
3904         return NULL;
3905     ret_char = strstr(cmd,"sleep");
3906     if (ret_char == NULL)
3907         return NULL;
3908
3909     if (decw_term_port == 0) {
3910         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3911         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3912         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3913
3914        status = lib$find_image_symbol
3915                                (&filename1_dsc,
3916                                 &decw_term_port_dsc,
3917                                 (void *)&decw_term_port,
3918                                 NULL,
3919                                 0);
3920
3921         /* Try again with the other image name */
3922         if (!$VMS_STATUS_SUCCESS(status)) {
3923
3924            status = lib$find_image_symbol
3925                                (&filename2_dsc,
3926                                 &decw_term_port_dsc,
3927                                 (void *)&decw_term_port,
3928                                 NULL,
3929                                 0);
3930
3931         }
3932
3933     }
3934
3935
3936     /* No decw$term_port, give it up */
3937     if (!$VMS_STATUS_SUCCESS(status))
3938         return NULL;
3939
3940     /* Are we on a workstation? */
3941     /* to do: capture the rows / columns and pass their properties */
3942     ret_stat = vms_is_syscommand_xterm();
3943     if (ret_stat < 0)
3944         return NULL;
3945
3946     /* Make the title: */
3947     ret_char = strstr(cptr,"-title");
3948     if (ret_char != NULL) {
3949         while ((*cptr != 0) && (*cptr != '\"')) {
3950             cptr++;
3951         }
3952         if (*cptr == '\"')
3953             cptr++;
3954         n = 0;
3955         while ((*cptr != 0) && (*cptr != '\"')) {
3956             title[n] = *cptr;
3957             n++;
3958             if (n == 39) {
3959                 title[39] = 0;
3960                 break;
3961             }
3962             cptr++;
3963         }
3964         title[n] = 0;
3965     }
3966     else {
3967             /* Default title */
3968             strcpy(title,"Perl Debug DECTerm");
3969     }
3970     sprintf(customization, cust_str, title);
3971
3972     customization_dsc.dsc$a_pointer = customization;
3973     customization_dsc.dsc$w_length = strlen(customization);
3974     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3975     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3976
3977     device_name_dsc.dsc$a_pointer = device_name;
3978     device_name_dsc.dsc$w_length = sizeof device_name -1;
3979     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3980     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3981
3982     device_name_len = 0;
3983
3984     /* Try to create the window */
3985      status = (*decw_term_port)
3986        (NULL,
3987         NULL,
3988         &customization_dsc,
3989         &device_name_dsc,
3990         &device_name_len,
3991         NULL,
3992         NULL,
3993         NULL);
3994     if (!$VMS_STATUS_SUCCESS(status)) {
3995         SETERRNO(EVMSERR, status);
3996         return NULL;
3997     }
3998
3999     device_name[device_name_len] = '\0';
4000
4001     /* Need to set this up to look like a pipe for cleanup */
4002     n = sizeof(Info);
4003     status = lib$get_vm(&n, &info);
4004     if (!$VMS_STATUS_SUCCESS(status)) {
4005         SETERRNO(ENOMEM, status);
4006         return NULL;
4007     }
4008
4009     info->mode = *mode;
4010     info->done = FALSE;
4011     info->completion = 0;
4012     info->closing    = FALSE;
4013     info->in         = 0;
4014     info->out        = 0;
4015     info->err        = 0;
4016     info->fp         = NULL;
4017     info->useFILE    = 0;
4018     info->waiting    = 0;
4019     info->in_done    = TRUE;
4020     info->out_done   = TRUE;
4021     info->err_done   = TRUE;
4022
4023     /* Assign a channel on this so that it will persist, and not login */
4024     /* We stash this channel in the info structure for reference. */
4025     /* The created xterm self destructs when the last channel is removed */
4026     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4027     /* So leave this assigned. */
4028     device_name_dsc.dsc$w_length = device_name_len;
4029     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4030     if (!$VMS_STATUS_SUCCESS(status)) {
4031         SETERRNO(EVMSERR, status);
4032         return NULL;
4033     }
4034     info->xchan_valid = 1;
4035
4036     /* Now create a mailbox to be read by the application */
4037
4038     create_mbx(&p_chan, &d_mbx1);
4039
4040     /* write the name of the created terminal to the mailbox */
4041     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4042             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4043
4044     if (!$VMS_STATUS_SUCCESS(status)) {
4045         SETERRNO(EVMSERR, status);
4046         return NULL;
4047     }
4048
4049     info->fp  = PerlIO_open(mbx1, mode);
4050
4051     /* Done with this channel */
4052     sys$dassgn(p_chan);
4053
4054     /* If any errors, then clean up */
4055     if (!info->fp) {
4056         n = sizeof(Info);
4057         _ckvmssts_noperl(lib$free_vm(&n, &info));
4058         return NULL;
4059         }
4060
4061     /* All done */
4062     return info->fp;
4063 }
4064
4065 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4066
4067 static PerlIO *
4068 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4069 {
4070     static int handler_set_up = FALSE;
4071     PerlIO * ret_fp;
4072     unsigned long int sts, flags = CLI$M_NOWAIT;
4073     /* The use of a GLOBAL table (as was done previously) rendered
4074      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4075      * environment.  Hence we've switched to LOCAL symbol table.
4076      */
4077     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4078     int j, wait = 0, n;
4079     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4080     char *in, *out, *err, mbx[512];
4081     FILE *tpipe = 0;
4082     char tfilebuf[NAM$C_MAXRSS+1];
4083     pInfo info = NULL;
4084     char cmd_sym_name[20];
4085     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4086                                       DSC$K_CLASS_S, symbol};
4087     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4088                                       DSC$K_CLASS_S, 0};
4089     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4090                                       DSC$K_CLASS_S, cmd_sym_name};
4091     struct dsc$descriptor_s *vmscmd;
4092     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4093     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4094     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4095
4096     /* Check here for Xterm create request.  This means looking for
4097      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4098      *  is possible to create an xterm.
4099      */
4100     if (*in_mode == 'r') {
4101         PerlIO * xterm_fd;
4102
4103 #if defined(PERL_IMPLICIT_CONTEXT)
4104         /* Can not fork an xterm with a NULL context */
4105         /* This probably could never happen */
4106         xterm_fd = NULL;
4107         if (aTHX != NULL)
4108 #endif
4109         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4110         if (xterm_fd != NULL)
4111             return xterm_fd;
4112     }
4113
4114     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4115
4116     /* once-per-program initialization...
4117        note that the SETAST calls and the dual test of pipe_ef
4118        makes sure that only the FIRST thread through here does
4119        the initialization...all other threads wait until it's
4120        done.
4121
4122        Yeah, uglier than a pthread call, it's got all the stuff inline
4123        rather than in a separate routine.
4124     */
4125
4126     if (!pipe_ef) {
4127         _ckvmssts_noperl(sys$setast(0));
4128         if (!pipe_ef) {
4129             unsigned long int pidcode = JPI$_PID;
4130             $DESCRIPTOR(d_delay, RETRY_DELAY);
4131             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4132             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4133             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4134         }
4135         if (!handler_set_up) {
4136           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4137           handler_set_up = TRUE;
4138         }
4139         _ckvmssts_noperl(sys$setast(1));
4140     }
4141
4142     /* see if we can find a VMSPIPE.COM */
4143
4144     tfilebuf[0] = '@';
4145     vmspipe = find_vmspipe(aTHX);
4146     if (vmspipe) {
4147         vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4148     } else {        /* uh, oh...we're in tempfile hell */
4149         tpipe = vmspipe_tempfile(aTHX);
4150         if (!tpipe) {       /* a fish popular in Boston */
4151             if (ckWARN(WARN_PIPE)) {
4152                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4153             }
4154         return NULL;
4155         }
4156         fgetname(tpipe,tfilebuf+1,1);
4157         vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4158     }
4159     vmspipedsc.dsc$a_pointer = tfilebuf;
4160
4161     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4162     if (!(sts & 1)) {
4163       switch (sts) {
4164         case RMS$_FNF:  case RMS$_DNF:
4165           set_errno(ENOENT); break;
4166         case RMS$_DIR:
4167           set_errno(ENOTDIR); break;
4168         case RMS$_DEV:
4169           set_errno(ENODEV); break;
4170         case RMS$_PRV:
4171           set_errno(EACCES); break;
4172         case RMS$_SYN:
4173           set_errno(EINVAL); break;
4174         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4175           set_errno(E2BIG); break;
4176         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4177           _ckvmssts_noperl(sts); /* fall through */
4178         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4179           set_errno(EVMSERR);
4180       }
4181       set_vaxc_errno(sts);
4182       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4183         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4184       }
4185       *psts = sts;
4186       return NULL;
4187     }
4188     n = sizeof(Info);
4189     _ckvmssts_noperl(lib$get_vm(&n, &info));
4190
4191     my_strlcpy(mode, in_mode, sizeof(mode));
4192     info->mode = *mode;
4193     info->done = FALSE;
4194     info->completion = 0;
4195     info->closing    = FALSE;
4196     info->in         = 0;
4197     info->out        = 0;
4198     info->err        = 0;
4199     info->fp         = NULL;
4200     info->useFILE    = 0;
4201     info->waiting    = 0;
4202     info->in_done    = TRUE;
4203     info->out_done   = TRUE;
4204     info->err_done   = TRUE;
4205     info->xchan      = 0;
4206     info->xchan_valid = 0;
4207
4208     in = (char *)PerlMem_malloc(VMS_MAXRSS);
4209     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4210     out = (char *)PerlMem_malloc(VMS_MAXRSS);
4211     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4212     err = (char *)PerlMem_malloc(VMS_MAXRSS);
4213     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4214
4215     in[0] = out[0] = err[0] = '\0';
4216
4217     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4218         info->useFILE = 1;
4219         strcpy(p,p+1);
4220     }
4221     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4222         wait = 1;
4223         strcpy(p,p+1);
4224     }
4225
4226     if (*mode == 'r') {             /* piping from subroutine */
4227
4228         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4229         if (info->out) {
4230             info->out->pipe_done = &info->out_done;
4231             info->out_done = FALSE;
4232             info->out->info = info;
4233         }
4234         if (!info->useFILE) {
4235             info->fp  = PerlIO_open(mbx, mode);
4236         } else {
4237             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4238             vmssetuserlnm("SYS$INPUT", mbx);
4239         }
4240
4241         if (!info->fp && info->out) {
4242             sys$cancel(info->out->chan_out);
4243
4244             while (!info->out_done) {
4245                 int done;
4246                 _ckvmssts_noperl(sys$setast(0));
4247                 done = info->out_done;
4248                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4249                 _ckvmssts_noperl(sys$setast(1));
4250                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4251             }
4252
4253             if (info->out->buf) {
4254                 n = info->out->bufsize * sizeof(char);
4255                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4256             }
4257             n = sizeof(Pipe);
4258             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4259             n = sizeof(Info);
4260             _ckvmssts_noperl(lib$free_vm(&n, &info));
4261             *psts = RMS$_FNF;
4262             return NULL;
4263         }
4264
4265         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4266         if (info->err) {
4267             info->err->pipe_done = &info->err_done;
4268             info->err_done = FALSE;
4269             info->err->info = info;
4270         }
4271
4272     } else if (*mode == 'w') {      /* piping to subroutine */
4273
4274         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4275         if (info->out) {
4276             info->out->pipe_done = &info->out_done;
4277             info->out_done = FALSE;
4278             info->out->info = info;
4279         }
4280
4281         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4282         if (info->err) {
4283             info->err->pipe_done = &info->err_done;
4284             info->err_done = FALSE;
4285             info->err->info = info;
4286         }
4287
4288         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4289         if (!info->useFILE) {
4290             info->fp  = PerlIO_open(mbx, mode);
4291         } else {
4292             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4293             vmssetuserlnm("SYS$OUTPUT", mbx);
4294         }
4295
4296         if (info->in) {
4297             info->in->pipe_done = &info->in_done;
4298             info->in_done = FALSE;
4299             info->in->info = info;
4300         }
4301
4302         /* error cleanup */
4303         if (!info->fp && info->in) {
4304             info->done = TRUE;
4305             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4306                                       0, 0, 0, 0, 0, 0, 0, 0));
4307
4308             while (!info->in_done) {
4309                 int done;
4310                 _ckvmssts_noperl(sys$setast(0));
4311                 done = info->in_done;
4312                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4313                 _ckvmssts_noperl(sys$setast(1));
4314                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4315             }
4316
4317             if (info->in->buf) {
4318                 n = info->in->bufsize * sizeof(char);
4319                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4320             }
4321             n = sizeof(Pipe);
4322             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4323             n = sizeof(Info);
4324             _ckvmssts_noperl(lib$free_vm(&n, &info));
4325             *psts = RMS$_FNF;
4326             return NULL;
4327         }
4328
4329
4330     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4331         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4332         if (info->out) {
4333             info->out->pipe_done = &info->out_done;
4334             info->out_done = FALSE;
4335             info->out->info = info;
4336         }
4337
4338         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4339         if (info->err) {
4340             info->err->pipe_done = &info->err_done;
4341             info->err_done = FALSE;
4342             info->err->info = info;
4343         }
4344     }
4345
4346     d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4347     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4348
4349     d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4350     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4351
4352     d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4353     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4354
4355     /* Done with the names for the pipes */
4356     PerlMem_free(err);
4357     PerlMem_free(out);
4358     PerlMem_free(in);
4359
4360     p = vmscmd->dsc$a_pointer;
4361     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4362     if (*p == '$') p++;                         /* remove leading $ */
4363     while (*p == ' ' || *p == '\t') p++;
4364
4365     for (j = 0; j < 4; j++) {
4366         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4367         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4368
4369     d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4370     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4371
4372         if (strlen(p) > MAX_DCL_SYMBOL) {
4373             p += MAX_DCL_SYMBOL;
4374         } else {
4375             p += strlen(p);
4376         }
4377     }
4378     _ckvmssts_noperl(sys$setast(0));
4379     info->next=open_pipes;  /* prepend to list */
4380     open_pipes=info;
4381     _ckvmssts_noperl(sys$setast(1));
4382     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4383      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4384      * have SYS$COMMAND if we need it.
4385      */
4386     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4387                       0, &info->pid, &info->completion,
4388                       0, popen_completion_ast,info,0,0,0));
4389
4390     /* if we were using a tempfile, close it now */
4391
4392     if (tpipe) fclose(tpipe);
4393
4394     /* once the subprocess is spawned, it has copied the symbols and
4395        we can get rid of ours */
4396
4397     for (j = 0; j < 4; j++) {
4398         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4399         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4400     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4401     }
4402     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4403     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4404     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4405     vms_execfree(vmscmd);
4406
4407 #ifdef PERL_IMPLICIT_CONTEXT
4408     if (aTHX)
4409 #endif
4410     PL_forkprocess = info->pid;
4411
4412     ret_fp = info->fp;
4413     if (wait) {
4414          dSAVEDERRNO;
4415          int done = 0;
4416          while (!done) {
4417              _ckvmssts_noperl(sys$setast(0));
4418              done = info->done;
4419              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4420              _ckvmssts_noperl(sys$setast(1));
4421              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4422          }
4423         *psts = info->completion;
4424 /* Caller thinks it is open and tries to close it. */
4425 /* This causes some problems, as it changes the error status */
4426 /*        my_pclose(info->fp); */
4427
4428          /* If we did not have a file pointer open, then we have to */
4429          /* clean up here or eventually we will run out of something */
4430          SAVE_ERRNO;
4431          if (info->fp == NULL) {
4432              my_pclose_pinfo(aTHX_ info);
4433          }
4434          RESTORE_ERRNO;
4435
4436     } else {
4437         *psts = info->pid;
4438     }
4439     return ret_fp;
4440 }  /* end of safe_popen */
4441
4442
4443 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4444 PerlIO *
4445 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4446 {
4447     int sts;
4448     TAINT_ENV();
4449     TAINT_PROPER("popen");
4450     PERL_FLUSHALL_FOR_CHILD;
4451     return safe_popen(aTHX_ cmd,mode,&sts);
4452 }
4453
4454 /*}}}*/
4455
4456
4457 /* Routine to close and cleanup a pipe info structure */
4458
4459 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4460
4461     unsigned long int retsts;
4462     int done, n;
4463     pInfo next, last;
4464
4465     /* If we were writing to a subprocess, insure that someone reading from
4466      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4467      * produce an EOF record in the mailbox.
4468      *
4469      *  well, at least sometimes it *does*, so we have to watch out for
4470      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4471      */
4472      if (info->fp) {
4473         if (!info->useFILE
4474 #if defined(USE_ITHREADS)
4475           && my_perl
4476 #endif
4477 #ifdef USE_PERLIO
4478           && PL_perlio_fd_refcnt
4479 #endif
4480            )
4481             PerlIO_flush(info->fp);
4482         else
4483             fflush((FILE *)info->fp);
4484     }
4485
4486     _ckvmssts(sys$setast(0));
4487      info->closing = TRUE;
4488      done = info->done && info->in_done && info->out_done && info->err_done;
4489      /* hanging on write to Perl's input? cancel it */
4490      if (info->mode == 'r' && info->out && !info->out_done) {
4491         if (info->out->chan_out) {
4492             _ckvmssts(sys$cancel(info->out->chan_out));
4493             if (!info->out->chan_in) {   /* EOF generation, need AST */
4494                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4495             }
4496         }
4497      }
4498      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4499          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4500                            0, 0, 0, 0, 0, 0));
4501     _ckvmssts(sys$setast(1));
4502     if (info->fp) {
4503      if (!info->useFILE
4504 #if defined(USE_ITHREADS)
4505          && my_perl
4506 #endif
4507 #ifdef USE_PERLIO
4508          && PL_perlio_fd_refcnt
4509 #endif
4510         )
4511         PerlIO_close(info->fp);
4512      else
4513         fclose((FILE *)info->fp);
4514     }
4515      /*
4516         we have to wait until subprocess completes, but ALSO wait until all
4517         the i/o completes...otherwise we'll be freeing the "info" structure
4518         that the i/o ASTs could still be using...
4519      */
4520
4521      while (!done) {
4522          _ckvmssts(sys$setast(0));
4523          done = info->done && info->in_done && info->out_done && info->err_done;
4524          if (!done) _ckvmssts(sys$clref(pipe_ef));
4525          _ckvmssts(sys$setast(1));
4526          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4527      }
4528      retsts = info->completion;
4529
4530     /* remove from list of open pipes */
4531     _ckvmssts(sys$setast(0));
4532     last = NULL;
4533     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4534         if (next == info)
4535             break;
4536     }
4537
4538     if (last)
4539         last->next = info->next;
4540     else
4541         open_pipes = info->next;
4542     _ckvmssts(sys$setast(1));
4543
4544     /* free buffers and structures */
4545
4546     if (info->in) {
4547         if (info->in->buf) {
4548             n = info->in->bufsize * sizeof(char);
4549             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4550         }
4551         n = sizeof(Pipe);
4552         _ckvmssts(lib$free_vm(&n, &info->in));
4553     }
4554     if (info->out) {
4555         if (info->out->buf) {
4556             n = info->out->bufsize * sizeof(char);
4557             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4558         }
4559         n = sizeof(Pipe);
4560         _ckvmssts(lib$free_vm(&n, &info->out));
4561     }
4562     if (info->err) {
4563         if (info->err->buf) {
4564             n = info->err->bufsize * sizeof(char);
4565             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4566         }
4567         n = sizeof(Pipe);
4568         _ckvmssts(lib$free_vm(&n, &info->err));
4569     }
4570     n = sizeof(Info);
4571     _ckvmssts(lib$free_vm(&n, &info));
4572
4573     return retsts;
4574 }
4575
4576
4577 /*{{{  I32 my_pclose(PerlIO *fp)*/
4578 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4579 {
4580     pInfo info, last = NULL;
4581     I32 ret_status;
4582
4583     /* Fixme - need ast and mutex protection here */
4584     for (info = open_pipes; info != NULL; last = info, info = info->next)
4585         if (info->fp == fp) break;
4586
4587     if (info == NULL) {  /* no such pipe open */
4588       set_errno(ECHILD); /* quoth POSIX */
4589       set_vaxc_errno(SS$_NONEXPR);
4590       return -1;
4591     }
4592
4593     ret_status = my_pclose_pinfo(aTHX_ info);
4594
4595     return ret_status;
4596
4597 }  /* end of my_pclose() */
4598
4599 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4600   /* Roll our own prototype because we want this regardless of whether
4601    * _VMS_WAIT is defined.
4602    */
4603
4604 #ifdef __cplusplus
4605 extern "C" {
4606 #endif
4607   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4608 #ifdef __cplusplus
4609 }
4610 #endif
4611
4612 #endif
4613 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4614    created with popen(); otherwise partially emulate waitpid() unless
4615    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4616    Also check processes not considered by the CRTL waitpid().
4617  */
4618 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4619 Pid_t
4620 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4621 {
4622     pInfo info;
4623     int done;
4624     int sts;
4625     int j;
4626
4627     if (statusp) *statusp = 0;
4628
4629     for (info = open_pipes; info != NULL; info = info->next)
4630         if (info->pid == pid) break;
4631
4632     if (info != NULL) {  /* we know about this child */
4633       while (!info->done) {
4634           _ckvmssts(sys$setast(0));
4635           done = info->done;
4636           if (!done) _ckvmssts(sys$clref(pipe_ef));
4637           _ckvmssts(sys$setast(1));
4638           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4639       }
4640
4641       if (statusp) *statusp = info->completion;
4642       return pid;
4643     }
4644
4645     /* child that already terminated? */
4646
4647     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4648         if (closed_list[j].pid == pid) {
4649             if (statusp) *statusp = closed_list[j].completion;
4650             return pid;
4651         }
4652     }
4653
4654     /* fall through if this child is not one of our own pipe children */
4655
4656 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4657
4658       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4659        * in 7.2 did we get a version that fills in the VMS completion
4660        * status as Perl has always tried to do.
4661        */
4662
4663       sts = __vms_waitpid( pid, statusp, flags );
4664
4665       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4666          return sts;
4667
4668       /* If the real waitpid tells us the child does not exist, we
4669        * fall through here to implement waiting for a child that
4670        * was created by some means other than exec() (say, spawned
4671        * from DCL) or to wait for a process that is not a subprocess
4672        * of the current process.
4673        */
4674
4675 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4676
4677     {
4678       $DESCRIPTOR(intdsc,"0 00:00:01");
4679       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4680       unsigned long int pidcode = JPI$_PID, mypid;
4681       unsigned long int interval[2];
4682       unsigned int jpi_iosb[2];
4683       struct itmlst_3 jpilist[2] = {
4684           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4685           {                      0,         0,                 0, 0}
4686       };
4687
4688       if (pid <= 0) {
4689         /* Sorry folks, we don't presently implement rooting around for
4690            the first child we can find, and we definitely don't want to
4691            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4692          */
4693         set_errno(ENOTSUP);
4694         return -1;
4695       }
4696
4697       /* Get the owner of the child so I can warn if it's not mine. If the
4698        * process doesn't exist or I don't have the privs to look at it,
4699        * I can go home early.
4700        */
4701       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4702       if (sts & 1) sts = jpi_iosb[0];
4703       if (!(sts & 1)) {
4704         switch (sts) {
4705             case SS$_NONEXPR:
4706                 set_errno(ECHILD);
4707                 break;
4708             case SS$_NOPRIV:
4709                 set_errno(EACCES);
4710                 break;
4711             default:
4712                 _ckvmssts(sts);
4713         }
4714         set_vaxc_errno(sts);
4715         return -1;
4716       }
4717
4718       if (ckWARN(WARN_EXEC)) {
4719         /* remind folks they are asking for non-standard waitpid behavior */
4720         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4721         if (ownerpid != mypid)
4722           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4723                       "waitpid: process %x is not a child of process %x",
4724                       pid,mypid);
4725       }
4726
4727       /* simply check on it once a second until it's not there anymore. */
4728
4729       _ckvmssts(sys$bintim(&intdsc,interval));
4730       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4731             _ckvmssts(sys$schdwk(0,0,interval,0));
4732             _ckvmssts(sys$hiber());
4733       }
4734       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4735
4736       _ckvmssts(sts);
4737       return pid;
4738     }
4739 }  /* end of waitpid() */
4740 /*}}}*/
4741 /*}}}*/
4742 /*}}}*/
4743
4744 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4745 char *
4746 my_gconvert(double val, int ndig, int trail, char *buf)
4747 {
4748   static char __gcvtbuf[DBL_DIG+1];
4749   char *loc;
4750
4751   loc = buf ? buf : __gcvtbuf;
4752
4753   if (val) {
4754     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4755     return gcvt(val,ndig,loc);
4756   }
4757   else {
4758     loc[0] = '0'; loc[1] = '\0';
4759     return loc;
4760   }
4761
4762 }
4763 /*}}}*/
4764
4765 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4766 static int rms_free_search_context(struct FAB * fab)
4767 {
4768 struct NAM * nam;
4769
4770     nam = fab->fab$l_nam;
4771     nam->nam$b_nop |= NAM$M_SYNCHK;
4772     nam->nam$l_rlf = NULL;
4773     fab->fab$b_dns = 0;
4774     return sys$parse(fab, NULL, NULL);
4775 }
4776
4777 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4778 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4779 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4780 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4781 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4782 #define rms_nam_esll(nam) nam.nam$b_esl
4783 #define rms_nam_esl(nam) nam.nam$b_esl
4784 #define rms_nam_name(nam) nam.nam$l_name
4785 #define rms_nam_namel(nam) nam.nam$l_name
4786 #define rms_nam_type(nam) nam.nam$l_type
4787 #define rms_nam_typel(nam) nam.nam$l_type
4788 #define rms_nam_ver(nam) nam.nam$l_ver
4789 #define rms_nam_verl(nam) nam.nam$l_ver
4790 #define rms_nam_rsll(nam) nam.nam$b_rsl
4791 #define rms_nam_rsl(nam) nam.nam$b_rsl
4792 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4793 #define rms_set_fna(fab, nam, name, size) \
4794         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4795 #define rms_get_fna(fab, nam) fab.fab$l_fna
4796 #define rms_set_dna(fab, nam, name, size) \
4797         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4798 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4799 #define rms_set_esa(nam, name, size) \
4800         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4801 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4802         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4803 #define rms_set_rsa(nam, name, size) \
4804         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4805 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4806         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4807 #define rms_nam_name_type_l_size(nam) \
4808         (nam.nam$b_name + nam.nam$b_type)
4809 #else
4810 static int rms_free_search_context(struct FAB * fab)
4811 {
4812 struct NAML * nam;
4813
4814     nam = fab->fab$l_naml;
4815     nam->naml$b_nop |= NAM$M_SYNCHK;
4816     nam->naml$l_rlf = NULL;
4817     nam->naml$l_long_defname_size = 0;
4818
4819     fab->fab$b_dns = 0;
4820     return sys$parse(fab, NULL, NULL);
4821 }
4822
4823 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4824 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4825 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4826 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4827 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4828 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4829 #define rms_nam_esl(nam) nam.naml$b_esl
4830 #define rms_nam_name(nam) nam.naml$l_name
4831 #define rms_nam_namel(nam) nam.naml$l_long_name
4832 #define rms_nam_type(nam) nam.naml$l_type
4833 #define rms_nam_typel(nam) nam.naml$l_long_type
4834 #define rms_nam_ver(nam) nam.naml$l_ver
4835 #define rms_nam_verl(nam) nam.naml$l_long_ver
4836 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4837 #define rms_nam_rsl(nam) nam.naml$b_rsl
4838 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4839 #define rms_set_fna(fab, nam, name, size) \
4840         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4841         nam.naml$l_long_filename_size = size; \
4842         nam.naml$l_long_filename = name;}
4843 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4844 #define rms_set_dna(fab, nam, name, size) \
4845         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4846         nam.naml$l_long_defname_size = size; \
4847         nam.naml$l_long_defname = name; }
4848 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4849 #define rms_set_esa(nam, name, size) \
4850         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4851         nam.naml$l_long_expand_alloc = size; \
4852         nam.naml$l_long_expand = name; }
4853 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4854         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4855         nam.naml$l_long_expand = l_name; \
4856         nam.naml$l_long_expand_alloc = l_size; }
4857 #define rms_set_rsa(nam, name, size) \
4858         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4859         nam.naml$l_long_result = name; \
4860         nam.naml$l_long_result_alloc = size; }
4861 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4862         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4863         nam.naml$l_long_result = l_name; \
4864         nam.naml$l_long_result_alloc = l_size; }
4865 #define rms_nam_name_type_l_size(nam) \
4866         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4867 #endif
4868
4869
4870 /* rms_erase
4871  * The CRTL for 8.3 and later can create symbolic links in any mode,
4872  * however in 8.3 the unlink/remove/delete routines will only properly handle
4873  * them if one of the PCP modes is active.
4874  */
4875 static int rms_erase(const char * vmsname)
4876 {
4877   int status;
4878   struct FAB myfab = cc$rms_fab;
4879   rms_setup_nam(mynam);
4880
4881   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4882   rms_bind_fab_nam(myfab, mynam);
4883
4884 #ifdef NAML$M_OPEN_SPECIAL
4885   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4886 #endif
4887
4888   status = sys$erase(&myfab, 0, 0);
4889
4890   return status;
4891 }
4892
4893
4894 static int
4895 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4896                     const struct dsc$descriptor_s * vms_dst_dsc,
4897                     unsigned long flags)
4898 {
4899     /*  VMS and UNIX handle file permissions differently and the
4900      * the same ACL trick may be needed for renaming files,
4901      * especially if they are directories.
4902      */
4903
4904    /* todo: get kill_file and rename to share common code */
4905    /* I can not find online documentation for $change_acl
4906     * it appears to be replaced by $set_security some time ago */
4907
4908 const unsigned int access_mode = 0;
4909 $DESCRIPTOR(obj_file_dsc,"FILE");
4910 char *vmsname;
4911 char *rslt;
4912 unsigned long int jpicode = JPI$_UIC;
4913 int aclsts, fndsts, rnsts = -1;
4914 unsigned int ctx = 0;
4915 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4916 struct dsc$descriptor_s * clean_dsc;
4917
4918 struct myacedef {
4919     unsigned char myace$b_length;
4920     unsigned char myace$b_type;
4921     unsigned short int myace$w_flags;
4922     unsigned long int myace$l_access;
4923     unsigned long int myace$l_ident;
4924 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4925              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4926              0},
4927              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4928
4929 struct item_list_3
4930         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4931                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4932                       {0,0,0,0}},
4933         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4934         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4935                      {0,0,0,0}};
4936
4937
4938     /* Expand the input spec using RMS, since we do not want to put
4939      * ACLs on the target of a symbolic link */
4940     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
4941     if (vmsname == NULL)
4942         return SS$_INSFMEM;
4943
4944     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4945                         vmsname,
4946                         PERL_RMSEXPAND_M_SYMLINK);
4947     if (rslt == NULL) {
4948         PerlMem_free(vmsname);
4949         return SS$_INSFMEM;
4950     }
4951
4952     /* So we get our own UIC to use as a rights identifier,
4953      * and the insert an ACE at the head of the ACL which allows us
4954      * to delete the file.
4955      */
4956     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4957
4958     fildsc.dsc$w_length = strlen(vmsname);
4959     fildsc.dsc$a_pointer = vmsname;
4960     ctx = 0;
4961     newace.myace$l_ident = oldace.myace$l_ident;
4962     rnsts = SS$_ABORT;
4963
4964     /* Grab any existing ACEs with this identifier in case we fail */
4965     clean_dsc = &fildsc;
4966     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4967                                &fildsc,
4968                                NULL,
4969                                OSS$M_WLOCK,
4970                                findlst,
4971                                &ctx,
4972                                &access_mode);
4973
4974     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4975         /* Add the new ACE . . . */
4976
4977         /* if the sys$get_security succeeded, then ctx is valid, and the
4978          * object/file descriptors will be ignored.  But otherwise they
4979          * are needed
4980          */
4981         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4982                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4983         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4984             set_errno(EVMSERR);
4985             set_vaxc_errno(aclsts);
4986             PerlMem_free(vmsname);
4987             return aclsts;
4988         }
4989
4990         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4991                                 NULL, NULL,
4992                                 &flags,
4993                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4994
4995         if ($VMS_STATUS_SUCCESS(rnsts)) {
4996             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4997         }
4998
4999         /* Put things back the way they were. */
5000         ctx = 0;
5001         aclsts = sys$get_security(&obj_file_dsc,
5002                                   clean_dsc,
5003                                   NULL,
5004                                   OSS$M_WLOCK,
5005                                   findlst,
5006                                   &ctx,
5007                                   &access_mode);
5008
5009         if ($VMS_STATUS_SUCCESS(aclsts)) {
5010         int sec_flags;
5011
5012             sec_flags = 0;
5013             if (!$VMS_STATUS_SUCCESS(fndsts))
5014                 sec_flags = OSS$M_RELCTX;
5015
5016             /* Get rid of the new ACE */
5017             aclsts = sys$set_security(NULL, NULL, NULL,
5018                                   sec_flags, dellst, &ctx, &access_mode);
5019
5020             /* If there was an old ACE, put it back */
5021             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5022                 addlst[0].bufadr = &oldace;
5023                 aclsts = sys$set_security(NULL, NULL, NULL,
5024                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5025                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5026                     set_errno(EVMSERR);
5027                     set_vaxc_errno(aclsts);
5028                     rnsts = aclsts;
5029                 }
5030             } else {
5031             int aclsts2;
5032
5033                 /* Try to clear the lock on the ACL list */
5034                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5035                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5036
5037                 /* Rename errors are most important */
5038                 if (!$VMS_STATUS_SUCCESS(rnsts))
5039                     aclsts = rnsts;
5040                 set_errno(EVMSERR);
5041                 set_vaxc_errno(aclsts);
5042                 rnsts = aclsts;
5043             }
5044         }
5045         else {
5046             if (aclsts != SS$_ACLEMPTY)
5047                 rnsts = aclsts;
5048         }
5049     }
5050     else
5051         rnsts = fndsts;
5052
5053     PerlMem_free(vmsname);
5054     return rnsts;
5055 }
5056
5057
5058 /*{{{int rename(const char *, const char * */
5059 /* Not exactly what X/Open says to do, but doing it absolutely right
5060  * and efficiently would require a lot more work.  This should be close
5061  * enough to pass all but the most strict X/Open compliance test.
5062  */
5063 int
5064 Perl_rename(pTHX_ const char *src, const char * dst)
5065 {
5066 int retval;
5067 int pre_delete = 0;
5068 int src_sts;
5069 int dst_sts;
5070 Stat_t src_st;
5071 Stat_t dst_st;
5072
5073     /* Validate the source file */
5074     src_sts = flex_lstat(src, &src_st);
5075     if (src_sts != 0) {
5076
5077         /* No source file or other problem */
5078         return src_sts;
5079     }
5080     if (src_st.st_devnam[0] == 0)  {
5081         /* This may be possible so fail if it is seen. */
5082         errno = EIO;
5083         return -1;
5084     }
5085
5086     dst_sts = flex_lstat(dst, &dst_st);
5087     if (dst_sts == 0) {
5088
5089         if (dst_st.st_dev != src_st.st_dev) {
5090             /* Must be on the same device */
5091             errno = EXDEV;
5092             return -1;
5093         }
5094
5095         /* VMS_INO_T_COMPARE is true if the inodes are different
5096          * to match the output of memcmp
5097          */
5098
5099         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5100             /* That was easy, the files are the same! */
5101             return 0;
5102         }
5103
5104         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5105             /* If source is a directory, so must be dest */
5106                 errno = EISDIR;
5107                 return -1;
5108         }
5109
5110     }
5111
5112
5113     if ((dst_sts == 0) &&
5114         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5115
5116         /* We have issues here if vms_unlink_all_versions is set
5117          * If the destination exists, and is not a directory, then
5118          * we must delete in advance.
5119          *
5120          * If the src is a directory, then we must always pre-delete
5121          * the destination.
5122          *
5123          * If we successfully delete the dst in advance, and the rename fails
5124          * X/Open requires that errno be EIO.
5125          *
5126          */
5127
5128         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5129             int d_sts;
5130             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5131                                      S_ISDIR(dst_st.st_mode));
5132
5133            /* Need to delete all versions ? */
5134            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5135                 int i = 0;
5136
5137                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5138                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5139                     if (d_sts != 0)
5140                         break;
5141                     i++;
5142
5143                     /* Make sure that we do not loop forever */
5144                     if (i > 32767) {
5145                         errno = EIO;
5146                         d_sts = -1;
5147                         break;
5148                     }
5149                 }
5150            }
5151
5152             if (d_sts != 0)
5153                 return d_sts;
5154
5155             /* We killed the destination, so only errno now is EIO */
5156             pre_delete = 1;
5157         }
5158     }
5159
5160     /* Originally the idea was to call the CRTL rename() and only
5161      * try the lib$rename_file if it failed.
5162      * It turns out that there are too many variants in what the
5163      * the CRTL rename might do, so only use lib$rename_file
5164      */
5165     retval = -1;
5166
5167     {
5168         /* Is the source and dest both in VMS format */
5169         /* if the source is a directory, then need to fileify */
5170         /*  and dest must be a directory or non-existent. */
5171
5172         char * vms_dst;
5173         int sts;
5174         char * ret_str;
5175         unsigned long flags;
5176         struct dsc$descriptor_s old_file_dsc;
5177         struct dsc$descriptor_s new_file_dsc;
5178
5179         /* We need to modify the src and dst depending
5180          * on if one or more of them are directories.
5181          */
5182
5183         vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
5184         if (vms_dst == NULL)
5185             _ckvmssts_noperl(SS$_INSFMEM);
5186
5187         if (S_ISDIR(src_st.st_mode)) {
5188         char * ret_str;
5189         char * vms_dir_file;
5190
5191             vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
5192             if (vms_dir_file == NULL)
5193                 _ckvmssts_noperl(SS$_INSFMEM);
5194
5195             /* If the dest is a directory, we must remove it */
5196             if (dst_sts == 0) {
5197                 int d_sts;
5198                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5199                 if (d_sts != 0) {
5200                     PerlMem_free(vms_dst);
5201                     errno = EIO;
5202                     return d_sts;
5203                 }
5204
5205                 pre_delete = 1;
5206             }
5207
5208            /* The dest must be a VMS file specification */
5209            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5210            if (ret_str == NULL) {
5211                 PerlMem_free(vms_dst);
5212                 errno = EIO;
5213                 return -1;
5214            }
5215
5216             /* The source must be a file specification */
5217             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5218             if (ret_str == NULL) {
5219                 PerlMem_free(vms_dst);
5220                 PerlMem_free(vms_dir_file);
5221                 errno = EIO;
5222                 return -1;
5223             }
5224             PerlMem_free(vms_dst);
5225             vms_dst = vms_dir_file;
5226
5227         } else {
5228             /* File to file or file to new dir */
5229
5230             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5231                 /* VMS pathify a dir target */
5232                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5233                 if (ret_str == NULL) {
5234                     PerlMem_free(vms_dst);
5235                     errno = EIO;
5236                     return -1;
5237                 }
5238             } else {
5239                 char * v_spec, * r_spec, * d_spec, * n_spec;
5240                 char * e_spec, * vs_spec;
5241                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5242
5243                 /* fileify a target VMS file specification */
5244                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5245                 if (ret_str == NULL) {
5246                     PerlMem_free(vms_dst);
5247                     errno = EIO;
5248                     return -1;
5249                 }
5250
5251                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5252                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5253                              &e_len, &vs_spec, &vs_len);
5254                 if (sts == 0) {
5255                      if (e_len == 0) {
5256                          /* Get rid of the version */
5257                          if (vs_len != 0) {
5258                              *vs_spec = '\0';
5259                          }
5260                          /* Need to specify a '.' so that the extension */
5261                          /* is not inherited */
5262                          strcat(vms_dst,".");
5263                      }
5264                 }
5265             }
5266         }
5267
5268         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5269         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5270         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5271         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5272
5273         new_file_dsc.dsc$a_pointer = vms_dst;
5274         new_file_dsc.dsc$w_length = strlen(vms_dst);
5275         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5276         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5277
5278         flags = 0;
5279 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5280         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5281 #endif
5282
5283         sts = lib$rename_file(&old_file_dsc,
5284                               &new_file_dsc,
5285                               NULL, NULL,
5286                               &flags,
5287                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5288         if (!$VMS_STATUS_SUCCESS(sts)) {
5289
5290            /* We could have failed because VMS style permissions do not
5291             * permit renames that UNIX will allow.  Just like the hack
5292             * in for kill_file.
5293             */
5294            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5295         }
5296
5297         PerlMem_free(vms_dst);
5298         if (!$VMS_STATUS_SUCCESS(sts)) {
5299             errno = EIO;
5300             return -1;
5301         }
5302         retval = 0;
5303     }
5304
5305     if (vms_unlink_all_versions) {
5306         /* Now get rid of any previous versions of the source file that
5307          * might still exist
5308          */
5309         int i = 0;
5310         dSAVEDERRNO;
5311         SAVE_ERRNO;
5312         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5313                                    S_ISDIR(src_st.st_mode));
5314         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5315              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5316                                        S_ISDIR(src_st.st_mode));
5317              if (src_sts != 0)
5318                  break;
5319              i++;
5320
5321              /* Make sure that we do not loop forever */
5322              if (i > 32767) {
5323                  src_sts = -1;
5324                  break;
5325              }
5326         }
5327         RESTORE_ERRNO;
5328     }
5329
5330     /* We deleted the destination, so must force the error to be EIO */
5331     if ((retval != 0) && (pre_delete != 0))
5332         errno = EIO;
5333
5334     return retval;
5335 }
5336 /*}}}*/
5337
5338
5339 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5340 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5341  * to expand file specification.  Allows for a single default file
5342  * specification and a simple mask of options.  If outbuf is non-NULL,
5343  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5344  * the resultant file specification is placed.  If outbuf is NULL, the
5345  * resultant file specification is placed into a static buffer.
5346  * The third argument, if non-NULL, is taken to be a default file
5347  * specification string.  The fourth argument is unused at present.
5348  * rmesexpand() returns the address of the resultant string if
5349  * successful, and NULL on error.
5350  *
5351  * New functionality for previously unused opts value:
5352  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5353  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5354  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5355  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5356  */
5357 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5358
5359 static char *
5360 int_rmsexpand
5361    (const char *filespec,
5362     char *outbuf,
5363     const char *defspec,
5364     unsigned opts,
5365     int * fs_utf8,
5366     int * dfs_utf8)
5367 {
5368   char * ret_spec;
5369   const char * in_spec;
5370   char * spec_buf;
5371   const char * def_spec;
5372   char * vmsfspec, *vmsdefspec;
5373   char * esa;
5374   char * esal = NULL;
5375   char * outbufl;
5376   struct FAB myfab = cc$rms_fab;
5377   rms_setup_nam(mynam);
5378   STRLEN speclen;
5379   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5380   int sts;
5381
5382   /* temp hack until UTF8 is actually implemented */
5383   if (fs_utf8 != NULL)
5384     *fs_utf8 = 0;
5385
5386   if (!filespec || !*filespec) {
5387     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5388     return NULL;
5389   }
5390
5391   vmsfspec = NULL;
5392   vmsdefspec = NULL;
5393   outbufl = NULL;
5394
5395   in_spec = filespec;
5396   isunix = 0;
5397   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5398       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5399       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5400
5401       /* If this is a UNIX file spec, convert it to VMS */
5402       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5403                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5404                            &e_len, &vs_spec, &vs_len);
5405       if (sts != 0) {
5406           isunix = 1;
5407           char * ret_spec;
5408
5409           vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5410           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5411           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5412           if (ret_spec == NULL) {
5413               PerlMem_free(vmsfspec);
5414               return NULL;
5415           }
5416           in_spec = (const char *)vmsfspec;
5417
5418           /* Unless we are forcing to VMS format, a UNIX input means
5419            * UNIX output, and that requires long names to be used
5420            */
5421           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5422 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5423               opts |= PERL_RMSEXPAND_M_LONG;
5424 #else
5425               NOOP;
5426 #endif
5427           else
5428               isunix = 0;
5429       }
5430
5431   }
5432
5433   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5434   rms_bind_fab_nam(myfab, mynam);
5435
5436   /* Process the default file specification if present */
5437   def_spec = defspec;
5438   if (defspec && *defspec) {
5439     int t_isunix;
5440     t_isunix = is_unix_filespec(defspec);
5441     if (t_isunix) {
5442       vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5443       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5444       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5445
5446       if (ret_spec == NULL) {
5447           /* Clean up and bail */
5448           PerlMem_free(vmsdefspec);
5449           if (vmsfspec != NULL)
5450               PerlMem_free(vmsfspec);
5451               return NULL;
5452           }
5453           def_spec = (const char *)vmsdefspec;
5454       }
5455       rms_set_dna(myfab, mynam,
5456                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5457   }
5458
5459   /* Now we need the expansion buffers */
5460   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
5461   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5462 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5463   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
5464   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5465 #endif
5466   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5467
5468   /* If a NAML block is used RMS always writes to the long and short
5469    * addresses unless you suppress the short name.
5470    */
5471 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5472   outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
5473   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5474 #endif
5475    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5476
5477 #ifdef NAM$M_NO_SHORT_UPCASE
5478   if (decc_efs_case_preserve)
5479     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5480 #endif
5481
5482    /* We may not want to follow symbolic links */
5483 #ifdef NAML$M_OPEN_SPECIAL
5484   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5485     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5486 #endif
5487
5488   /* First attempt to parse as an existing file */
5489   retsts = sys$parse(&myfab,0,0);
5490   if (!(retsts & STS$K_SUCCESS)) {
5491
5492     /* Could not find the file, try as syntax only if error is not fatal */
5493     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5494     if (retsts == RMS$_DNF ||
5495         retsts == RMS$_DIR ||
5496         retsts == RMS$_DEV ||
5497         retsts == RMS$_PRV) {
5498       retsts = sys$parse(&myfab,0,0);
5499       if (retsts & STS$K_SUCCESS) goto int_expanded;
5500     }
5501
5502      /* Still could not parse the file specification */
5503     /*----------------------------------------------*/
5504     sts = rms_free_search_context(&myfab); /* Free search context */
5505     if (vmsdefspec != NULL)
5506         PerlMem_free(vmsdefspec);
5507     if (vmsfspec != NULL)
5508         PerlMem_free(vmsfspec);
5509     if (outbufl != NULL)
5510         PerlMem_free(outbufl);
5511     PerlMem_free(esa);
5512     if (esal != NULL)
5513         PerlMem_free(esal);
5514     set_vaxc_errno(retsts);
5515     if      (retsts == RMS$_PRV) set_errno(EACCES);
5516     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5517     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5518     else                         set_errno(EVMSERR);
5519     return NULL;
5520   }
5521   retsts = sys$search(&myfab,0,0);
5522   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5523     sts = rms_free_search_context(&myfab); /* Free search context */
5524     if (vmsdefspec != NULL)
5525         PerlMem_free(vmsdefspec);
5526     if (vmsfspec != NULL)
5527         PerlMem_free(vmsfspec);
5528     if (outbufl != NULL)
5529         PerlMem_free(outbufl);
5530     PerlMem_free(esa);
5531     if (esal != NULL)
5532         PerlMem_free(esal);
5533     set_vaxc_errno(retsts);
5534     if      (retsts == RMS$_PRV) set_errno(EACCES);
5535     else                         set_errno(EVMSERR);
5536     return NULL;
5537   }
5538
5539   /* If the input filespec contained any lowercase characters,
5540    * downcase the result for compatibility with Unix-minded code. */
5541 int_expanded:
5542   if (!decc_efs_case_preserve) {
5543     char * tbuf;
5544     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5545       if (islower(*tbuf)) { haslower = 1; break; }
5546   }
5547
5548    /* Is a long or a short name expected */
5549   /*------------------------------------*/
5550   spec_buf = NULL;
5551 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5552   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5553     if (rms_nam_rsll(mynam)) {
5554         spec_buf = outbufl;
5555         speclen = rms_nam_rsll(mynam);
5556     }
5557     else {
5558         spec_buf = esal; /* Not esa */
5559         speclen = rms_nam_esll(mynam);
5560     }
5561   }
5562   else {
5563 #endif
5564     if (rms_nam_rsl(mynam)) {
5565         spec_buf = outbuf;
5566         speclen = rms_nam_rsl(mynam);
5567     }
5568     else {
5569         spec_buf = esa; /* Not esal */
5570         speclen = rms_nam_esl(mynam);
5571     }
5572 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5573   }
5574 #endif
5575   spec_buf[speclen] = '\0';
5576
5577   /* Trim off null fields added by $PARSE
5578    * If type > 1 char, must have been specified in original or default spec
5579    * (not true for version; $SEARCH may have added version of existing file).
5580    */
5581   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5582   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5583     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5584              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5585   }
5586   else {
5587     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5588              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5589   }
5590   if (trimver || trimtype) {
5591     if (defspec && *defspec) {
5592       char *defesal = NULL;
5593       char *defesa = NULL;
5594       defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5595       if (defesa != NULL) {
5596         struct FAB deffab = cc$rms_fab;
5597 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5598         defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5599         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5600 #endif
5601         rms_setup_nam(defnam);
5602
5603         rms_bind_fab_nam(deffab, defnam);
5604
5605         /* Cast ok */
5606         rms_set_fna
5607             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5608
5609         /* RMS needs the esa/esal as a work area if wildcards are involved */
5610         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5611
5612         rms_clear_nam_nop(defnam);
5613         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5614 #ifdef NAM$M_NO_SHORT_UPCASE
5615         if (decc_efs_case_preserve)
5616           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5617 #endif
5618 #ifdef NAML$M_OPEN_SPECIAL
5619         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5620           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5621 #endif
5622         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5623           if (trimver) {
5624              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5625           }
5626           if (trimtype) {
5627             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5628           }
5629         }
5630         if (defesal != NULL)
5631             PerlMem_free(defesal);
5632         PerlMem_free(defesa);
5633       } else {
5634           _ckvmssts_noperl(SS$_INSFMEM);
5635       }
5636     }
5637     if (trimver) {
5638       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5639         if (*(rms_nam_verl(mynam)) != '\"')
5640           speclen = rms_nam_verl(mynam) - spec_buf;
5641       }
5642       else {
5643         if (*(rms_nam_ver(mynam)) != '\"')
5644           speclen = rms_nam_ver(mynam) - spec_buf;
5645       }
5646     }
5647     if (trimtype) {
5648       /* If we didn't already trim version, copy down */
5649       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5650         if (speclen > rms_nam_verl(mynam) - spec_buf)
5651           memmove
5652            (rms_nam_typel(mynam),
5653             rms_nam_verl(mynam),
5654             speclen - (rms_nam_verl(mynam) - spec_buf));
5655           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5656       }
5657       else {
5658         if (speclen > rms_nam_ver(mynam) - spec_buf)
5659           memmove
5660            (rms_nam_type(mynam),
5661             rms_nam_ver(mynam),
5662             speclen - (rms_nam_ver(mynam) - spec_buf));
5663           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5664       }
5665     }
5666   }
5667
5668    /* Done with these copies of the input files */
5669   /*-------------------------------------------*/
5670   if (vmsfspec != NULL)
5671         PerlMem_free(vmsfspec);
5672   if (vmsdefspec != NULL)
5673         PerlMem_free(vmsdefspec);
5674
5675   /* If we just had a directory spec on input, $PARSE "helpfully"
5676    * adds an empty name and type for us */
5677 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5678   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5679     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5680         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5681         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5682       speclen = rms_nam_namel(mynam) - spec_buf;
5683   }
5684   else
5685 #endif
5686   {
5687     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5688         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5689         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5690       speclen = rms_nam_name(mynam) - spec_buf;
5691   }
5692
5693   /* Posix format specifications must have matching quotes */
5694   if (speclen < (VMS_MAXRSS - 1)) {
5695     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5696       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5697         spec_buf[speclen] = '\"';
5698         speclen++;
5699       }
5700     }
5701   }
5702   spec_buf[speclen] = '\0';
5703   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5704
5705   /* Have we been working with an expanded, but not resultant, spec? */
5706   /* Also, convert back to Unix syntax if necessary. */
5707   {
5708   int rsl;
5709
5710 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5711     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5712       rsl = rms_nam_rsll(mynam);
5713     } else
5714 #endif
5715     {
5716       rsl = rms_nam_rsl(mynam);
5717     }
5718     if (!rsl) {
5719       /* rsl is not present, it means that spec_buf is either */
5720       /* esa or esal, and needs to be copied to outbuf */
5721       /* convert to Unix if desired */
5722       if (isunix) {
5723         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5724       } else {
5725         /* VMS file specs are not in UTF-8 */
5726         if (fs_utf8 != NULL)
5727             *fs_utf8 = 0;
5728         my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5729         ret_spec = outbuf;
5730       }
5731     }
5732     else {
5733       /* Now spec_buf is either outbuf or outbufl */
5734       /* We need the result into outbuf */
5735       if (isunix) {
5736            /* If we need this in UNIX, then we need another buffer */
5737            /* to keep things in order */
5738            char * src;
5739            char * new_src = NULL;
5740            if (spec_buf == outbuf) {
5741                new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
5742                my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5743            } else {
5744                src = spec_buf;
5745            }
5746            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5747            if (new_src) {
5748                PerlMem_free(new_src);
5749            }
5750       } else {
5751            /* VMS file specs are not in UTF-8 */
5752            if (fs_utf8 != NULL)
5753                *fs_utf8 = 0;
5754
5755            /* Copy the buffer if needed */
5756            if (outbuf != spec_buf)
5757                my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5758            ret_spec = outbuf;
5759       }
5760     }
5761   }
5762
5763   /* Need to clean up the search context */
5764   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5765   sts = rms_free_search_context(&myfab); /* Free search context */
5766
5767   /* Clean up the extra buffers */
5768   if (esal != NULL)
5769       PerlMem_free(esal);
5770   PerlMem_free(esa);
5771   if (outbufl != NULL)
5772      PerlMem_free(outbufl);
5773
5774   /* Return the result */
5775   return ret_spec;
5776 }
5777
5778 /* Common simple case - Expand an already VMS spec */
5779 static char *
5780 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5781     opts |= PERL_RMSEXPAND_M_VMS_IN;
5782     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5783 }
5784
5785 /* Common simple case - Expand to a VMS spec */
5786 static char *
5787 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5788     opts |= PERL_RMSEXPAND_M_VMS;
5789     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5790 }
5791
5792
5793 /* Entry point used by perl routines */
5794 static char *
5795 mp_do_rmsexpand
5796    (pTHX_ const char *filespec,
5797     char *outbuf,
5798     int ts,
5799     const char *defspec,
5800     unsigned opts,
5801     int * fs_utf8,
5802     int * dfs_utf8)
5803 {
5804     static char __rmsexpand_retbuf[VMS_MAXRSS];
5805     char * expanded, *ret_spec, *ret_buf;
5806
5807     expanded = NULL;
5808     ret_buf = outbuf;
5809     if (ret_buf == NULL) {
5810         if (ts) {
5811             Newx(expanded, VMS_MAXRSS, char);
5812             if (expanded == NULL)
5813                 _ckvmssts(SS$_INSFMEM);
5814             ret_buf = expanded;
5815         } else {
5816             ret_buf = __rmsexpand_retbuf;
5817         }
5818     }
5819
5820
5821     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5822                              opts, fs_utf8,  dfs_utf8);
5823
5824     if (ret_spec == NULL) {
5825        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5826        if (expanded)
5827            Safefree(expanded);
5828     }
5829
5830     return ret_spec;
5831 }
5832 /*}}}*/
5833 /* External entry points */
5834 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5835 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5836 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5837 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5838 char *Perl_rmsexpand_utf8
5839   (pTHX_ const char *spec, char *buf, const char *def,
5840    unsigned opt, int * fs_utf8, int * dfs_utf8)
5841 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5842 char *Perl_rmsexpand_utf8_ts
5843   (pTHX_ const char *spec, char *buf, const char *def,
5844    unsigned opt, int * fs_utf8, int * dfs_utf8)
5845 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5846
5847
5848 /*
5849 ** The following routines are provided to make life easier when
5850 ** converting among VMS-style and Unix-style directory specifications.
5851 ** All will take input specifications in either VMS or Unix syntax. On
5852 ** failure, all return NULL.  If successful, the routines listed below
5853 ** return a pointer to a buffer containing the appropriately
5854 ** reformatted spec (and, therefore, subsequent calls to that routine
5855 ** will clobber the result), while the routines of the same names with
5856 ** a _ts suffix appended will return a pointer to a mallocd string
5857 ** containing the appropriately reformatted spec.
5858 ** In all cases, only explicit syntax is altered; no check is made that
5859 ** the resulting string is valid or that the directory in question
5860 ** actually exists.
5861 **
5862 **   fileify_dirspec() - convert a directory spec into the name of the
5863 **     directory file (i.e. what you can stat() to see if it's a dir).
5864 **     The style (VMS or Unix) of the result is the same as the style
5865 **     of the parameter passed in.
5866 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5867 **     what you prepend to a filename to indicate what directory it's in).
5868 **     The style (VMS or Unix) of the result is the same as the style
5869 **     of the parameter passed in.
5870 **   tounixpath() - convert a directory spec into a Unix-style path.
5871 **   tovmspath() - convert a directory spec into a VMS-style path.
5872 **   tounixspec() - convert any file spec into a Unix-style file spec.
5873 **   tovmsspec() - convert any file spec into a VMS-style spec.
5874 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5875 **
5876 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5877 ** Permission is given to distribute this code as part of the Perl
5878 ** standard distribution under the terms of the GNU General Public
5879 ** License or the Perl Artistic License.  Copies of each may be
5880 ** found in the Perl standard distribution.
5881  */
5882
5883 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5884 static char *
5885 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5886 {
5887     unsigned long int dirlen, retlen, hasfilename = 0;
5888     char *cp1, *cp2, *lastdir;
5889     char *trndir, *vmsdir;
5890     unsigned short int trnlnm_iter_count;
5891     int sts;
5892     if (utf8_fl != NULL)
5893         *utf8_fl = 0;
5894
5895     if (!dir || !*dir) {
5896       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5897     }
5898     dirlen = strlen(dir);
5899     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5900     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5901       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5902         dir = "/sys$disk";
5903         dirlen = 9;
5904       }
5905       else
5906         dirlen = 1;
5907     }
5908     if (dirlen > (VMS_MAXRSS - 1)) {
5909       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5910       return NULL;
5911     }
5912     trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5913     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5914     if (!strpbrk(dir+1,"/]>:")  &&
5915         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5916       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5917       trnlnm_iter_count = 0;
5918       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
5919         trnlnm_iter_count++;
5920         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5921       }
5922       dirlen = strlen(trndir);
5923     }
5924     else {
5925       memcpy(trndir, dir, dirlen);
5926       trndir[dirlen] = '\0';
5927     }
5928
5929     /* At this point we are done with *dir and use *trndir which is a
5930      * copy that can be modified.  *dir must not be modified.
5931      */
5932
5933     /* If we were handed a rooted logical name or spec, treat it like a
5934      * simple directory, so that
5935      *    $ Define myroot dev:[dir.]
5936      *    ... do_fileify_dirspec("myroot",buf,1) ...
5937      * does something useful.
5938      */
5939     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5940       trndir[--dirlen] = '\0';
5941       trndir[dirlen-1] = ']';
5942     }
5943     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5944       trndir[--dirlen] = '\0';
5945       trndir[dirlen-1] = '>';
5946     }
5947
5948     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5949       /* If we've got an explicit filename, we can just shuffle the string. */
5950       if (*(cp1+1)) hasfilename = 1;
5951       /* Similarly, we can just back up a level if we've got multiple levels
5952          of explicit directories in a VMS spec which ends with directories. */
5953       else {
5954         for (cp2 = cp1; cp2 > trndir; cp2--) {
5955           if (*cp2 == '.') {
5956             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5957 /* fix-me, can not scan EFS file specs backward like this */
5958               *cp2 = *cp1; *cp1 = '\0';
5959               hasfilename = 1;
5960               break;
5961             }
5962           }
5963           if (*cp2 == '[' || *cp2 == '<') break;
5964         }
5965       }
5966     }
5967
5968     vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5969     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5970     cp1 = strpbrk(trndir,"]:>");
5971     if (hasfilename || !cp1) { /* filename present or not VMS */
5972
5973       if (trndir[0] == '.') {
5974         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5975           PerlMem_free(trndir);
5976           PerlMem_free(vmsdir);
5977           return int_fileify_dirspec("[]", buf, NULL);
5978         }
5979         else if (trndir[1] == '.' &&
5980                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5981           PerlMem_free(trndir);
5982           PerlMem_free(vmsdir);
5983           return int_fileify_dirspec("[-]", buf, NULL);
5984         }
5985       }
5986       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5987         dirlen -= 1;                 /* to last element */
5988         lastdir = strrchr(trndir,'/');
5989       }
5990       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5991         /* If we have "/." or "/..", VMSify it and let the VMS code
5992          * below expand it, rather than repeating the code to handle
5993          * relative components of a filespec here */
5994         do {
5995           if (*(cp1+2) == '.') cp1++;
5996           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5997             char * ret_chr;
5998             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
5999                 PerlMem_free(trndir);
6000                 PerlMem_free(vmsdir);
6001                 return NULL;
6002             }
6003             if (strchr(vmsdir,'/') != NULL) {
6004               /* If int_tovmsspec() returned it, it must have VMS syntax
6005                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6006                * the time to check this here only so we avoid a recursion
6007                * loop; otherwise, gigo.
6008                */
6009               PerlMem_free(trndir);
6010               PerlMem_free(vmsdir);
6011               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6012               return NULL;
6013             }
6014             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6015                 PerlMem_free(trndir);
6016                 PerlMem_free(vmsdir);
6017                 return NULL;
6018             }
6019             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6020             PerlMem_free(trndir);
6021             PerlMem_free(vmsdir);
6022             return ret_chr;
6023           }
6024           cp1++;
6025         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6026         lastdir = strrchr(trndir,'/');
6027       }
6028       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6029         char * ret_chr;
6030         /* Ditto for specs that end in an MFD -- let the VMS code
6031          * figure out whether it's a real device or a rooted logical. */
6032
6033         /* This should not happen any more.  Allowing the fake /000000
6034          * in a UNIX pathname causes all sorts of problems when trying
6035          * to run in UNIX emulation.  So the VMS to UNIX conversions
6036          * now remove the fake /000000 directories.
6037          */
6038
6039         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6040         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6041             PerlMem_free(trndir);
6042             PerlMem_free(vmsdir);
6043             return NULL;
6044         }
6045         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6046             PerlMem_free(trndir);
6047             PerlMem_free(vmsdir);
6048             return NULL;
6049         }
6050         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6051         PerlMem_free(trndir);
6052         PerlMem_free(vmsdir);
6053         return ret_chr;
6054       }
6055       else {
6056
6057         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6058              !(lastdir = cp1 = strrchr(trndir,']')) &&
6059              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6060
6061         cp2 = strrchr(cp1,'.');
6062         if (cp2) {
6063             int e_len, vs_len = 0;
6064             int is_dir = 0;
6065             char * cp3;
6066             cp3 = strchr(cp2,';');
6067             e_len = strlen(cp2);
6068             if (cp3) {
6069                 vs_len = strlen(cp3);
6070                 e_len = e_len - vs_len;
6071             }
6072             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6073             if (!is_dir) {
6074                 if (!decc_efs_charset) {
6075                     /* If this is not EFS, then not a directory */
6076                     PerlMem_free(trndir);
6077                     PerlMem_free(vmsdir);
6078                     set_errno(ENOTDIR);
6079                     set_vaxc_errno(RMS$_DIR);
6080                     return NULL;
6081                 }
6082             } else {
6083                 /* Ok, here we have an issue, technically if a .dir shows */
6084                 /* from inside a directory, then we should treat it as */
6085                 /* xxx^.dir.dir.  But we do not have that context at this */
6086                 /* point unless this is totally restructured, so we remove */
6087                 /* The .dir for now, and fix this better later */
6088                 dirlen = cp2 - trndir;
6089             }
6090             if (decc_efs_charset && !strchr(trndir,'/')) {
6091                 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6092                 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6093
6094                 for (; cp4 > cp1; cp4--) {
6095                     if (*cp4 == '.') {
6096                         if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6097                             memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6098                             *cp4 = '^';
6099                             dirlen++;
6100                         }
6101                     }
6102                 }
6103             }
6104         }
6105
6106       }
6107
6108       retlen = dirlen + 6;
6109       memcpy(buf, trndir, dirlen);
6110       buf[dirlen] = '\0';
6111
6112       /* We've picked up everything up to the directory file name.
6113          Now just add the type and version, and we're set. */
6114       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6115           strcat(buf,".dir;1");
6116       else
6117           strcat(buf,".DIR;1");
6118       PerlMem_free(trndir);
6119       PerlMem_free(vmsdir);
6120       return buf;
6121     }
6122     else {  /* VMS-style directory spec */
6123
6124       char *esa, *esal, term, *cp;
6125       char *my_esa;
6126       int my_esa_len;
6127       unsigned long int cmplen, haslower = 0;
6128       struct FAB dirfab = cc$rms_fab;
6129       rms_setup_nam(savnam);
6130       rms_setup_nam(dirnam);
6131
6132       esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
6133       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6134       esal = NULL;
6135 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6136       esal = (char *)PerlMem_malloc(VMS_MAXRSS);
6137       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6138 #endif
6139       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6140       rms_bind_fab_nam(dirfab, dirnam);
6141       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6142       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6143 #ifdef NAM$M_NO_SHORT_UPCASE
6144       if (decc_efs_case_preserve)
6145         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6146 #endif
6147
6148       for (cp = trndir; *cp; cp++)
6149         if (islower(*cp)) { haslower = 1; break; }
6150       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6151         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6152             (dirfab.fab$l_sts == RMS$_DNF) ||
6153             (dirfab.fab$l_sts == RMS$_PRV)) {
6154             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6155             sts = sys$parse(&dirfab);
6156         }
6157         if (!sts) {
6158           PerlMem_free(esa);
6159           if (esal != NULL)
6160               PerlMem_free(esal);
6161           PerlMem_free(trndir);
6162           PerlMem_free(vmsdir);
6163           set_errno(EVMSERR);
6164           set_vaxc_errno(dirfab.fab$l_sts);
6165           return NULL;
6166         }
6167       }
6168       else {
6169         savnam = dirnam;
6170         /* Does the file really exist? */
6171         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6172           /* Yes; fake the fnb bits so we'll check type below */
6173           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6174         }
6175         else { /* No; just work with potential name */
6176           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6177           else {
6178             int fab_sts;
6179             fab_sts = dirfab.fab$l_sts;
6180             sts = rms_free_search_context(&dirfab);
6181             PerlMem_free(esa);
6182             if (esal != NULL)
6183                 PerlMem_free(esal);
6184             PerlMem_free(trndir);
6185             PerlMem_free(vmsdir);
6186             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6187             return NULL;
6188           }
6189         }
6190       }
6191
6192       /* Make sure we are using the right buffer */
6193 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6194       if (esal != NULL) {
6195         my_esa = esal;
6196         my_esa_len = rms_nam_esll(dirnam);
6197       } else {
6198 #endif
6199         my_esa = esa;
6200         my_esa_len = rms_nam_esl(dirnam);
6201 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6202       }
6203 #endif
6204       my_esa[my_esa_len] = '\0';
6205       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6206         cp1 = strchr(my_esa,']');
6207         if (!cp1) cp1 = strchr(my_esa,'>');
6208         if (cp1) {  /* Should always be true */
6209           my_esa_len -= cp1 - my_esa - 1;
6210           memmove(my_esa, cp1 + 1, my_esa_len);
6211         }
6212       }
6213       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6214         /* Yep; check version while we're at it, if it's there. */
6215         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6216         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6217           /* Something other than .DIR[;1].  Bzzt. */
6218           sts = rms_free_search_context(&dirfab);
6219           PerlMem_free(esa);
6220           if (esal != NULL)
6221              PerlMem_free(esal);
6222           PerlMem_free(trndir);
6223           PerlMem_free(vmsdir);
6224           set_errno(ENOTDIR);
6225           set_vaxc_errno(RMS$_DIR);
6226           return NULL;
6227         }
6228       }
6229
6230       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6231         /* They provided at least the name; we added the type, if necessary, */
6232         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6233         sts = rms_free_search_context(&dirfab);
6234         PerlMem_free(trndir);
6235         PerlMem_free(esa);
6236         if (esal != NULL)
6237             PerlMem_free(esal);
6238         PerlMem_free(vmsdir);
6239         return buf;
6240       }
6241       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6242         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6243         *cp1 = '\0';
6244         my_esa_len -= 9;
6245       }
6246       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6247       if (cp1 == NULL) { /* should never happen */
6248         sts = rms_free_search_context(&dirfab);
6249         PerlMem_free(trndir);
6250         PerlMem_free(esa);
6251         if (esal != NULL)
6252             PerlMem_free(esal);
6253         PerlMem_free(vmsdir);
6254         return NULL;
6255       }
6256       term = *cp1;
6257       *cp1 = '\0';
6258       retlen = strlen(my_esa);
6259       cp1 = strrchr(my_esa,'.');
6260       /* ODS-5 directory specifications can have extra "." in them. */
6261       /* Fix-me, can not scan EFS file specifications backwards */
6262       while (cp1 != NULL) {
6263         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6264           break;
6265         else {
6266            cp1--;
6267            while ((cp1 > my_esa) && (*cp1 != '.'))
6268              cp1--;
6269         }
6270         if (cp1 == my_esa)
6271           cp1 = NULL;
6272       }
6273
6274       if ((cp1) != NULL) {
6275         /* There's more than one directory in the path.  Just roll back. */
6276         *cp1 = term;
6277         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6278       }
6279       else {
6280         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6281           /* Go back and expand rooted logical name */
6282           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6283 #ifdef NAM$M_NO_SHORT_UPCASE
6284           if (decc_efs_case_preserve)
6285             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6286 #endif
6287           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6288             sts = rms_free_search_context(&dirfab);
6289             PerlMem_free(esa);
6290             if (esal != NULL)
6291                 PerlMem_free(esal);
6292             PerlMem_free(trndir);
6293             PerlMem_free(vmsdir);
6294             set_errno(EVMSERR);
6295             set_vaxc_errno(dirfab.fab$l_sts);
6296             return NULL;
6297           }
6298
6299           /* This changes the length of the string of course */
6300           if (esal != NULL) {
6301               my_esa_len = rms_nam_esll(dirnam);
6302           } else {
6303               my_esa_len = rms_nam_esl(dirnam);
6304           }
6305
6306           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6307           cp1 = strstr(my_esa,"][");
6308           if (!cp1) cp1 = strstr(my_esa,"]<");
6309           dirlen = cp1 - my_esa;
6310           memcpy(buf, my_esa, dirlen);
6311           if (!strncmp(cp1+2,"000000]",7)) {
6312             buf[dirlen-1] = '\0';
6313             /* fix-me Not full ODS-5, just extra dots in directories for now */
6314             cp1 = buf + dirlen - 1;
6315             while (cp1 > buf)
6316             {
6317               if (*cp1 == '[')
6318                 break;
6319               if (*cp1 == '.') {
6320                 if (*(cp1-1) != '^')
6321                   break;
6322               }
6323               cp1--;
6324             }
6325             if (*cp1 == '.') *cp1 = ']';
6326             else {
6327               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6328               memmove(cp1+1,"000000]",7);
6329             }
6330           }
6331           else {
6332             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6333             buf[retlen] = '\0';
6334             /* Convert last '.' to ']' */
6335             cp1 = buf+retlen-1;
6336             while (*cp != '[') {
6337               cp1--;
6338               if (*cp1 == '.') {
6339                 /* Do not trip on extra dots in ODS-5 directories */
6340                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6341                 break;
6342               }
6343             }
6344             if (*cp1 == '.') *cp1 = ']';
6345             else {
6346               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6347               memmove(cp1+1,"000000]",7);
6348             }
6349           }
6350         }
6351         else {  /* This is a top-level dir.  Add the MFD to the path. */
6352           cp1 = my_esa;
6353           cp2 = buf;
6354           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6355           strcpy(cp2,":[000000]");
6356           cp1 += 2;
6357           strcpy(cp2+9,cp1);
6358         }
6359       }
6360       sts = rms_free_search_context(&dirfab);
6361       /* We've set up the string up through the filename.  Add the
6362          type and version, and we're done. */
6363       strcat(buf,".DIR;1");
6364
6365       /* $PARSE may have upcased filespec, so convert output to lower
6366        * case if input contained any lowercase characters. */
6367       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6368       PerlMem_free(trndir);
6369       PerlMem_free(esa);
6370       if (esal != NULL)
6371         PerlMem_free(esal);
6372       PerlMem_free(vmsdir);
6373       return buf;
6374     }
6375 }  /* end of int_fileify_dirspec() */
6376
6377
6378 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6379 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6380 {
6381     static char __fileify_retbuf[VMS_MAXRSS];
6382     char * fileified, *ret_spec, *ret_buf;
6383
6384     fileified = NULL;
6385     ret_buf = buf;
6386     if (ret_buf == NULL) {
6387         if (ts) {
6388             Newx(fileified, VMS_MAXRSS, char);
6389             if (fileified == NULL)
6390                 _ckvmssts(SS$_INSFMEM);
6391             ret_buf = fileified;
6392         } else {
6393             ret_buf = __fileify_retbuf;
6394         }
6395     }
6396
6397     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6398
6399     if (ret_spec == NULL) {
6400        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6401        if (fileified)
6402            Safefree(fileified);
6403     }
6404
6405     return ret_spec;
6406 }  /* end of do_fileify_dirspec() */
6407 /*}}}*/
6408
6409 /* External entry points */
6410 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6411 { return do_fileify_dirspec(dir,buf,0,NULL); }
6412 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6413 { return do_fileify_dirspec(dir,buf,1,NULL); }
6414 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6415 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6416 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6417 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6418
6419 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6420     char * v_spec, int v_len, char * r_spec, int r_len,
6421     char * d_spec, int d_len, char * n_spec, int n_len,
6422     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6423
6424     /* VMS specification - Try to do this the simple way */
6425     if ((v_len + r_len > 0) || (d_len > 0)) {
6426         int is_dir;
6427
6428         /* No name or extension component, already a directory */
6429         if ((n_len + e_len + vs_len) == 0) {
6430             strcpy(buf, dir);
6431             return buf;
6432         }
6433
6434         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6435         /* This results from catfile() being used instead of catdir() */
6436         /* So even though it should not work, we need to allow it */
6437
6438         /* If this is .DIR;1 then do a simple conversion */
6439         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6440         if (is_dir || (e_len == 0) && (d_len > 0)) {
6441              int len;
6442              len = v_len + r_len + d_len - 1;
6443              char dclose = d_spec[d_len - 1];
6444              memcpy(buf, dir, len);
6445              buf[len] = '.';
6446              len++;
6447              memcpy(&buf[len], n_spec, n_len);
6448              len += n_len;
6449              buf[len] = dclose;
6450              buf[len + 1] = '\0';
6451              return buf;
6452         }
6453
6454 #ifdef HAS_SYMLINK
6455         else if (d_len > 0) {
6456             /* In the olden days, a directory needed to have a .DIR */
6457             /* extension to be a valid directory, but now it could  */
6458             /* be a symbolic link */
6459             int len;
6460             len = v_len + r_len + d_len - 1;
6461             char dclose = d_spec[d_len - 1];
6462             memcpy(buf, dir, len);
6463             buf[len] = '.';
6464             len++;
6465             memcpy(&buf[len], n_spec, n_len);
6466             len += n_len;
6467             if (e_len > 0) {
6468                 if (decc_efs_charset) {
6469                     if (e_len == 4
6470                         && (toupper(e_spec[1]) == 'D')
6471                         && (toupper(e_spec[2]) == 'I')
6472                         && (toupper(e_spec[3]) == 'R')) {
6473
6474                         /* Corner case: directory spec with invalid version.
6475                          * Valid would have followed is_dir path above.
6476                          */
6477                         SETERRNO(ENOTDIR, RMS$_DIR);
6478                         return NULL;
6479                     }
6480                     else {
6481                         buf[len] = '^';
6482                         len++;
6483                         memcpy(&buf[len], e_spec, e_len);
6484                         len += e_len;
6485                     }
6486                 }
6487                 else {
6488                     SETERRNO(ENOTDIR, RMS$_DIR);
6489                     return NULL;
6490                 }
6491             }
6492             buf[len] = dclose;
6493             buf[len + 1] = '\0';
6494             return buf;
6495         }
6496 #else
6497         else {
6498             set_vaxc_errno(RMS$_DIR);
6499             set_errno(ENOTDIR);
6500             return NULL;
6501         }
6502 #endif
6503     }
6504     set_vaxc_errno(RMS$_DIR);
6505     set_errno(ENOTDIR);
6506     return NULL;
6507 }
6508
6509
6510 /* Internal routine to make sure or convert a directory to be in a */
6511 /* path specification.  No utf8 flag because it is not changed or used */
6512 static char *int_pathify_dirspec(const char *dir, char *buf)
6513 {
6514     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6515     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6516     char * exp_spec, *ret_spec;
6517     char * trndir;
6518     unsigned short int trnlnm_iter_count;
6519     STRLEN trnlen;
6520     int need_to_lower;
6521
6522     if (vms_debug_fileify) {
6523         if (dir == NULL)
6524             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6525         else
6526             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6527     }
6528
6529     /* We may need to lower case the result if we translated  */
6530     /* a logical name or got the current working directory */
6531     need_to_lower = 0;
6532
6533     if (!dir || !*dir) {
6534       set_errno(EINVAL);
6535       set_vaxc_errno(SS$_BADPARAM);
6536       return NULL;
6537     }
6538
6539     trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
6540     if (trndir == NULL)
6541         _ckvmssts_noperl(SS$_INSFMEM);
6542
6543     /* If no directory specified use the current default */
6544     if (*dir)
6545         my_strlcpy(trndir, dir, VMS_MAXRSS);
6546     else {
6547         getcwd(trndir, VMS_MAXRSS - 1);
6548         need_to_lower = 1;
6549     }
6550
6551     /* now deal with bare names that could be logical names */
6552     trnlnm_iter_count = 0;
6553     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6554            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6555         trnlnm_iter_count++;
6556         need_to_lower = 1;
6557         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6558             break;
6559         trnlen = strlen(trndir);
6560
6561         /* Trap simple rooted lnms, and return lnm:[000000] */
6562         if (!strcmp(trndir+trnlen-2,".]")) {
6563             my_strlcpy(buf, dir, VMS_MAXRSS);
6564             strcat(buf, ":[000000]");
6565             PerlMem_free(trndir);
6566
6567             if (vms_debug_fileify) {
6568                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6569             }
6570             return buf;
6571         }
6572     }
6573
6574     /* At this point we do not work with *dir, but the copy in  *trndir */
6575
6576     if (need_to_lower && !decc_efs_case_preserve) {
6577         /* Legacy mode, lower case the returned value */
6578         __mystrtolower(trndir);
6579     }
6580
6581
6582     /* Some special cases, '..', '.' */
6583     sts = 0;
6584     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6585        /* Force UNIX filespec */
6586        sts = 1;
6587
6588     } else {
6589         /* Is this Unix or VMS format? */
6590         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6591                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6592                              &e_len, &vs_spec, &vs_len);
6593         if (sts == 0) {
6594
6595             /* Just a filename? */
6596             if ((v_len + r_len + d_len) == 0) {
6597
6598                 /* Now we have a problem, this could be Unix or VMS */
6599                 /* We have to guess.  .DIR usually means VMS */
6600
6601                 /* In UNIX report mode, the .DIR extension is removed */
6602                 /* if one shows up, it is for a non-directory or a directory */
6603                 /* in EFS charset mode */
6604
6605                 /* So if we are in Unix report mode, assume that this */
6606                 /* is a relative Unix directory specification */
6607
6608                 sts = 1;
6609                 if (!decc_filename_unix_report && decc_efs_charset) {
6610                     int is_dir;
6611                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6612
6613                     if (is_dir) {
6614                         /* Traditional mode, assume .DIR is directory */
6615                         buf[0] = '[';
6616                         buf[1] = '.';
6617                         memcpy(&buf[2], n_spec, n_len);
6618                         buf[n_len + 2] = ']';
6619                         buf[n_len + 3] = '\0';
6620                         PerlMem_free(trndir);
6621                         if (vms_debug_fileify) {
6622                             fprintf(stderr,
6623                                     "int_pathify_dirspec: buf = %s\n",
6624                                     buf);
6625                         }
6626                         return buf;
6627                     }
6628                 }
6629             }
6630         }
6631     }
6632     if (sts == 0) {
6633         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6634             v_spec, v_len, r_spec, r_len,
6635             d_spec, d_len, n_spec, n_len,
6636             e_spec, e_len, vs_spec, vs_len);
6637
6638         if (ret_spec != NULL) {
6639             PerlMem_free(trndir);
6640             if (vms_debug_fileify) {
6641                 fprintf(stderr,
6642                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6643             }
6644             return ret_spec;
6645         }
6646
6647         /* Simple way did not work, which means that a logical name */
6648         /* was present for the directory specification.             */
6649         /* Need to use an rmsexpand variant to decode it completely */
6650         exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
6651         if (exp_spec == NULL)
6652             _ckvmssts_noperl(SS$_INSFMEM);
6653
6654         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6655         if (ret_spec != NULL) {
6656             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6657                                  &r_spec, &r_len, &d_spec, &d_len,
6658                                  &n_spec, &n_len, &e_spec,
6659                                  &e_len, &vs_spec, &vs_len);
6660             if (sts == 0) {
6661                 ret_spec = int_pathify_dirspec_simple(
6662                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6663                     d_spec, d_len, n_spec, n_len,
6664                     e_spec, e_len, vs_spec, vs_len);
6665
6666                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6667                     /* Legacy mode, lower case the returned value */
6668                     __mystrtolower(ret_spec);
6669                 }
6670             } else {
6671                 set_vaxc_errno(RMS$_DIR);
6672                 set_errno(ENOTDIR);
6673                 ret_spec = NULL;
6674             }
6675         }
6676         PerlMem_free(exp_spec);
6677         PerlMem_free(trndir);
6678         if (vms_debug_fileify) {
6679             if (ret_spec == NULL)
6680                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6681             else
6682                 fprintf(stderr,
6683                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6684         }
6685         return ret_spec;
6686
6687     } else {
6688         /* Unix specification, Could be trivial conversion, */
6689         /* but have to deal with trailing '.dir' or extra '.' */
6690
6691         char * lastdot;
6692         char * lastslash;
6693         int is_dir;
6694         STRLEN dir_len = strlen(trndir);
6695
6696         lastslash = strrchr(trndir, '/');
6697         if (lastslash == NULL)
6698             lastslash = trndir;
6699         else
6700             lastslash++;
6701
6702         lastdot = NULL;
6703
6704         /* '..' or '.' are valid directory components */
6705         is_dir = 0;
6706         if (lastslash[0] == '.') {
6707             if (lastslash[1] == '\0') {
6708                is_dir = 1;
6709             } else if (lastslash[1] == '.') {
6710                 if (lastslash[2] == '\0') {
6711                     is_dir = 1;
6712                 } else {
6713                     /* And finally allow '...' */
6714                     if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6715                         is_dir = 1;
6716                     }
6717                 }
6718             }
6719         }
6720
6721         if (!is_dir) {
6722            lastdot = strrchr(lastslash, '.');
6723         }
6724         if (lastdot != NULL) {
6725             STRLEN e_len;
6726              /* '.dir' is discarded, and any other '.' is invalid */
6727             e_len = strlen(lastdot);
6728
6729             is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6730
6731             if (is_dir) {
6732                 dir_len = dir_len - 4;
6733             }
6734         }
6735
6736         my_strlcpy(buf, trndir, VMS_MAXRSS);
6737         if (buf[dir_len - 1] != '/') {
6738             buf[dir_len] = '/';
6739             buf[dir_len + 1] = '\0';
6740         }
6741
6742         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6743         if (!decc_efs_charset) {
6744              int dir_start = 0;
6745              char * str = buf;
6746              if (str[0] == '.') {
6747                  char * dots = str;
6748                  int cnt = 1;
6749                  while ((dots[cnt] == '.') && (cnt < 3))
6750                      cnt++;
6751                  if (cnt <= 3) {
6752                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6753                          dir_start = 1;
6754                          str += cnt;
6755                      }
6756                  }
6757              }
6758              for (; *str; ++str) {
6759                  while (*str == '/') {
6760                      dir_start = 1;
6761                      *str++;
6762                  }
6763                  if (dir_start) {
6764
6765                      /* Have to skip up to three dots which could be */
6766                      /* directories, 3 dots being a VMS extension for Perl */
6767                      char * dots = str;
6768                      int cnt = 0;
6769                      while ((dots[cnt] == '.') && (cnt < 3)) {
6770                          cnt++;
6771                      }
6772                      if (dots[cnt] == '\0')
6773                          break;
6774                      if ((cnt > 1) && (dots[cnt] != '/')) {
6775                          dir_start = 0;
6776                      } else {
6777                          str += cnt;
6778                      }
6779
6780                      /* too many dots? */
6781                      if ((cnt == 0) || (cnt > 3)) {
6782                          dir_start = 0;
6783                      }
6784                  }
6785                  if (!dir_start && (*str == '.')) {
6786                      *str = '_';
6787                  }
6788              }
6789         }
6790         PerlMem_free(trndir);
6791         ret_spec = buf;
6792         if (vms_debug_fileify) {
6793             if (ret_spec == NULL)
6794                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6795             else
6796                 fprintf(stderr,
6797                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6798         }
6799         return ret_spec;
6800     }
6801 }
6802
6803 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6804 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6805 {
6806     static char __pathify_retbuf[VMS_MAXRSS];
6807     char * pathified, *ret_spec, *ret_buf;
6808
6809     pathified = NULL;
6810     ret_buf = buf;
6811     if (ret_buf == NULL) {
6812         if (ts) {
6813             Newx(pathified, VMS_MAXRSS, char);
6814             if (pathified == NULL)
6815                 _ckvmssts(SS$_INSFMEM);
6816             ret_buf = pathified;
6817         } else {
6818             ret_buf = __pathify_retbuf;
6819         }
6820     }
6821
6822     ret_spec = int_pathify_dirspec(dir, ret_buf);
6823
6824     if (ret_spec == NULL) {
6825        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6826        if (pathified)
6827            Safefree(pathified);
6828     }
6829
6830     return ret_spec;
6831
6832 }  /* end of do_pathify_dirspec() */
6833
6834
6835 /* External entry points */
6836 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6837 { return do_pathify_dirspec(dir,buf,0,NULL); }
6838 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6839 { return do_pathify_dirspec(dir,buf,1,NULL); }
6840 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6841 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6842 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6843 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6844
6845 /* Internal tounixspec routine that does not use a thread context */
6846 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6847 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6848 {
6849   char *dirend, *cp1, *cp3, *tmp;
6850   const char *cp2;
6851   int dirlen;
6852   unsigned short int trnlnm_iter_count;
6853   int cmp_rslt, outchars_added;
6854   if (utf8_fl != NULL)
6855     *utf8_fl = 0;
6856
6857   if (vms_debug_fileify) {
6858       if (spec == NULL)
6859           fprintf(stderr, "int_tounixspec: spec = NULL\n");
6860       else
6861           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6862   }
6863
6864
6865   if (spec == NULL) {
6866       set_errno(EINVAL);
6867       set_vaxc_errno(SS$_BADPARAM);
6868       return NULL;
6869   }
6870   if (strlen(spec) > (VMS_MAXRSS-1)) {
6871       set_errno(E2BIG);
6872       set_vaxc_errno(SS$_BUFFEROVF);
6873       return NULL;
6874   }
6875
6876   /* New VMS specific format needs translation
6877    * glob passes filenames with trailing '\n' and expects this preserved.
6878    */
6879   if (decc_posix_compliant_pathnames) {
6880     if (strncmp(spec, "\"^UP^", 5) == 0) {
6881       char * uspec;
6882       char *tunix;
6883       int tunix_len;
6884       int nl_flag;
6885
6886       tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
6887       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6888       tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
6889       nl_flag = 0;
6890       if (tunix[tunix_len - 1] == '\n') {
6891         tunix[tunix_len - 1] = '\"';
6892         tunix[tunix_len] = '\0';
6893         tunix_len--;
6894         nl_flag = 1;
6895       }
6896       uspec = decc$translate_vms(tunix);
6897       PerlMem_free(tunix);
6898       if ((int)uspec > 0) {
6899         my_strlcpy(rslt, uspec, VMS_MAXRSS);
6900         if (nl_flag) {
6901           strcat(rslt,"\n");
6902         }
6903         else {
6904           /* If we can not translate it, makemaker wants as-is */
6905           my_strlcpy(rslt, spec, VMS_MAXRSS);
6906         }
6907         return rslt;
6908       }
6909     }
6910   }
6911
6912   cmp_rslt = 0; /* Presume VMS */
6913   cp1 = strchr(spec, '/');
6914   if (cp1 == NULL)
6915     cmp_rslt = 0;
6916
6917     /* Look for EFS ^/ */
6918     if (decc_efs_charset) {
6919       while (cp1 != NULL) {
6920         cp2 = cp1 - 1;
6921         if (*cp2 != '^') {
6922           /* Found illegal VMS, assume UNIX */
6923           cmp_rslt = 1;
6924           break;
6925         }
6926       cp1++;
6927       cp1 = strchr(cp1, '/');
6928     }
6929   }
6930
6931   /* Look for "." and ".." */
6932   if (decc_filename_unix_report) {
6933     if (spec[0] == '.') {
6934       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6935         cmp_rslt = 1;
6936       }
6937       else {
6938         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6939           cmp_rslt = 1;
6940         }
6941       }
6942     }
6943   }
6944
6945   cp1 = rslt;
6946   cp2 = spec;
6947
6948   /* This is already UNIX or at least nothing VMS understands,
6949    * so all we can reasonably do is unescape extended chars.
6950    */
6951   if (cmp_rslt) {
6952     while (*cp2) {
6953         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
6954         cp1 += outchars_added;
6955     }
6956     *cp1 = '\0';
6957     if (vms_debug_fileify) {
6958         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6959     }
6960     return rslt;
6961   }
6962
6963   dirend = strrchr(spec,']');
6964   if (dirend == NULL) dirend = strrchr(spec,'>');
6965   if (dirend == NULL) dirend = strchr(spec,':');
6966   if (dirend == NULL) {
6967     while (*cp2) {
6968         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
6969         cp1 += outchars_added;
6970     }
6971     *cp1 = '\0';
6972     if (vms_debug_fileify) {
6973         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6974     }
6975     return rslt;
6976   }
6977
6978   /* Special case 1 - sys$posix_root = / */
6979   if (!decc_disable_posix_root) {
6980     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6981       *cp1 = '/';
6982       cp1++;
6983       cp2 = cp2 + 15;
6984       }
6985   }
6986
6987   /* Special case 2 - Convert NLA0: to /dev/null */
6988   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6989   if (cmp_rslt == 0) {
6990     strcpy(rslt, "/dev/null");
6991     cp1 = cp1 + 9;
6992     cp2 = cp2 + 5;
6993     if (spec[6] != '\0') {
6994       cp1[9] = '/';
6995       cp1++;
6996       cp2++;
6997     }
6998   }
6999
7000    /* Also handle special case "SYS$SCRATCH:" */
7001   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7002   tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
7003   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7004   if (cmp_rslt == 0) {
7005   int islnm;
7006
7007     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7008     if (!islnm) {
7009       strcpy(rslt, "/tmp");
7010       cp1 = cp1 + 4;
7011       cp2 = cp2 + 12;
7012       if (spec[12] != '\0') {
7013         cp1[4] = '/';
7014         cp1++;
7015         cp2++;
7016       }
7017     }
7018   }
7019
7020   if (*cp2 != '[' && *cp2 != '<') {
7021     *(cp1++) = '/';
7022   }
7023   else {  /* the VMS spec begins with directories */
7024     cp2++;
7025     if (*cp2 == ']' || *cp2 == '>') {
7026       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7027       PerlMem_free(tmp);
7028       return rslt;
7029     }
7030     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7031       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7032         PerlMem_free(tmp);
7033         if (vms_debug_fileify) {
7034             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7035         }
7036         return NULL;
7037       }
7038       trnlnm_iter_count = 0;
7039       do {
7040         cp3 = tmp;
7041         while (*cp3 != ':' && *cp3) cp3++;
7042         *(cp3++) = '\0';
7043         if (strchr(cp3,']') != NULL) break;
7044         trnlnm_iter_count++;
7045         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7046       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7047       cp1 = rslt;
7048       cp3 = tmp;
7049       *(cp1++) = '/';
7050       while (*cp3) {
7051         *(cp1++) = *(cp3++);
7052         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7053             PerlMem_free(tmp);
7054             set_errno(ENAMETOOLONG);
7055             set_vaxc_errno(SS$_BUFFEROVF);
7056             if (vms_debug_fileify) {
7057                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7058             }
7059             return NULL; /* No room */
7060         }
7061       }
7062       *(cp1++) = '/';
7063     }
7064     if ((*cp2 == '^')) {
7065         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7066         cp1 += outchars_added;
7067     }
7068     else if ( *cp2 == '.') {
7069       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7070         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7071         cp2 += 3;
7072       }
7073       else cp2++;
7074     }
7075   }
7076   PerlMem_free(tmp);
7077   for (; cp2 <= dirend; cp2++) {
7078     if ((*cp2 == '^')) {
7079         /* EFS file escape, pass the next character as is */
7080         /* Fix me: HEX encoding for Unicode not implemented */
7081         *(cp1++) = *(++cp2);
7082         /* An escaped dot stays as is -- don't convert to slash */
7083         if (*cp2 == '.') cp2++;
7084     }
7085     if (*cp2 == ':') {
7086       *(cp1++) = '/';
7087       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7088     }
7089     else if (*cp2 == ']' || *cp2 == '>') {
7090       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7091     }
7092     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7093       *(cp1++) = '/';
7094       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7095         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7096                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7097         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7098             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7099       }
7100       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7101         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7102         cp2 += 2;
7103       }
7104     }
7105     else if (*cp2 == '-') {
7106       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7107         while (*cp2 == '-') {
7108           cp2++;
7109           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7110         }
7111         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7112                                                          /* filespecs like */
7113           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7114           if (vms_debug_fileify) {
7115               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7116           }
7117           return NULL;
7118         }
7119       }
7120       else *(cp1++) = *cp2;
7121     }
7122     else *(cp1++) = *cp2;
7123   }
7124   /* Translate the rest of the filename. */
7125   while (*cp2) {
7126       int dot_seen = 0;
7127       switch(*cp2) {
7128       /* Fixme - for compatibility with the CRTL we should be removing */
7129       /* spaces from the file specifications, but this may show that */
7130       /* some tests that were appearing to pass are not really passing */
7131       case '%':
7132           cp2++;
7133           *(cp1++) = '?';
7134           break;
7135       case '^':
7136           cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7137           cp1 += outchars_added;
7138           break;
7139       case ';':
7140           if (decc_filename_unix_no_version) {
7141               /* Easy, drop the version */
7142               while (*cp2)
7143                   cp2++;
7144               break;
7145           } else {
7146               /* Punt - passing the version as a dot will probably */
7147               /* break perl in weird ways, but so did passing */
7148               /* through the ; as a version.  Follow the CRTL and */
7149               /* hope for the best. */
7150               cp2++;
7151               *(cp1++) = '.';
7152           }
7153           break;
7154       case '.':
7155           if (dot_seen) {
7156               /* We will need to fix this properly later */
7157               /* As Perl may be installed on an ODS-5 volume, but not */
7158               /* have the EFS_CHARSET enabled, it still may encounter */
7159               /* filenames with extra dots in them, and a precedent got */
7160               /* set which allowed them to work, that we will uphold here */
7161               /* If extra dots are present in a name and no ^ is on them */
7162               /* VMS assumes that the first one is the extension delimiter */
7163               /* the rest have an implied ^. */
7164
7165               /* this is also a conflict as the . is also a version */
7166               /* delimiter in VMS, */
7167
7168               *(cp1++) = *(cp2++);
7169               break;
7170           }
7171           dot_seen = 1;
7172           /* This is an extension */
7173           if (decc_readdir_dropdotnotype) {
7174               cp2++;
7175               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7176                   /* Drop the dot for the extension */
7177                   break;
7178               } else {
7179                   *(cp1++) = '.';
7180               }
7181               break;
7182           }
7183       default:
7184           *(cp1++) = *(cp2++);
7185       }
7186   }
7187   *cp1 = '\0';
7188
7189   /* This still leaves /000000/ when working with a
7190    * VMS device root or concealed root.
7191    */
7192   {
7193   int ulen;
7194   char * zeros;
7195
7196       ulen = strlen(rslt);
7197
7198       /* Get rid of "000000/ in rooted filespecs */
7199       if (ulen > 7) {
7200         zeros = strstr(rslt, "/000000/");
7201         if (zeros != NULL) {
7202           int mlen;
7203           mlen = ulen - (zeros - rslt) - 7;
7204           memmove(zeros, &zeros[7], mlen);
7205           ulen = ulen - 7;
7206           rslt[ulen] = '\0';
7207         }
7208       }
7209   }
7210
7211   if (vms_debug_fileify) {
7212       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7213   }
7214   return rslt;
7215
7216 }  /* end of int_tounixspec() */
7217
7218
7219 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7220 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7221 {
7222     static char __tounixspec_retbuf[VMS_MAXRSS];
7223     char * unixspec, *ret_spec, *ret_buf;
7224
7225     unixspec = NULL;
7226     ret_buf = buf;
7227     if (ret_buf == NULL) {
7228         if (ts) {
7229             Newx(unixspec, VMS_MAXRSS, char);
7230             if (unixspec == NULL)
7231                 _ckvmssts(SS$_INSFMEM);
7232             ret_buf = unixspec;
7233         } else {
7234             ret_buf = __tounixspec_retbuf;
7235         }
7236     }
7237
7238     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7239
7240     if (ret_spec == NULL) {
7241        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7242        if (unixspec)
7243            Safefree(unixspec);
7244     }
7245
7246     return ret_spec;
7247
7248 }  /* end of do_tounixspec() */
7249 /*}}}*/
7250 /* External entry points */
7251 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7252   { return do_tounixspec(spec,buf,0, NULL); }
7253 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7254   { return do_tounixspec(spec,buf,1, NULL); }
7255 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7256   { return do_tounixspec(spec,buf,0, utf8_fl); }
7257 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7258   { return do_tounixspec(spec,buf,1, utf8_fl); }
7259
7260 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7261
7262 /*
7263  This procedure is used to identify if a path is based in either
7264  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7265  it returns the OpenVMS format directory for it.
7266
7267  It is expecting specifications of only '/' or '/xxxx/'
7268
7269  If a posix root does not exist, or 'xxxx' is not a directory
7270  in the posix root, it returns a failure.
7271
7272  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7273
7274  It is used only internally by posix_to_vmsspec_hardway().
7275  */
7276
7277 static int posix_root_to_vms
7278   (char *vmspath, int vmspath_len,
7279    const char *unixpath,
7280    const int * utf8_fl)
7281 {
7282 int sts;
7283 struct FAB myfab = cc$rms_fab;
7284 rms_setup_nam(mynam);
7285 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7286 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7287 char * esa, * esal, * rsa, * rsal;
7288 int dir_flag;
7289 int unixlen;
7290
7291     dir_flag = 0;
7292     vmspath[0] = '\0';
7293     unixlen = strlen(unixpath);
7294     if (unixlen == 0) {
7295       return RMS$_FNF;
7296     }
7297
7298 #if __CRTL_VER >= 80200000
7299   /* If not a posix spec already, convert it */
7300   if (decc_posix_compliant_pathnames) {
7301     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7302       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7303     }
7304     else {
7305       /* This is already a VMS specification, no conversion */
7306       unixlen--;
7307       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7308     }
7309   }
7310   else
7311 #endif
7312   {
7313   int path_len;
7314   int i,j;
7315
7316      /* Check to see if this is under the POSIX root */
7317      if (decc_disable_posix_root) {
7318         return RMS$_FNF;
7319      }
7320
7321      /* Skip leading / */
7322      if (unixpath[0] == '/') {
7323         unixpath++;
7324         unixlen--;
7325      }
7326
7327
7328      strcpy(vmspath,"SYS$POSIX_ROOT:");
7329
7330      /* If this is only the / , or blank, then... */
7331      if (unixpath[0] == '\0') {
7332         /* by definition, this is the answer */
7333         return SS$_NORMAL;
7334      }
7335
7336      /* Need to look up a directory */
7337      vmspath[15] = '[';
7338      vmspath[16] = '\0';
7339
7340      /* Copy and add '^' escape characters as needed */
7341      j = 16;
7342      i = 0;
7343      while (unixpath[i] != 0) {
7344      int k;
7345
7346         j += copy_expand_unix_filename_escape
7347             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7348         i += k;
7349      }
7350
7351      path_len = strlen(vmspath);
7352      if (vmspath[path_len - 1] == '/')
7353         path_len--;
7354      vmspath[path_len] = ']';
7355      path_len++;
7356      vmspath[path_len] = '\0';
7357
7358   }
7359   vmspath[vmspath_len] = 0;
7360   if (unixpath[unixlen - 1] == '/')
7361   dir_flag = 1;
7362   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7363   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7364   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7365   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7366   rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7367   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7368   rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7369   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7370   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7371   rms_bind_fab_nam(myfab, mynam);
7372   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7373   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7374   if (decc_efs_case_preserve)
7375     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7376 #ifdef NAML$M_OPEN_SPECIAL
7377   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7378 #endif
7379
7380   /* Set up the remaining naml fields */
7381   sts = sys$parse(&myfab);
7382
7383   /* It failed! Try again as a UNIX filespec */
7384   if (!(sts & 1)) {
7385     PerlMem_free(esal);
7386     PerlMem_free(esa);
7387     PerlMem_free(rsal);
7388     PerlMem_free(rsa);
7389     return sts;
7390   }
7391
7392    /* get the Device ID and the FID */
7393    sts = sys$search(&myfab);
7394
7395    /* These are no longer needed */
7396    PerlMem_free(esa);
7397    PerlMem_free(rsal);
7398    PerlMem_free(rsa);
7399
7400    /* on any failure, returned the POSIX ^UP^ filespec */
7401    if (!(sts & 1)) {
7402       PerlMem_free(esal);
7403       return sts;
7404    }
7405    specdsc.dsc$a_pointer = vmspath;
7406    specdsc.dsc$w_length = vmspath_len;
7407
7408    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7409    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7410    sts = lib$fid_to_name
7411       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7412
7413   /* on any failure, returned the POSIX ^UP^ filespec */
7414   if (!(sts & 1)) {
7415      /* This can happen if user does not have permission to read directories */
7416      if (strncmp(unixpath,"\"^UP^",5) != 0)
7417        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7418      else
7419        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7420   }
7421   else {
7422     vmspath[specdsc.dsc$w_length] = 0;
7423
7424     /* Are we expecting a directory? */
7425     if (dir_flag != 0) {
7426     int i;
7427     char *eptr;
7428
7429       eptr = NULL;
7430
7431       i = specdsc.dsc$w_length - 1;
7432       while (i > 0) {
7433       int zercnt;
7434         zercnt = 0;
7435         /* Version must be '1' */
7436         if (vmspath[i--] != '1')
7437           break;
7438         /* Version delimiter is one of ".;" */
7439         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7440           break;
7441         i--;
7442         if (vmspath[i--] != 'R')
7443           break;
7444         if (vmspath[i--] != 'I')
7445           break;
7446         if (vmspath[i--] != 'D')
7447           break;
7448         if (vmspath[i--] != '.')
7449           break;
7450         eptr = &vmspath[i+1];
7451         while (i > 0) {
7452           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7453             if (vmspath[i-1] != '^') {
7454               if (zercnt != 6) {
7455                 *eptr = vmspath[i];
7456                 eptr[1] = '\0';
7457                 vmspath[i] = '.';
7458                 break;
7459               }
7460               else {
7461                 /* Get rid of 6 imaginary zero directory filename */
7462                 vmspath[i+1] = '\0';
7463               }
7464             }
7465           }
7466           if (vmspath[i] == '0')
7467             zercnt++;
7468           else
7469             zercnt = 10;
7470           i--;
7471         }
7472         break;
7473       }
7474     }
7475   }
7476   PerlMem_free(esal);
7477   return sts;
7478 }
7479
7480 /* /dev/mumble needs to be handled special.
7481    /dev/null becomes NLA0:, And there is the potential for other stuff
7482    like /dev/tty which may need to be mapped to something.
7483 */
7484
7485 static int
7486 slash_dev_special_to_vms
7487    (const char * unixptr,
7488     char * vmspath,
7489     int vmspath_len)
7490 {
7491 char * nextslash;
7492 int len;
7493 int cmp;
7494
7495     unixptr += 4;
7496     nextslash = strchr(unixptr, '/');
7497     len = strlen(unixptr);
7498     if (nextslash != NULL)
7499         len = nextslash - unixptr;
7500     cmp = strncmp("null", unixptr, 5);
7501     if (cmp == 0) {
7502         if (vmspath_len >= 6) {
7503             strcpy(vmspath, "_NLA0:");
7504             return SS$_NORMAL;
7505         }
7506     }
7507     return 0;
7508 }
7509
7510
7511 /* The built in routines do not understand perl's special needs, so
7512     doing a manual conversion from UNIX to VMS
7513
7514     If the utf8_fl is not null and points to a non-zero value, then
7515     treat 8 bit characters as UTF-8.
7516
7517     The sequence starting with '$(' and ending with ')' will be passed
7518     through with out interpretation instead of being escaped.
7519
7520   */
7521 static int posix_to_vmsspec_hardway
7522   (char *vmspath, int vmspath_len,
7523    const char *unixpath,
7524    int dir_flag,
7525    int * utf8_fl) {
7526
7527 char *esa;
7528 const char *unixptr;
7529 const char *unixend;
7530 char *vmsptr;
7531 const char *lastslash;
7532 const char *lastdot;
7533 int unixlen;
7534 int vmslen;
7535 int dir_start;
7536 int dir_dot;
7537 int quoted;
7538 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7539 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7540
7541   if (utf8_fl != NULL)
7542     *utf8_fl = 0;
7543
7544   unixptr = unixpath;
7545   dir_dot = 0;
7546
7547   /* Ignore leading "/" characters */
7548   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7549     unixptr++;
7550   }
7551   unixlen = strlen(unixptr);
7552
7553   /* Do nothing with blank paths */
7554   if (unixlen == 0) {
7555     vmspath[0] = '\0';
7556     return SS$_NORMAL;
7557   }
7558
7559   quoted = 0;
7560   /* This could have a "^UP^ on the front */
7561   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7562     quoted = 1;
7563     unixptr+= 5;
7564     unixlen-= 5;
7565   }
7566
7567   lastslash = strrchr(unixptr,'/');
7568   lastdot = strrchr(unixptr,'.');
7569   unixend = strrchr(unixptr,'\"');
7570   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7571     unixend = unixptr + unixlen;
7572   }
7573
7574   /* last dot is last dot or past end of string */
7575   if (lastdot == NULL)
7576     lastdot = unixptr + unixlen;
7577
7578   /* if no directories, set last slash to beginning of string */
7579   if (lastslash == NULL) {
7580     lastslash = unixptr;
7581   }
7582   else {
7583     /* Watch out for trailing "." after last slash, still a directory */
7584     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7585       lastslash = unixptr + unixlen;
7586     }
7587
7588     /* Watch out for trailing ".." after last slash, still a directory */
7589     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7590       lastslash = unixptr + unixlen;
7591     }
7592
7593     /* dots in directories are aways escaped */
7594     if (lastdot < lastslash)
7595       lastdot = unixptr + unixlen;
7596   }
7597
7598   /* if (unixptr < lastslash) then we are in a directory */
7599
7600   dir_start = 0;
7601
7602   vmsptr = vmspath;
7603   vmslen = 0;
7604
7605   /* Start with the UNIX path */
7606   if (*unixptr != '/') {
7607     /* relative paths */
7608
7609     /* If allowing logical names on relative pathnames, then handle here */
7610     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7611         !decc_posix_compliant_pathnames) {
7612     char * nextslash;
7613     int seg_len;
7614     char * trn;
7615     int islnm;
7616
7617         /* Find the next slash */
7618         nextslash = strchr(unixptr,'/');
7619
7620         esa = (char *)PerlMem_malloc(vmspath_len);
7621         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7622
7623         trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7624         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7625
7626         if (nextslash != NULL) {
7627
7628             seg_len = nextslash - unixptr;
7629             memcpy(esa, unixptr, seg_len);
7630             esa[seg_len] = 0;
7631         }
7632         else {
7633             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7634         }
7635         /* trnlnm(section) */
7636         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7637
7638         if (islnm) {
7639             /* Now fix up the directory */
7640
7641             /* Split up the path to find the components */
7642             sts = vms_split_path
7643                   (trn,
7644                    &v_spec,
7645                    &v_len,
7646                    &r_spec,
7647                    &r_len,
7648                    &d_spec,
7649                    &d_len,
7650                    &n_spec,
7651                    &n_len,
7652                    &e_spec,
7653                    &e_len,
7654                    &vs_spec,
7655                    &vs_len);
7656
7657             while (sts == 0) {
7658             int cmp;
7659
7660                 /* A logical name must be a directory  or the full
7661                    specification.  It is only a full specification if
7662                    it is the only component */
7663                 if ((unixptr[seg_len] == '\0') ||
7664                     (unixptr[seg_len+1] == '\0')) {
7665
7666                     /* Is a directory being required? */
7667                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7668                         /* Not a logical name */
7669                         break;
7670                     }
7671
7672
7673                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7674                         /* This must be a directory */
7675                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7676                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7677                             vmsptr[vmslen] = ':';
7678                             vmslen++;
7679                             vmsptr[vmslen] = '\0';
7680                             return SS$_NORMAL;
7681                         }
7682                     }
7683
7684                 }
7685
7686
7687                 /* must be dev/directory - ignore version */
7688                 if ((n_len + e_len) != 0)
7689                     break;
7690
7691                 /* transfer the volume */
7692                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7693                     memcpy(vmsptr, v_spec, v_len);
7694                     vmsptr += v_len;
7695                     vmsptr[0] = '\0';
7696                     vmslen += v_len;
7697                 }
7698
7699                 /* unroot the rooted directory */
7700                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7701                     r_spec[0] = '[';
7702                     r_spec[r_len - 1] = ']';
7703
7704                     /* This should not be there, but nothing is perfect */
7705                     if (r_len > 9) {
7706                         cmp = strcmp(&r_spec[1], "000000.");
7707                         if (cmp == 0) {
7708                             r_spec += 7;
7709                             r_spec[7] = '[';
7710                             r_len -= 7;
7711                             if (r_len == 2)
7712                                 r_len = 0;
7713                         }
7714                     }
7715                     if (r_len > 0) {
7716                         memcpy(vmsptr, r_spec, r_len);
7717                         vmsptr += r_len;
7718                         vmslen += r_len;
7719                         vmsptr[0] = '\0';
7720                     }
7721                 }
7722                 /* Bring over the directory. */
7723                 if ((d_len > 0) &&
7724                     ((d_len + vmslen) < vmspath_len)) {
7725                     d_spec[0] = '[';
7726                     d_spec[d_len - 1] = ']';
7727                     if (d_len > 9) {
7728                         cmp = strcmp(&d_spec[1], "000000.");
7729                         if (cmp == 0) {
7730                             d_spec += 7;
7731                             d_spec[7] = '[';
7732                             d_len -= 7;
7733                             if (d_len == 2)
7734                                 d_len = 0;
7735                         }
7736                     }
7737
7738                     if (r_len > 0) {
7739                         /* Remove the redundant root */
7740                         if (r_len > 0) {
7741                             /* remove the ][ */
7742                             vmsptr--;
7743                             vmslen--;
7744                             d_spec++;
7745                             d_len--;
7746                         }
7747                         memcpy(vmsptr, d_spec, d_len);
7748                             vmsptr += d_len;
7749                             vmslen += d_len;
7750                             vmsptr[0] = '\0';
7751                     }
7752                 }
7753                 break;
7754             }
7755         }
7756
7757         PerlMem_free(esa);
7758         PerlMem_free(trn);
7759     }
7760
7761     if (lastslash > unixptr) {
7762     int dotdir_seen;
7763
7764       /* skip leading ./ */
7765       dotdir_seen = 0;
7766       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7767         dotdir_seen = 1;
7768         unixptr++;
7769         unixptr++;
7770       }
7771
7772       /* Are we still in a directory? */
7773       if (unixptr <= lastslash) {
7774         *vmsptr++ = '[';
7775         vmslen = 1;
7776         dir_start = 1;
7777
7778         /* if not backing up, then it is relative forward. */
7779         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7780               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7781           *vmsptr++ = '.';
7782           vmslen++;
7783           dir_dot = 1;
7784           }
7785        }
7786        else {
7787          if (dotdir_seen) {
7788            /* Perl wants an empty directory here to tell the difference
7789             * between a DCL command and a filename
7790             */
7791           *vmsptr++ = '[';
7792           *vmsptr++ = ']';
7793           vmslen = 2;
7794         }
7795       }
7796     }
7797     else {
7798       /* Handle two special files . and .. */
7799       if (unixptr[0] == '.') {
7800         if (&unixptr[1] == unixend) {
7801           *vmsptr++ = '[';
7802           *vmsptr++ = ']';
7803           vmslen += 2;
7804           *vmsptr++ = '\0';
7805           return SS$_NORMAL;
7806         }
7807         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7808           *vmsptr++ = '[';
7809           *vmsptr++ = '-';
7810           *vmsptr++ = ']';
7811           vmslen += 3;
7812           *vmsptr++ = '\0';
7813           return SS$_NORMAL;
7814         }
7815       }
7816     }
7817   }
7818   else {        /* Absolute PATH handling */
7819   int sts;
7820   char * nextslash;
7821   int seg_len;
7822     /* Need to find out where root is */
7823
7824     /* In theory, this procedure should never get an absolute POSIX pathname
7825      * that can not be found on the POSIX root.
7826      * In practice, that can not be relied on, and things will show up
7827      * here that are a VMS device name or concealed logical name instead.
7828      * So to make things work, this procedure must be tolerant.
7829      */
7830     esa = (char *)PerlMem_malloc(vmspath_len);
7831     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7832
7833     sts = SS$_NORMAL;
7834     nextslash = strchr(&unixptr[1],'/');
7835     seg_len = 0;
7836     if (nextslash != NULL) {
7837       int cmp;
7838       seg_len = nextslash - &unixptr[1];
7839       my_strlcpy(vmspath, unixptr, seg_len + 2);
7840       cmp = 1;
7841       if (seg_len == 3) {
7842         cmp = strncmp(vmspath, "dev", 4);
7843         if (cmp == 0) {
7844             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7845             if (sts == SS$_NORMAL)
7846                 return SS$_NORMAL;
7847         }
7848       }
7849       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7850     }
7851
7852     if ($VMS_STATUS_SUCCESS(sts)) {
7853       /* This is verified to be a real path */
7854
7855       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7856       if ($VMS_STATUS_SUCCESS(sts)) {
7857         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
7858         vmsptr = vmspath + vmslen;
7859         unixptr++;
7860         if (unixptr < lastslash) {
7861         char * rptr;
7862           vmsptr--;
7863           *vmsptr++ = '.';
7864           dir_start = 1;
7865           dir_dot = 1;
7866           if (vmslen > 7) {
7867           int cmp;
7868             rptr = vmsptr - 7;
7869             cmp = strcmp(rptr,"000000.");
7870             if (cmp == 0) {
7871               vmslen -= 7;
7872               vmsptr -= 7;
7873               vmsptr[1] = '\0';
7874             } /* removing 6 zeros */
7875           } /* vmslen < 7, no 6 zeros possible */
7876         } /* Not in a directory */
7877       } /* Posix root found */
7878       else {
7879         /* No posix root, fall back to default directory */
7880         strcpy(vmspath, "SYS$DISK:[");
7881         vmsptr = &vmspath[10];
7882         vmslen = 10;
7883         if (unixptr > lastslash) {
7884            *vmsptr = ']';
7885            vmsptr++;
7886            vmslen++;
7887         }
7888         else {
7889            dir_start = 1;
7890         }
7891       }
7892     } /* end of verified real path handling */
7893     else {
7894     int add_6zero;
7895     int islnm;
7896
7897       /* Ok, we have a device or a concealed root that is not in POSIX
7898        * or we have garbage.  Make the best of it.
7899        */
7900
7901       /* Posix to VMS destroyed this, so copy it again */
7902       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
7903       vmslen = strlen(vmspath); /* We know we're truncating. */
7904       vmsptr = &vmsptr[vmslen];
7905       islnm = 0;
7906
7907       /* Now do we need to add the fake 6 zero directory to it? */
7908       add_6zero = 1;
7909       if ((*lastslash == '/') && (nextslash < lastslash)) {
7910         /* No there is another directory */
7911         add_6zero = 0;
7912       }
7913       else {
7914       int trnend;
7915       int cmp;
7916
7917         /* now we have foo:bar or foo:[000000]bar to decide from */
7918         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7919
7920         if (!islnm && !decc_posix_compliant_pathnames) {
7921
7922             cmp = strncmp("bin", vmspath, 4);
7923             if (cmp == 0) {
7924                 /* bin => SYS$SYSTEM: */
7925                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7926             }
7927             else {
7928                 /* tmp => SYS$SCRATCH: */
7929                 cmp = strncmp("tmp", vmspath, 4);
7930                 if (cmp == 0) {
7931                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7932                 }
7933             }
7934         }
7935
7936         trnend = islnm ? islnm - 1 : 0;
7937
7938         /* if this was a logical name, ']' or '>' must be present */
7939         /* if not a logical name, then assume a device and hope. */
7940         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7941
7942         /* if log name and trailing '.' then rooted - treat as device */
7943         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7944
7945         /* Fix me, if not a logical name, a device lookup should be
7946          * done to see if the device is file structured.  If the device
7947          * is not file structured, the 6 zeros should not be put on.
7948          *
7949          * As it is, perl is occasionally looking for dev:[000000]tty.
7950          * which looks a little strange.
7951          *
7952          * Not that easy to detect as "/dev" may be file structured with
7953          * special device files.
7954          */
7955
7956         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
7957             (&nextslash[1] == unixend)) {
7958           /* No real directory present */
7959           add_6zero = 1;
7960         }
7961       }
7962
7963       /* Put the device delimiter on */
7964       *vmsptr++ = ':';
7965       vmslen++;
7966       unixptr = nextslash;
7967       unixptr++;
7968
7969       /* Start directory if needed */
7970       if (!islnm || add_6zero) {
7971         *vmsptr++ = '[';
7972         vmslen++;
7973         dir_start = 1;
7974       }
7975
7976       /* add fake 000000] if needed */
7977       if (add_6zero) {
7978         *vmsptr++ = '0';
7979         *vmsptr++ = '0';
7980         *vmsptr++ = '0';
7981         *vmsptr++ = '0';
7982         *vmsptr++ = '0';
7983         *vmsptr++ = '0';
7984         *vmsptr++ = ']';
7985         vmslen += 7;
7986         dir_start = 0;
7987       }
7988
7989     } /* non-POSIX translation */
7990     PerlMem_free(esa);
7991   } /* End of relative/absolute path handling */
7992
7993   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7994   int dash_flag;
7995   int in_cnt;
7996   int out_cnt;
7997
7998     dash_flag = 0;
7999
8000     if (dir_start != 0) {
8001
8002       /* First characters in a directory are handled special */
8003       while ((*unixptr == '/') ||
8004              ((*unixptr == '.') &&
8005               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8006                 (&unixptr[1]==unixend)))) {
8007       int loop_flag;
8008
8009         loop_flag = 0;
8010
8011         /* Skip redundant / in specification */
8012         while ((*unixptr == '/') && (dir_start != 0)) {
8013           loop_flag = 1;
8014           unixptr++;
8015           if (unixptr == lastslash)
8016             break;
8017         }
8018         if (unixptr == lastslash)
8019           break;
8020
8021         /* Skip redundant ./ characters */
8022         while ((*unixptr == '.') &&
8023                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8024           loop_flag = 1;
8025           unixptr++;
8026           if (unixptr == lastslash)
8027             break;
8028           if (*unixptr == '/')
8029             unixptr++;
8030         }
8031         if (unixptr == lastslash)
8032           break;
8033
8034         /* Skip redundant ../ characters */
8035         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8036              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8037           /* Set the backing up flag */
8038           loop_flag = 1;
8039           dir_dot = 0;
8040           dash_flag = 1;
8041           *vmsptr++ = '-';
8042           vmslen++;
8043           unixptr++; /* first . */
8044           unixptr++; /* second . */
8045           if (unixptr == lastslash)
8046             break;
8047           if (*unixptr == '/') /* The slash */
8048             unixptr++;
8049         }
8050         if (unixptr == lastslash)
8051           break;
8052
8053         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8054         /* Not needed when VMS is pretending to be UNIX. */
8055
8056         /* Is this loop stuck because of too many dots? */
8057         if (loop_flag == 0) {
8058           /* Exit the loop and pass the rest through */
8059           break;
8060         }
8061       }
8062
8063       /* Are we done with directories yet? */
8064       if (unixptr >= lastslash) {
8065
8066         /* Watch out for trailing dots */
8067         if (dir_dot != 0) {
8068             vmslen --;
8069             vmsptr--;
8070         }
8071         *vmsptr++ = ']';
8072         vmslen++;
8073         dash_flag = 0;
8074         dir_start = 0;
8075         if (*unixptr == '/')
8076           unixptr++;
8077       }
8078       else {
8079         /* Have we stopped backing up? */
8080         if (dash_flag) {
8081           *vmsptr++ = '.';
8082           vmslen++;
8083           dash_flag = 0;
8084           /* dir_start continues to be = 1 */
8085         }
8086         if (*unixptr == '-') {
8087           *vmsptr++ = '^';
8088           *vmsptr++ = *unixptr++;
8089           vmslen += 2;
8090           dir_start = 0;
8091
8092           /* Now are we done with directories yet? */
8093           if (unixptr >= lastslash) {
8094
8095             /* Watch out for trailing dots */
8096             if (dir_dot != 0) {
8097               vmslen --;
8098               vmsptr--;
8099             }
8100
8101             *vmsptr++ = ']';
8102             vmslen++;
8103             dash_flag = 0;
8104             dir_start = 0;
8105           }
8106         }
8107       }
8108     }
8109
8110     /* All done? */
8111     if (unixptr >= unixend)
8112       break;
8113
8114     /* Normal characters - More EFS work probably needed */
8115     dir_start = 0;
8116     dir_dot = 0;
8117
8118     switch(*unixptr) {
8119     case '/':
8120         /* remove multiple / */
8121         while (unixptr[1] == '/') {
8122            unixptr++;
8123         }
8124         if (unixptr == lastslash) {
8125           /* Watch out for trailing dots */
8126           if (dir_dot != 0) {
8127             vmslen --;
8128             vmsptr--;
8129           }
8130           *vmsptr++ = ']';
8131         }
8132         else {
8133           dir_start = 1;
8134           *vmsptr++ = '.';
8135           dir_dot = 1;
8136
8137           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8138           /* Not needed when VMS is pretending to be UNIX. */
8139
8140         }
8141         dash_flag = 0;
8142         if (unixptr != unixend)
8143           unixptr++;
8144         vmslen++;
8145         break;
8146     case '.':
8147         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8148             (&unixptr[1] == unixend)) {
8149           *vmsptr++ = '^';
8150           *vmsptr++ = '.';
8151           vmslen += 2;
8152           unixptr++;
8153
8154           /* trailing dot ==> '^..' on VMS */
8155           if (unixptr == unixend) {
8156             *vmsptr++ = '.';
8157             vmslen++;
8158             unixptr++;
8159           }
8160           break;
8161         }
8162
8163         *vmsptr++ = *unixptr++;
8164         vmslen ++;
8165         break;
8166     case '"':
8167         if (quoted && (&unixptr[1] == unixend)) {
8168             unixptr++;
8169             break;
8170         }
8171         in_cnt = copy_expand_unix_filename_escape
8172                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8173         vmsptr += out_cnt;
8174         unixptr += in_cnt;
8175         break;
8176     case '~':
8177     case ';':
8178     case '\\':
8179     case '?':
8180     case ' ':
8181     default:
8182         in_cnt = copy_expand_unix_filename_escape
8183                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8184         vmsptr += out_cnt;
8185         unixptr += in_cnt;
8186         break;
8187     }
8188   }
8189
8190   /* Make sure directory is closed */
8191   if (unixptr == lastslash) {
8192     char *vmsptr2;
8193     vmsptr2 = vmsptr - 1;
8194
8195     if (*vmsptr2 != ']') {
8196       *vmsptr2--;
8197
8198       /* directories do not end in a dot bracket */
8199       if (*vmsptr2 == '.') {
8200         vmsptr2--;
8201
8202         /* ^. is allowed */
8203         if (*vmsptr2 != '^') {
8204           vmsptr--; /* back up over the dot */
8205         }
8206       }
8207       *vmsptr++ = ']';
8208     }
8209   }
8210   else {
8211     char *vmsptr2;
8212     /* Add a trailing dot if a file with no extension */
8213     vmsptr2 = vmsptr - 1;
8214     if ((vmslen > 1) &&
8215         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8216         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8217         *vmsptr++ = '.';
8218         vmslen++;
8219     }
8220   }
8221
8222   *vmsptr = '\0';
8223   return SS$_NORMAL;
8224 }
8225 #endif
8226
8227  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8228 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8229 {
8230 char * result;
8231 int utf8_flag;
8232
8233    /* If a UTF8 flag is being passed, honor it */
8234    utf8_flag = 0;
8235    if (utf8_fl != NULL) {
8236      utf8_flag = *utf8_fl;
8237     *utf8_fl = 0;
8238    }
8239
8240    if (utf8_flag) {
8241      /* If there is a possibility of UTF8, then if any UTF8 characters
8242         are present, then they must be converted to VTF-7
8243       */
8244      result = strcpy(rslt, path); /* FIX-ME */
8245    }
8246    else
8247      result = strcpy(rslt, path);
8248
8249    return result;
8250 }
8251
8252 /* A convenience macro for copying dots in filenames and escaping
8253  * them when they haven't already been escaped, with guards to
8254  * avoid checking before the start of the buffer or advancing
8255  * beyond the end of it (allowing room for the NUL terminator).
8256  */
8257 #define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
8258     if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8259           || ((vmsefsdot) == (vmsefsbuf))) \
8260          && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
8261        ) { \
8262         *((vmsefsdot)++) = '^'; \
8263     } \
8264     if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8265         *((vmsefsdot)++) = '.'; \
8266 } STMT_END
8267
8268 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8269 static char *int_tovmsspec
8270    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8271   char *dirend;
8272   char *lastdot;
8273   char *cp1;
8274   const char *cp2;
8275   unsigned long int infront = 0, hasdir = 1;
8276   int rslt_len;
8277   int no_type_seen;
8278   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8279   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8280
8281   if (vms_debug_fileify) {
8282       if (path == NULL)
8283           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8284       else
8285           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8286   }
8287
8288   if (path == NULL) {
8289       /* If we fail, we should be setting errno */
8290       set_errno(EINVAL);
8291       set_vaxc_errno(SS$_BADPARAM);
8292       return NULL;
8293   }
8294   rslt_len = VMS_MAXRSS-1;
8295
8296   /* '.' and '..' are "[]" and "[-]" for a quick check */
8297   if (path[0] == '.') {
8298     if (path[1] == '\0') {
8299       strcpy(rslt,"[]");
8300       if (utf8_flag != NULL)
8301         *utf8_flag = 0;
8302       return rslt;
8303     }
8304     else {
8305       if (path[1] == '.' && path[2] == '\0') {
8306         strcpy(rslt,"[-]");
8307         if (utf8_flag != NULL)
8308            *utf8_flag = 0;
8309         return rslt;
8310       }
8311     }
8312   }
8313
8314    /* Posix specifications are now a native VMS format */
8315   /*--------------------------------------------------*/
8316 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8317   if (decc_posix_compliant_pathnames) {
8318     if (strncmp(path,"\"^UP^",5) == 0) {
8319       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8320       return rslt;
8321     }
8322   }
8323 #endif
8324
8325   /* This is really the only way to see if this is already in VMS format */
8326   sts = vms_split_path
8327        (path,
8328         &v_spec,
8329         &v_len,
8330         &r_spec,
8331         &r_len,
8332         &d_spec,
8333         &d_len,
8334         &n_spec,
8335         &n_len,
8336         &e_spec,
8337         &e_len,
8338         &vs_spec,
8339         &vs_len);
8340   if (sts == 0) {
8341     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8342        replacement, because the above parse just took care of most of
8343        what is needed to do vmspath when the specification is already
8344        in VMS format.
8345
8346        And if it is not already, it is easier to do the conversion as
8347        part of this routine than to call this routine and then work on
8348        the result.
8349      */
8350
8351     /* If VMS punctuation was found, it is already VMS format */
8352     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8353       if (utf8_flag != NULL)
8354         *utf8_flag = 0;
8355       my_strlcpy(rslt, path, VMS_MAXRSS);
8356       if (vms_debug_fileify) {
8357           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8358       }
8359       return rslt;
8360     }
8361     /* Now, what to do with trailing "." cases where there is no
8362        extension?  If this is a UNIX specification, and EFS characters
8363        are enabled, then the trailing "." should be converted to a "^.".
8364        But if this was already a VMS specification, then it should be
8365        left alone.
8366
8367        So in the case of ambiguity, leave the specification alone.
8368      */
8369
8370
8371     /* If there is a possibility of UTF8, then if any UTF8 characters
8372         are present, then they must be converted to VTF-7
8373      */
8374     if (utf8_flag != NULL)
8375       *utf8_flag = 0;
8376     my_strlcpy(rslt, path, VMS_MAXRSS);
8377     if (vms_debug_fileify) {
8378         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8379     }
8380     return rslt;
8381   }
8382
8383   dirend = strrchr(path,'/');
8384
8385   if (dirend == NULL) {
8386      /* If we get here with no Unix directory delimiters, then this is an
8387       * ambiguous file specification, such as a Unix glob specification, a
8388       * shell or make macro, or a filespec that would be valid except for
8389       * unescaped extended characters.  The safest thing if it's a macro
8390       * is to pass it through as-is.
8391       */
8392       if (strstr(path, "$(")) {
8393           my_strlcpy(rslt, path, VMS_MAXRSS);
8394           if (vms_debug_fileify) {
8395               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8396           }
8397           return rslt;
8398       }
8399       hasdir = 0;
8400   }
8401   else if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8402     if (!*(dirend+2)) dirend +=2;
8403     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8404     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8405   }
8406
8407   cp1 = rslt;
8408   cp2 = path;
8409   lastdot = strrchr(cp2,'.');
8410   if (*cp2 == '/') {
8411     char *trndev;
8412     int islnm, rooted;
8413     STRLEN trnend;
8414
8415     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8416     if (!*(cp2+1)) {
8417       if (decc_disable_posix_root) {
8418         strcpy(rslt,"sys$disk:[000000]");
8419       }
8420       else {
8421         strcpy(rslt,"sys$posix_root:[000000]");
8422       }
8423       if (utf8_flag != NULL)
8424         *utf8_flag = 0;
8425       if (vms_debug_fileify) {
8426           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8427       }
8428       return rslt;
8429     }
8430     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8431     *cp1 = '\0';
8432     trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8433     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8434     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8435
8436      /* DECC special handling */
8437     if (!islnm) {
8438       if (strcmp(rslt,"bin") == 0) {
8439         strcpy(rslt,"sys$system");
8440         cp1 = rslt + 10;
8441         *cp1 = 0;
8442         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8443       }
8444       else if (strcmp(rslt,"tmp") == 0) {
8445         strcpy(rslt,"sys$scratch");
8446         cp1 = rslt + 11;
8447         *cp1 = 0;
8448         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8449       }
8450       else if (!decc_disable_posix_root) {
8451         strcpy(rslt, "sys$posix_root");
8452         cp1 = rslt + 14;
8453         *cp1 = 0;
8454         cp2 = path;
8455         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8456         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8457       }
8458       else if (strcmp(rslt,"dev") == 0) {
8459         if (strncmp(cp2,"/null", 5) == 0) {
8460           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8461             strcpy(rslt,"NLA0");
8462             cp1 = rslt + 4;
8463             *cp1 = 0;
8464             cp2 = cp2 + 5;
8465             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8466           }
8467         }
8468       }
8469     }
8470
8471     trnend = islnm ? strlen(trndev) - 1 : 0;
8472     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8473     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8474     /* If the first element of the path is a logical name, determine
8475      * whether it has to be translated so we can add more directories. */
8476     if (!islnm || rooted) {
8477       *(cp1++) = ':';
8478       *(cp1++) = '[';
8479       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8480       else cp2++;
8481     }
8482     else {
8483       if (cp2 != dirend) {
8484         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8485         cp1 = rslt + trnend;
8486         if (*cp2 != 0) {
8487           *(cp1++) = '.';
8488           cp2++;
8489         }
8490       }
8491       else {
8492         if (decc_disable_posix_root) {
8493           *(cp1++) = ':';
8494           hasdir = 0;
8495         }
8496       }
8497     }
8498     PerlMem_free(trndev);
8499   }
8500   else if (hasdir) {
8501     *(cp1++) = '[';
8502     if (*cp2 == '.') {
8503       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8504         cp2 += 2;         /* skip over "./" - it's redundant */
8505         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8506       }
8507       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8508         *(cp1++) = '-';                                 /* "../" --> "-" */
8509         cp2 += 3;
8510       }
8511       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8512                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8513         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8514         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8515         cp2 += 4;
8516       }
8517       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8518         /* Escape the extra dots in EFS file specifications */
8519         *(cp1++) = '^';
8520       }
8521       if (cp2 > dirend) cp2 = dirend;
8522     }
8523     else *(cp1++) = '.';
8524   }
8525   else {
8526     *(cp1++) = *cp2;
8527   }
8528   for (; cp2 < dirend; cp2++) {
8529     if (*cp2 == '/') {
8530       if (*(cp2-1) == '/') continue;
8531       if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
8532       infront = 0;
8533     }
8534     else if (!infront && *cp2 == '.') {
8535       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8536       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8537       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8538         if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
8539         else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
8540         else {
8541           *(cp1++) = '-';
8542         }
8543         cp2 += 2;
8544         if (cp2 == dirend) break;
8545       }
8546       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8547                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8548         if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8549         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8550         if (!*(cp2+3)) {
8551           *(cp1++) = '.';  /* Simulate trailing '/' */
8552           cp2 += 2;  /* for loop will incr this to == dirend */
8553         }
8554         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8555       }
8556       else {
8557         if (decc_efs_charset == 0) {
8558           if (cp1 > rslt && *(cp1-1) == '^')
8559             cp1--;         /* remove the escape, if any */
8560           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8561         }
8562         else {
8563           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8564         }
8565       }
8566     }
8567     else {
8568       if (!infront && cp1 > rslt && *(cp1-1) == '-')  *(cp1++) = '.';
8569       if (*cp2 == '.') {
8570         if (decc_efs_charset == 0) {
8571           if (cp1 > rslt && *(cp1-1) == '^')
8572             cp1--;         /* remove the escape, if any */
8573           *(cp1++) = '_';
8574         }
8575         else {
8576           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8577         }
8578       }
8579       else                  *(cp1++) =  *cp2;
8580       infront = 1;
8581     }
8582   }
8583   if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8584   if (hasdir) *(cp1++) = ']';
8585   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8586   /* fixme for ODS5 */
8587   no_type_seen = 0;
8588   if (cp2 > lastdot)
8589     no_type_seen = 1;
8590   while (*cp2) {
8591     switch(*cp2) {
8592     case '?':
8593         if (decc_efs_charset == 0)
8594           *(cp1++) = '%';
8595         else
8596           *(cp1++) = '?';
8597         cp2++;
8598     case ' ':
8599         if (cp2 > path && *(cp2-1) != '^') /* not previously escaped */
8600             *(cp1)++ = '^';
8601         *(cp1)++ = '_';
8602         cp2++;
8603         break;
8604     case '.':
8605         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8606             decc_readdir_dropdotnotype) {
8607           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8608           cp2++;
8609
8610           /* trailing dot ==> '^..' on VMS */
8611           if (*cp2 == '\0') {
8612             *(cp1++) = '.';
8613             no_type_seen = 0;
8614           }
8615         }
8616         else {
8617           *(cp1++) = *(cp2++);
8618           no_type_seen = 0;
8619         }
8620         break;
8621     case '$':
8622          /* This could be a macro to be passed through */
8623         *(cp1++) = *(cp2++);
8624         if (*cp2 == '(') {
8625         const char * save_cp2;
8626         char * save_cp1;
8627         int is_macro;
8628
8629             /* paranoid check */
8630             save_cp2 = cp2;
8631             save_cp1 = cp1;
8632             is_macro = 0;
8633
8634             /* Test through */
8635             *(cp1++) = *(cp2++);
8636             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8637                 *(cp1++) = *(cp2++);
8638                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8639                     *(cp1++) = *(cp2++);
8640                 }
8641                 if (*cp2 == ')') {
8642                     *(cp1++) = *(cp2++);
8643                     is_macro = 1;
8644                 }
8645             }
8646             if (is_macro == 0) {
8647                 /* Not really a macro - never mind */
8648                 cp2 = save_cp2;
8649                 cp1 = save_cp1;
8650             }
8651         }
8652         break;
8653     case '\"':
8654     case '~':
8655     case '`':
8656     case '!':
8657     case '#':
8658     case '%':
8659     case '^':
8660         /* Don't escape again if following character is
8661          * already something we escape.
8662          */
8663         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8664             *(cp1++) = *(cp2++);
8665             break;
8666         }
8667         /* But otherwise fall through and escape it. */
8668     case '&':
8669     case '(':
8670     case ')':
8671     case '=':
8672     case '+':
8673     case '\'':
8674     case '@':
8675     case '[':
8676     case ']':
8677     case '{':
8678     case '}':
8679     case ':':
8680     case '\\':
8681     case '|':
8682     case '<':
8683     case '>':
8684         if (cp2 > path && *(cp2-1) != '^') /* not previously escaped */
8685             *(cp1++) = '^';
8686         *(cp1++) = *(cp2++);
8687         break;
8688     case ';':
8689         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8690          * which is wrong.  UNIX notation should be ".dir." unless
8691          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8692          * changing this behavior could break more things at this time.
8693          * efs character set effectively does not allow "." to be a version
8694          * delimiter as a further complication about changing this.
8695          */
8696         if (decc_filename_unix_report != 0) {
8697           *(cp1++) = '^';
8698         }
8699         *(cp1++) = *(cp2++);
8700         break;
8701     default:
8702         *(cp1++) = *(cp2++);
8703     }
8704   }
8705   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8706   char *lcp1;
8707     lcp1 = cp1;
8708     lcp1--;
8709      /* Fix me for "^]", but that requires making sure that you do
8710       * not back up past the start of the filename
8711       */
8712     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8713       *cp1++ = '.';
8714   }
8715   *cp1 = '\0';
8716
8717   if (utf8_flag != NULL)
8718     *utf8_flag = 0;
8719   if (vms_debug_fileify) {
8720       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8721   }
8722   return rslt;
8723
8724 }  /* end of int_tovmsspec() */
8725
8726
8727 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8728 static char *mp_do_tovmsspec
8729    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8730   static char __tovmsspec_retbuf[VMS_MAXRSS];
8731     char * vmsspec, *ret_spec, *ret_buf;
8732
8733     vmsspec = NULL;
8734     ret_buf = buf;
8735     if (ret_buf == NULL) {
8736         if (ts) {
8737             Newx(vmsspec, VMS_MAXRSS, char);
8738             if (vmsspec == NULL)
8739                 _ckvmssts(SS$_INSFMEM);
8740             ret_buf = vmsspec;
8741         } else {
8742             ret_buf = __tovmsspec_retbuf;
8743         }
8744     }
8745
8746     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8747
8748     if (ret_spec == NULL) {
8749        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8750        if (vmsspec)
8751            Safefree(vmsspec);
8752     }
8753
8754     return ret_spec;
8755
8756 }  /* end of mp_do_tovmsspec() */
8757 /*}}}*/
8758 /* External entry points */
8759 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8760   { return do_tovmsspec(path,buf,0,NULL); }
8761 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8762   { return do_tovmsspec(path,buf,1,NULL); }
8763 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8764   { return do_tovmsspec(path,buf,0,utf8_fl); }
8765 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8766   { return do_tovmsspec(path,buf,1,utf8_fl); }
8767
8768 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8769 /* Internal routine for use with out an explicit context present */
8770 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
8771
8772     char * ret_spec, *pathified;
8773
8774     if (path == NULL)
8775         return NULL;
8776
8777     pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8778     if (pathified == NULL)
8779         _ckvmssts_noperl(SS$_INSFMEM);
8780
8781     ret_spec = int_pathify_dirspec(path, pathified);
8782
8783     if (ret_spec == NULL) {
8784         PerlMem_free(pathified);
8785         return NULL;
8786     }
8787
8788     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8789
8790     PerlMem_free(pathified);
8791     return ret_spec;
8792
8793 }
8794
8795 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8796 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8797   static char __tovmspath_retbuf[VMS_MAXRSS];
8798   int vmslen;
8799   char *pathified, *vmsified, *cp;
8800
8801   if (path == NULL) return NULL;
8802   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8803   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8804   if (int_pathify_dirspec(path, pathified) == NULL) {
8805     PerlMem_free(pathified);
8806     return NULL;
8807   }
8808
8809   vmsified = NULL;
8810   if (buf == NULL)
8811      Newx(vmsified, VMS_MAXRSS, char);
8812   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8813     PerlMem_free(pathified);
8814     if (vmsified) Safefree(vmsified);
8815     return NULL;
8816   }
8817   PerlMem_free(pathified);
8818   if (buf) {
8819     return buf;
8820   }
8821   else if (ts) {
8822     vmslen = strlen(vmsified);
8823     Newx(cp,vmslen+1,char);
8824     memcpy(cp,vmsified,vmslen);
8825     cp[vmslen] = '\0';
8826     Safefree(vmsified);
8827     return cp;
8828   }
8829   else {
8830     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8831     Safefree(vmsified);
8832     return __tovmspath_retbuf;
8833   }
8834
8835 }  /* end of do_tovmspath() */
8836 /*}}}*/
8837 /* External entry points */
8838 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8839   { return do_tovmspath(path,buf,0, NULL); }
8840 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8841   { return do_tovmspath(path,buf,1, NULL); }
8842 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8843   { return do_tovmspath(path,buf,0,utf8_fl); }
8844 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8845   { return do_tovmspath(path,buf,1,utf8_fl); }
8846
8847
8848 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8849 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8850   static char __tounixpath_retbuf[VMS_MAXRSS];
8851   int unixlen;
8852   char *pathified, *unixified, *cp;
8853
8854   if (path == NULL) return NULL;
8855   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8856   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8857   if (int_pathify_dirspec(path, pathified) == NULL) {
8858     PerlMem_free(pathified);
8859     return NULL;
8860   }
8861
8862   unixified = NULL;
8863   if (buf == NULL) {
8864       Newx(unixified, VMS_MAXRSS, char);
8865   }
8866   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8867     PerlMem_free(pathified);
8868     if (unixified) Safefree(unixified);
8869     return NULL;
8870   }
8871   PerlMem_free(pathified);
8872   if (buf) {
8873     return buf;
8874   }
8875   else if (ts) {
8876     unixlen = strlen(unixified);
8877     Newx(cp,unixlen+1,char);
8878     memcpy(cp,unixified,unixlen);
8879     cp[unixlen] = '\0';
8880     Safefree(unixified);
8881     return cp;
8882   }
8883   else {
8884     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
8885     Safefree(unixified);
8886     return __tounixpath_retbuf;
8887   }
8888
8889 }  /* end of do_tounixpath() */
8890 /*}}}*/
8891 /* External entry points */
8892 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8893   { return do_tounixpath(path,buf,0,NULL); }
8894 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8895   { return do_tounixpath(path,buf,1,NULL); }
8896 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8897   { return do_tounixpath(path,buf,0,utf8_fl); }
8898 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8899   { return do_tounixpath(path,buf,1,utf8_fl); }
8900
8901 /*
8902  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8903  *
8904  *****************************************************************************
8905  *                                                                           *
8906  *  Copyright (C) 1989-1994, 2007 by                                         *
8907  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8908  *                                                                           *
8909  *  Permission is hereby granted for the reproduction of this software       *
8910  *  on condition that this copyright notice is included in source            *
8911  *  distributions of the software.  The code may be modified and             *
8912  *  distributed under the same terms as Perl itself.                         *
8913  *                                                                           *
8914  *  27-Aug-1994 Modified for inclusion in perl5                              *
8915  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8916  *****************************************************************************
8917  */
8918
8919 /*
8920  * getredirection() is intended to aid in porting C programs
8921  * to VMS (Vax-11 C).  The native VMS environment does not support
8922  * '>' and '<' I/O redirection, or command line wild card expansion,
8923  * or a command line pipe mechanism using the '|' AND background
8924  * command execution '&'.  All of these capabilities are provided to any
8925  * C program which calls this procedure as the first thing in the
8926  * main program.
8927  * The piping mechanism will probably work with almost any 'filter' type
8928  * of program.  With suitable modification, it may useful for other
8929  * portability problems as well.
8930  *
8931  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8932  */
8933 struct list_item
8934     {
8935     struct list_item *next;
8936     char *value;
8937     };
8938
8939 static void add_item(struct list_item **head,
8940                      struct list_item **tail,
8941                      char *value,
8942                      int *count);
8943
8944 static void mp_expand_wild_cards(pTHX_ char *item,
8945                                 struct list_item **head,
8946                                 struct list_item **tail,
8947                                 int *count);
8948
8949 static int background_process(pTHX_ int argc, char **argv);
8950
8951 static void pipe_and_fork(pTHX_ char **cmargv);
8952
8953 /*{{{ void getredirection(int *ac, char ***av)*/
8954 static void
8955 mp_getredirection(pTHX_ int *ac, char ***av)
8956 /*
8957  * Process vms redirection arg's.  Exit if any error is seen.
8958  * If getredirection() processes an argument, it is erased
8959  * from the vector.  getredirection() returns a new argc and argv value.
8960  * In the event that a background command is requested (by a trailing "&"),
8961  * this routine creates a background subprocess, and simply exits the program.
8962  *
8963  * Warning: do not try to simplify the code for vms.  The code
8964  * presupposes that getredirection() is called before any data is
8965  * read from stdin or written to stdout.
8966  *
8967  * Normal usage is as follows:
8968  *
8969  *      main(argc, argv)
8970  *      int             argc;
8971  *      char            *argv[];
8972  *      {
8973  *              getredirection(&argc, &argv);
8974  *      }
8975  */
8976 {
8977     int                 argc = *ac;     /* Argument Count         */
8978     char                **argv = *av;   /* Argument Vector        */
8979     char                *ap;            /* Argument pointer       */
8980     int                 j;              /* argv[] index           */
8981     int                 item_count = 0; /* Count of Items in List */
8982     struct list_item    *list_head = 0; /* First Item in List       */
8983     struct list_item    *list_tail;     /* Last Item in List        */
8984     char                *in = NULL;     /* Input File Name          */
8985     char                *out = NULL;    /* Output File Name         */
8986     char                *outmode = "w"; /* Mode to Open Output File */
8987     char                *err = NULL;    /* Error File Name          */
8988     char                *errmode = "w"; /* Mode to Open Error File  */
8989     int                 cmargc = 0;     /* Piped Command Arg Count  */
8990     char                **cmargv = NULL;/* Piped Command Arg Vector */
8991
8992     /*
8993      * First handle the case where the last thing on the line ends with
8994      * a '&'.  This indicates the desire for the command to be run in a
8995      * subprocess, so we satisfy that desire.
8996      */
8997     ap = argv[argc-1];
8998     if (0 == strcmp("&", ap))
8999        exit(background_process(aTHX_ --argc, argv));
9000     if (*ap && '&' == ap[strlen(ap)-1])
9001         {
9002         ap[strlen(ap)-1] = '\0';
9003        exit(background_process(aTHX_ argc, argv));
9004         }
9005     /*
9006      * Now we handle the general redirection cases that involve '>', '>>',
9007      * '<', and pipes '|'.
9008      */
9009     for (j = 0; j < argc; ++j)
9010         {
9011         if (0 == strcmp("<", argv[j]))
9012             {
9013             if (j+1 >= argc)
9014                 {
9015                 fprintf(stderr,"No input file after < on command line");
9016                 exit(LIB$_WRONUMARG);
9017                 }
9018             in = argv[++j];
9019             continue;
9020             }
9021         if ('<' == *(ap = argv[j]))
9022             {
9023             in = 1 + ap;
9024             continue;
9025             }
9026         if (0 == strcmp(">", ap))
9027             {
9028             if (j+1 >= argc)
9029                 {
9030                 fprintf(stderr,"No output file after > on command line");
9031                 exit(LIB$_WRONUMARG);
9032                 }
9033             out = argv[++j];
9034             continue;
9035             }
9036         if ('>' == *ap)
9037             {
9038             if ('>' == ap[1])
9039                 {
9040                 outmode = "a";
9041                 if ('\0' == ap[2])
9042                     out = argv[++j];
9043                 else
9044                     out = 2 + ap;
9045                 }
9046             else
9047                 out = 1 + ap;
9048             if (j >= argc)
9049                 {
9050                 fprintf(stderr,"No output file after > or >> on command line");
9051                 exit(LIB$_WRONUMARG);
9052                 }
9053             continue;
9054             }
9055         if (('2' == *ap) && ('>' == ap[1]))
9056             {
9057             if ('>' == ap[2])
9058                 {
9059                 errmode = "a";
9060                 if ('\0' == ap[3])
9061                     err = argv[++j];
9062                 else
9063                     err = 3 + ap;
9064                 }
9065             else
9066                 if ('\0' == ap[2])
9067                     err = argv[++j];
9068                 else
9069                     err = 2 + ap;
9070             if (j >= argc)
9071                 {
9072                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9073                 exit(LIB$_WRONUMARG);
9074                 }
9075             continue;
9076             }
9077         if (0 == strcmp("|", argv[j]))
9078             {
9079             if (j+1 >= argc)
9080                 {
9081                 fprintf(stderr,"No command into which to pipe on command line");
9082                 exit(LIB$_WRONUMARG);
9083                 }
9084             cmargc = argc-(j+1);
9085             cmargv = &argv[j+1];
9086             argc = j;
9087             continue;
9088             }
9089         if ('|' == *(ap = argv[j]))
9090             {
9091             ++argv[j];
9092             cmargc = argc-j;
9093             cmargv = &argv[j];
9094             argc = j;
9095             continue;
9096             }
9097         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9098         }
9099     /*
9100      * Allocate and fill in the new argument vector, Some Unix's terminate
9101      * the list with an extra null pointer.
9102      */
9103     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9104     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9105     *av = argv;
9106     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9107         argv[j] = list_head->value;
9108     *ac = item_count;
9109     if (cmargv != NULL)
9110         {
9111         if (out != NULL)
9112             {
9113             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9114             exit(LIB$_INVARGORD);
9115             }
9116         pipe_and_fork(aTHX_ cmargv);
9117         }
9118
9119     /* Check for input from a pipe (mailbox) */
9120
9121     if (in == NULL && 1 == isapipe(0))
9122         {
9123         char mbxname[L_tmpnam];
9124         long int bufsize;
9125         long int dvi_item = DVI$_DEVBUFSIZ;
9126         $DESCRIPTOR(mbxnam, "");
9127         $DESCRIPTOR(mbxdevnam, "");
9128
9129         /* Input from a pipe, reopen it in binary mode to disable       */
9130         /* carriage control processing.                                 */
9131
9132         fgetname(stdin, mbxname, 1);
9133         mbxnam.dsc$a_pointer = mbxname;
9134         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9135         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9136         mbxdevnam.dsc$a_pointer = mbxname;
9137         mbxdevnam.dsc$w_length = sizeof(mbxname);
9138         dvi_item = DVI$_DEVNAM;
9139         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9140         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9141         set_errno(0);
9142         set_vaxc_errno(1);
9143         freopen(mbxname, "rb", stdin);
9144         if (errno != 0)
9145             {
9146             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9147             exit(vaxc$errno);
9148             }
9149         }
9150     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9151         {
9152         fprintf(stderr,"Can't open input file %s as stdin",in);
9153         exit(vaxc$errno);
9154         }
9155     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9156         {
9157         fprintf(stderr,"Can't open output file %s as stdout",out);
9158         exit(vaxc$errno);
9159         }
9160         if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
9161
9162     if (err != NULL) {
9163         if (strcmp(err,"&1") == 0) {
9164             dup2(fileno(stdout), fileno(stderr));
9165             vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
9166         } else {
9167         FILE *tmperr;
9168         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9169             {
9170             fprintf(stderr,"Can't open error file %s as stderr",err);
9171             exit(vaxc$errno);
9172             }
9173             fclose(tmperr);
9174            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9175                 {
9176                 exit(vaxc$errno);
9177                 }
9178             vmssetuserlnm("SYS$ERROR", err);
9179         }
9180         }
9181 #ifdef ARGPROC_DEBUG
9182     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9183     for (j = 0; j < *ac;  ++j)
9184         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9185 #endif
9186    /* Clear errors we may have hit expanding wildcards, so they don't
9187       show up in Perl's $! later */
9188    set_errno(0); set_vaxc_errno(1);
9189 }  /* end of getredirection() */
9190 /*}}}*/
9191
9192 static void add_item(struct list_item **head,
9193                      struct list_item **tail,
9194                      char *value,
9195                      int *count)
9196 {
9197     if (*head == 0)
9198         {
9199         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9200         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9201         *tail = *head;
9202         }
9203     else {
9204         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9205         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9206         *tail = (*tail)->next;
9207         }
9208     (*tail)->value = value;
9209     ++(*count);
9210 }
9211
9212 static void mp_expand_wild_cards(pTHX_ char *item,
9213                               struct list_item **head,
9214                               struct list_item **tail,
9215                               int *count)
9216 {
9217 int expcount = 0;
9218 unsigned long int context = 0;
9219 int isunix = 0;
9220 int item_len = 0;
9221 char *had_version;
9222 char *had_device;
9223 int had_directory;
9224 char *devdir,*cp;
9225 char *vmsspec;
9226 $DESCRIPTOR(filespec, "");
9227 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9228 $DESCRIPTOR(resultspec, "");
9229 unsigned long int lff_flags = 0;
9230 int sts;
9231 int rms_sts;
9232
9233 #ifdef VMS_LONGNAME_SUPPORT
9234     lff_flags = LIB$M_FIL_LONG_NAMES;
9235 #endif
9236
9237     for (cp = item; *cp; cp++) {
9238         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9239         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9240     }
9241     if (!*cp || isspace(*cp))
9242         {
9243         add_item(head, tail, item, count);
9244         return;
9245         }
9246     else
9247         {
9248      /* "double quoted" wild card expressions pass as is */
9249      /* From DCL that means using e.g.:                  */
9250      /* perl program """perl.*"""                        */
9251      item_len = strlen(item);
9252      if ( '"' == *item && '"' == item[item_len-1] )
9253        {
9254        item++;
9255        item[item_len-2] = '\0';
9256        add_item(head, tail, item, count);
9257        return;
9258        }
9259      }
9260     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9261     resultspec.dsc$b_class = DSC$K_CLASS_D;
9262     resultspec.dsc$a_pointer = NULL;
9263     vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9264     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9265     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9266       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9267     if (!isunix || !filespec.dsc$a_pointer)
9268       filespec.dsc$a_pointer = item;
9269     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9270     /*
9271      * Only return version specs, if the caller specified a version
9272      */
9273     had_version = strchr(item, ';');
9274     /*
9275      * Only return device and directory specs, if the caller specified either.
9276      */
9277     had_device = strchr(item, ':');
9278     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9279
9280     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9281                                  (&filespec, &resultspec, &context,
9282                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9283         {
9284         char *string;
9285         char *c;
9286
9287         string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9288         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9289         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9290         if (NULL == had_version)
9291             *(strrchr(string, ';')) = '\0';
9292         if ((!had_directory) && (had_device == NULL))
9293             {
9294             if (NULL == (devdir = strrchr(string, ']')))
9295                 devdir = strrchr(string, '>');
9296             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9297             }
9298         /*
9299          * Be consistent with what the C RTL has already done to the rest of
9300          * the argv items and lowercase all of these names.
9301          */
9302         if (!decc_efs_case_preserve) {
9303             for (c = string; *c; ++c)
9304             if (isupper(*c))
9305                 *c = tolower(*c);
9306         }
9307         if (isunix) trim_unixpath(string,item,1);
9308         add_item(head, tail, string, count);
9309         ++expcount;
9310     }
9311     PerlMem_free(vmsspec);
9312     if (sts != RMS$_NMF)
9313         {
9314         set_vaxc_errno(sts);
9315         switch (sts)
9316             {
9317             case RMS$_FNF: case RMS$_DNF:
9318                 set_errno(ENOENT); break;
9319             case RMS$_DIR:
9320                 set_errno(ENOTDIR); break;
9321             case RMS$_DEV:
9322                 set_errno(ENODEV); break;
9323             case RMS$_FNM: case RMS$_SYN:
9324                 set_errno(EINVAL); break;
9325             case RMS$_PRV:
9326                 set_errno(EACCES); break;
9327             default:
9328                 _ckvmssts_noperl(sts);
9329             }
9330         }
9331     if (expcount == 0)
9332         add_item(head, tail, item, count);
9333     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9334     _ckvmssts_noperl(lib$find_file_end(&context));
9335 }
9336
9337 static int child_st[2];/* Event Flag set when child process completes   */
9338
9339 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9340
9341 static unsigned long int exit_handler(void)
9342 {
9343 short iosb[4];
9344
9345     if (0 == child_st[0])
9346         {
9347 #ifdef ARGPROC_DEBUG
9348         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9349 #endif
9350         fflush(stdout);     /* Have to flush pipe for binary data to    */
9351                             /* terminate properly -- <tp@mccall.com>    */
9352         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9353         sys$dassgn(child_chan);
9354         fclose(stdout);
9355         sys$synch(0, child_st);
9356         }
9357     return(1);
9358 }
9359
9360 static void sig_child(int chan)
9361 {
9362 #ifdef ARGPROC_DEBUG
9363     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9364 #endif
9365     if (child_st[0] == 0)
9366         child_st[0] = 1;
9367 }
9368
9369 static struct exit_control_block exit_block =
9370     {
9371     0,
9372     exit_handler,
9373     1,
9374     &exit_block.exit_status,
9375     0
9376     };
9377
9378 static void
9379 pipe_and_fork(pTHX_ char **cmargv)
9380 {
9381     PerlIO *fp;
9382     struct dsc$descriptor_s *vmscmd;
9383     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9384     int sts, j, l, ismcr, quote, tquote = 0;
9385
9386     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9387     vms_execfree(vmscmd);
9388
9389     j = l = 0;
9390     p = subcmd;
9391     q = cmargv[0];
9392     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9393               && toupper(*(q+2)) == 'R' && !*(q+3);
9394
9395     while (q && l < MAX_DCL_LINE_LENGTH) {
9396         if (!*q) {
9397             if (j > 0 && quote) {
9398                 *p++ = '"';
9399                 l++;
9400             }
9401             q = cmargv[++j];
9402             if (q) {
9403                 if (ismcr && j > 1) quote = 1;
9404                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9405                 *p++ = ' ';
9406                 l++;
9407                 if (quote || tquote) {
9408                     *p++ = '"';
9409                     l++;
9410                 }
9411             }
9412         } else {
9413             if ((quote||tquote) && *q == '"') {
9414                 *p++ = '"';
9415                 l++;
9416             }
9417             *p++ = *q++;
9418             l++;
9419         }
9420     }
9421     *p = '\0';
9422
9423     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9424     if (fp == NULL) {
9425         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9426     }
9427 }
9428
9429 static int background_process(pTHX_ int argc, char **argv)
9430 {
9431 char command[MAX_DCL_SYMBOL + 1] = "$";
9432 $DESCRIPTOR(value, "");
9433 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9434 static $DESCRIPTOR(null, "NLA0:");
9435 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9436 char pidstring[80];
9437 $DESCRIPTOR(pidstr, "");
9438 int pid;
9439 unsigned long int flags = 17, one = 1, retsts;
9440 int len;
9441
9442     len = my_strlcat(command, argv[0], sizeof(command));
9443     while (--argc && (len < MAX_DCL_SYMBOL))
9444         {
9445         my_strlcat(command, " \"", sizeof(command));
9446         my_strlcat(command, *(++argv), sizeof(command));
9447         len = my_strlcat(command, "\"", sizeof(command));
9448         }
9449     value.dsc$a_pointer = command;
9450     value.dsc$w_length = strlen(value.dsc$a_pointer);
9451     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9452     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9453     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9454         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9455     }
9456     else {
9457         _ckvmssts_noperl(retsts);
9458     }
9459 #ifdef ARGPROC_DEBUG
9460     PerlIO_printf(Perl_debug_log, "%s\n", command);
9461 #endif
9462     sprintf(pidstring, "%08X", pid);
9463     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9464     pidstr.dsc$a_pointer = pidstring;
9465     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9466     lib$set_symbol(&pidsymbol, &pidstr);
9467     return(SS$_NORMAL);
9468 }
9469 /*}}}*/
9470 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9471
9472
9473 /* OS-specific initialization at image activation (not thread startup) */
9474 /* Older VAXC header files lack these constants */
9475 #ifndef JPI$_RIGHTS_SIZE
9476 #  define JPI$_RIGHTS_SIZE 817
9477 #endif
9478 #ifndef KGB$M_SUBSYSTEM
9479 #  define KGB$M_SUBSYSTEM 0x8
9480 #endif
9481
9482 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9483
9484 /*{{{void vms_image_init(int *, char ***)*/
9485 void
9486 vms_image_init(int *argcp, char ***argvp)
9487 {
9488   int status;
9489   char eqv[LNM$C_NAMLENGTH+1] = "";
9490   unsigned int len, tabct = 8, tabidx = 0;
9491   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9492   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9493   unsigned short int dummy, rlen;
9494   struct dsc$descriptor_s **tabvec;
9495 #if defined(PERL_IMPLICIT_CONTEXT)
9496   pTHX = NULL;
9497 #endif
9498   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9499                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9500                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9501                                  {          0,                0,    0,      0} };
9502
9503 #ifdef KILL_BY_SIGPRC
9504     Perl_csighandler_init();
9505 #endif
9506
9507 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9508     /* This was moved from the pre-image init handler because on threaded */
9509     /* Perl it was always returning 0 for the default value. */
9510     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9511     if (status > 0) {
9512         int s;
9513         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9514         if (s > 0) {
9515             int initial;
9516             initial = decc$feature_get_value(s, 4);
9517             if (initial > 0) {
9518                 /* initial is: 0 if nothing has set the feature */
9519                 /*            -1 if initialized to default */
9520                 /*             1 if set by logical name */
9521                 /*             2 if set by decc$feature_set_value */
9522                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9523
9524                 /* If the value is not valid, force the feature off */
9525                 if (decc_disable_posix_root < 0) {
9526                     decc$feature_set_value(s, 1, 1);
9527                     decc_disable_posix_root = 1;
9528                 }
9529             }
9530             else {
9531                 /* Nothing has asked for it explicitly, so use our own default. */
9532                 decc_disable_posix_root = 1;
9533                 decc$feature_set_value(s, 1, 1);
9534             }
9535         }
9536     }
9537 #endif
9538
9539   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9540   _ckvmssts_noperl(iosb[0]);
9541   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9542     if (iprv[i]) {           /* Running image installed with privs? */
9543       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9544       will_taint = TRUE;
9545       break;
9546     }
9547   }
9548   /* Rights identifiers might trigger tainting as well. */
9549   if (!will_taint && (rlen || rsz)) {
9550     while (rlen < rsz) {
9551       /* We didn't get all the identifiers on the first pass.  Allocate a
9552        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9553        * were needed to hold all identifiers at time of last call; we'll
9554        * allocate that many unsigned long ints), and go back and get 'em.
9555        * If it gave us less than it wanted to despite ample buffer space,
9556        * something's broken.  Is your system missing a system identifier?
9557        */
9558       if (rsz <= jpilist[1].buflen) {
9559          /* Perl_croak accvios when used this early in startup. */
9560          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9561                          rsz, (unsigned long) jpilist[1].buflen,
9562                          "Check your rights database for corruption.\n");
9563          exit(SS$_ABORT);
9564       }
9565       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9566       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9567       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9568       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9569       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9570       _ckvmssts_noperl(iosb[0]);
9571     }
9572     mask = (unsigned long int *)jpilist[1].bufadr;
9573     /* Check attribute flags for each identifier (2nd longword); protected
9574      * subsystem identifiers trigger tainting.
9575      */
9576     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9577       if (mask[i] & KGB$M_SUBSYSTEM) {
9578         will_taint = TRUE;
9579         break;
9580       }
9581     }
9582     if (mask != rlst) PerlMem_free(mask);
9583   }
9584
9585   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9586    * logical, some versions of the CRTL will add a phanthom /000000/
9587    * directory.  This needs to be removed.
9588    */
9589   if (decc_filename_unix_report) {
9590   char * zeros;
9591   int ulen;
9592     ulen = strlen(argvp[0][0]);
9593     if (ulen > 7) {
9594       zeros = strstr(argvp[0][0], "/000000/");
9595       if (zeros != NULL) {
9596         int mlen;
9597         mlen = ulen - (zeros - argvp[0][0]) - 7;
9598         memmove(zeros, &zeros[7], mlen);
9599         ulen = ulen - 7;
9600         argvp[0][0][ulen] = '\0';
9601       }
9602     }
9603     /* It also may have a trailing dot that needs to be removed otherwise
9604      * it will be converted to VMS mode incorrectly.
9605      */
9606     ulen--;
9607     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9608       argvp[0][0][ulen] = '\0';
9609   }
9610
9611   /* We need to use this hack to tell Perl it should run with tainting,
9612    * since its tainting flag may be part of the PL_curinterp struct, which
9613    * hasn't been allocated when vms_image_init() is called.
9614    */
9615   if (will_taint) {
9616     char **newargv, **oldargv;
9617     oldargv = *argvp;
9618     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9619     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9620     newargv[0] = oldargv[0];
9621     newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9622     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9623     strcpy(newargv[1], "-T");
9624     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9625     (*argcp)++;
9626     newargv[*argcp] = NULL;
9627     /* We orphan the old argv, since we don't know where it's come from,
9628      * so we don't know how to free it.
9629      */
9630     *argvp = newargv;
9631   }
9632   else {  /* Did user explicitly request tainting? */
9633     int i;
9634     char *cp, **av = *argvp;
9635     for (i = 1; i < *argcp; i++) {
9636       if (*av[i] != '-') break;
9637       for (cp = av[i]+1; *cp; cp++) {
9638         if (*cp == 'T') { will_taint = 1; break; }
9639         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9640                   strchr("DFIiMmx",*cp)) break;
9641       }
9642       if (will_taint) break;
9643     }
9644   }
9645
9646   for (tabidx = 0;
9647        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9648        tabidx++) {
9649     if (!tabidx) {
9650       tabvec = (struct dsc$descriptor_s **)
9651             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9652       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9653     }
9654     else if (tabidx >= tabct) {
9655       tabct += 8;
9656       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9657       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9658     }
9659     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9660     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9661     tabvec[tabidx]->dsc$w_length  = 0;
9662     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9663     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9664     tabvec[tabidx]->dsc$a_pointer = NULL;
9665     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9666   }
9667   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9668
9669   getredirection(argcp,argvp);
9670 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9671   {
9672 # include <reentrancy.h>
9673   decc$set_reentrancy(C$C_MULTITHREAD);
9674   }
9675 #endif
9676   return;
9677 }
9678 /*}}}*/
9679
9680
9681 /* trim_unixpath()
9682  * Trim Unix-style prefix off filespec, so it looks like what a shell
9683  * glob expansion would return (i.e. from specified prefix on, not
9684  * full path).  Note that returned filespec is Unix-style, regardless
9685  * of whether input filespec was VMS-style or Unix-style.
9686  *
9687  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9688  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9689  * vector of options; at present, only bit 0 is used, and if set tells
9690  * trim unixpath to try the current default directory as a prefix when
9691  * presented with a possibly ambiguous ... wildcard.
9692  *
9693  * Returns !=0 on success, with trimmed filespec replacing contents of
9694  * fspec, and 0 on failure, with contents of fpsec unchanged.
9695  */
9696 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9697 int
9698 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9699 {
9700   char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9701   int tmplen, reslen = 0, dirs = 0;
9702
9703   if (!wildspec || !fspec) return 0;
9704
9705   unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9706   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9707   tplate = unixwild;
9708   if (strpbrk(wildspec,"]>:") != NULL) {
9709     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9710         PerlMem_free(unixwild);
9711         return 0;
9712     }
9713   }
9714   else {
9715     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9716   }
9717   unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9718   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9719   if (strpbrk(fspec,"]>:") != NULL) {
9720     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9721         PerlMem_free(unixwild);
9722         PerlMem_free(unixified);
9723         return 0;
9724     }
9725     else base = unixified;
9726     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9727      * check to see that final result fits into (isn't longer than) fspec */
9728     reslen = strlen(fspec);
9729   }
9730   else base = fspec;
9731
9732   /* No prefix or absolute path on wildcard, so nothing to remove */
9733   if (!*tplate || *tplate == '/') {
9734     PerlMem_free(unixwild);
9735     if (base == fspec) {
9736         PerlMem_free(unixified);
9737         return 1;
9738     }
9739     tmplen = strlen(unixified);
9740     if (tmplen > reslen) {
9741         PerlMem_free(unixified);
9742         return 0;  /* not enough space */
9743     }
9744     /* Copy unixified resultant, including trailing NUL */
9745     memmove(fspec,unixified,tmplen+1);
9746     PerlMem_free(unixified);
9747     return 1;
9748   }
9749
9750   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9751   if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9752     for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9753     for (cp1 = end ;cp1 >= base; cp1--)
9754       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9755         { cp1++; break; }
9756     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9757     PerlMem_free(unixified);
9758     PerlMem_free(unixwild);
9759     return 1;
9760   }
9761   else {
9762     char *tpl, *lcres;
9763     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9764     int ells = 1, totells, segdirs, match;
9765     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9766                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9767
9768     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9769     totells = ells;
9770     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9771     tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9772     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9773     if (ellipsis == tplate && opts & 1) {
9774       /* Template begins with an ellipsis.  Since we can't tell how many
9775        * directory names at the front of the resultant to keep for an
9776        * arbitrary starting point, we arbitrarily choose the current
9777        * default directory as a starting point.  If it's there as a prefix,
9778        * clip it off.  If not, fall through and act as if the leading
9779        * ellipsis weren't there (i.e. return shortest possible path that
9780        * could match template).
9781        */
9782       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9783           PerlMem_free(tpl);
9784           PerlMem_free(unixified);
9785           PerlMem_free(unixwild);
9786           return 0;
9787       }
9788       if (!decc_efs_case_preserve) {
9789         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9790           if (_tolower(*cp1) != _tolower(*cp2)) break;
9791       }
9792       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9793       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9794       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9795         memmove(fspec,cp2+1,end - cp2);
9796         PerlMem_free(tpl);
9797         PerlMem_free(unixified);
9798         PerlMem_free(unixwild);
9799         return 1;
9800       }
9801     }
9802     /* First off, back up over constant elements at end of path */
9803     if (dirs) {
9804       for (front = end ; front >= base; front--)
9805          if (*front == '/' && !dirs--) { front++; break; }
9806     }
9807     lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9808     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9809     for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9810          cp1++,cp2++) {
9811             if (!decc_efs_case_preserve) {
9812                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9813             }
9814             else {
9815                 *cp2 = *cp1;
9816             }
9817     }
9818     if (cp1 != '\0') {
9819         PerlMem_free(tpl);
9820         PerlMem_free(unixified);
9821         PerlMem_free(unixwild);
9822         PerlMem_free(lcres);
9823         return 0;  /* Path too long. */
9824     }
9825     lcend = cp2;
9826     *cp2 = '\0';  /* Pick up with memcpy later */
9827     lcfront = lcres + (front - base);
9828     /* Now skip over each ellipsis and try to match the path in front of it. */
9829     while (ells--) {
9830       for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9831         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9832             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9833       if (cp1 < tplate) break; /* template started with an ellipsis */
9834       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9835         ellipsis = cp1; continue;
9836       }
9837       wilddsc.dsc$a_pointer = tpl;
9838       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9839       nextell = cp1;
9840       for (segdirs = 0, cp2 = tpl;
9841            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9842            cp1++, cp2++) {
9843          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9844          else {
9845             if (!decc_efs_case_preserve) {
9846               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9847             }
9848             else {
9849               *cp2 = *cp1;  /* else preserve case for match */
9850             }
9851          }
9852          if (*cp2 == '/') segdirs++;
9853       }
9854       if (cp1 != ellipsis - 1) {
9855           PerlMem_free(tpl);
9856           PerlMem_free(unixified);
9857           PerlMem_free(unixwild);
9858           PerlMem_free(lcres);
9859           return 0; /* Path too long */
9860       }
9861       /* Back up at least as many dirs as in template before matching */
9862       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9863         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9864       for (match = 0; cp1 > lcres;) {
9865         resdsc.dsc$a_pointer = cp1;
9866         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9867           match++;
9868           if (match == 1) lcfront = cp1;
9869         }
9870         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9871       }
9872       if (!match) {
9873         PerlMem_free(tpl);
9874         PerlMem_free(unixified);
9875         PerlMem_free(unixwild);
9876         PerlMem_free(lcres);
9877         return 0;  /* Can't find prefix ??? */
9878       }
9879       if (match > 1 && opts & 1) {
9880         /* This ... wildcard could cover more than one set of dirs (i.e.
9881          * a set of similar dir names is repeated).  If the template
9882          * contains more than 1 ..., upstream elements could resolve the
9883          * ambiguity, but it's not worth a full backtracking setup here.
9884          * As a quick heuristic, clip off the current default directory
9885          * if it's present to find the trimmed spec, else use the
9886          * shortest string that this ... could cover.
9887          */
9888         char def[NAM$C_MAXRSS+1], *st;
9889
9890         if (getcwd(def, sizeof def,0) == NULL) {
9891             PerlMem_free(unixified);
9892             PerlMem_free(unixwild);
9893             PerlMem_free(lcres);
9894             PerlMem_free(tpl);
9895             return 0;
9896         }
9897         if (!decc_efs_case_preserve) {
9898           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9899             if (_tolower(*cp1) != _tolower(*cp2)) break;
9900         }
9901         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9902         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9903         if (*cp1 == '\0' && *cp2 == '/') {
9904           memmove(fspec,cp2+1,end - cp2);
9905           PerlMem_free(tpl);
9906           PerlMem_free(unixified);
9907           PerlMem_free(unixwild);
9908           PerlMem_free(lcres);
9909           return 1;
9910         }
9911         /* Nope -- stick with lcfront from above and keep going. */
9912       }
9913     }
9914     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9915     PerlMem_free(tpl);
9916     PerlMem_free(unixified);
9917     PerlMem_free(unixwild);
9918     PerlMem_free(lcres);
9919     return 1;
9920   }
9921
9922 }  /* end of trim_unixpath() */
9923 /*}}}*/
9924
9925
9926 /*
9927  *  VMS readdir() routines.
9928  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9929  *
9930  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9931  *  Minor modifications to original routines.
9932  */
9933
9934 /* readdir may have been redefined by reentr.h, so make sure we get
9935  * the local version for what we do here.
9936  */
9937 #ifdef readdir
9938 # undef readdir
9939 #endif
9940 #if !defined(PERL_IMPLICIT_CONTEXT)
9941 # define readdir Perl_readdir
9942 #else
9943 # define readdir(a) Perl_readdir(aTHX_ a)
9944 #endif
9945
9946     /* Number of elements in vms_versions array */
9947 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9948
9949 /*
9950  *  Open a directory, return a handle for later use.
9951  */
9952 /*{{{ DIR *opendir(char*name) */
9953 DIR *
9954 Perl_opendir(pTHX_ const char *name)
9955 {
9956     DIR *dd;
9957     char *dir;
9958     Stat_t sb;
9959
9960     Newx(dir, VMS_MAXRSS, char);
9961     if (int_tovmspath(name, dir, NULL) == NULL) {
9962       Safefree(dir);
9963       return NULL;
9964     }
9965     /* Check access before stat; otherwise stat does not
9966      * accurately report whether it's a directory.
9967      */
9968     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9969       /* cando_by_name has already set errno */
9970       Safefree(dir);
9971       return NULL;
9972     }
9973     if (flex_stat(dir,&sb) == -1) return NULL;
9974     if (!S_ISDIR(sb.st_mode)) {
9975       Safefree(dir);
9976       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9977       return NULL;
9978     }
9979     /* Get memory for the handle, and the pattern. */
9980     Newx(dd,1,DIR);
9981     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9982
9983     /* Fill in the fields; mainly playing with the descriptor. */
9984     sprintf(dd->pattern, "%s*.*",dir);
9985     Safefree(dir);
9986     dd->context = 0;
9987     dd->count = 0;
9988     dd->flags = 0;
9989     /* By saying we want the result of readdir() in unix format, we are really
9990      * saying we want all the escapes removed, translating characters that
9991      * must be escaped in a VMS-format name to their unescaped form, which is
9992      * presumably allowed in a Unix-format name.
9993      */
9994     dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
9995     dd->pat.dsc$a_pointer = dd->pattern;
9996     dd->pat.dsc$w_length = strlen(dd->pattern);
9997     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9998     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9999 #if defined(USE_ITHREADS)
10000     Newx(dd->mutex,1,perl_mutex);
10001     MUTEX_INIT( (perl_mutex *) dd->mutex );
10002 #else
10003     dd->mutex = NULL;
10004 #endif
10005
10006     return dd;
10007 }  /* end of opendir() */
10008 /*}}}*/
10009
10010 /*
10011  *  Set the flag to indicate we want versions or not.
10012  */
10013 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10014 void
10015 vmsreaddirversions(DIR *dd, int flag)
10016 {
10017     if (flag)
10018         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10019     else
10020         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10021 }
10022 /*}}}*/
10023
10024 /*
10025  *  Free up an opened directory.
10026  */
10027 /*{{{ void closedir(DIR *dd)*/
10028 void
10029 Perl_closedir(DIR *dd)
10030 {
10031     int sts;
10032
10033     sts = lib$find_file_end(&dd->context);
10034     Safefree(dd->pattern);
10035 #if defined(USE_ITHREADS)
10036     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10037     Safefree(dd->mutex);
10038 #endif
10039     Safefree(dd);
10040 }
10041 /*}}}*/
10042
10043 /*
10044  *  Collect all the version numbers for the current file.
10045  */
10046 static void
10047 collectversions(pTHX_ DIR *dd)
10048 {
10049     struct dsc$descriptor_s     pat;
10050     struct dsc$descriptor_s     res;
10051     struct dirent *e;
10052     char *p, *text, *buff;
10053     int i;
10054     unsigned long context, tmpsts;
10055
10056     /* Convenient shorthand. */
10057     e = &dd->entry;
10058
10059     /* Add the version wildcard, ignoring the "*.*" put on before */
10060     i = strlen(dd->pattern);
10061     Newx(text,i + e->d_namlen + 3,char);
10062     my_strlcpy(text, dd->pattern, i + 1);
10063     sprintf(&text[i - 3], "%s;*", e->d_name);
10064
10065     /* Set up the pattern descriptor. */
10066     pat.dsc$a_pointer = text;
10067     pat.dsc$w_length = i + e->d_namlen - 1;
10068     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10069     pat.dsc$b_class = DSC$K_CLASS_S;
10070
10071     /* Set up result descriptor. */
10072     Newx(buff, VMS_MAXRSS, char);
10073     res.dsc$a_pointer = buff;
10074     res.dsc$w_length = VMS_MAXRSS - 1;
10075     res.dsc$b_dtype = DSC$K_DTYPE_T;
10076     res.dsc$b_class = DSC$K_CLASS_S;
10077
10078     /* Read files, collecting versions. */
10079     for (context = 0, e->vms_verscount = 0;
10080          e->vms_verscount < VERSIZE(e);
10081          e->vms_verscount++) {
10082         unsigned long rsts;
10083         unsigned long flags = 0;
10084
10085 #ifdef VMS_LONGNAME_SUPPORT
10086         flags = LIB$M_FIL_LONG_NAMES;
10087 #endif
10088         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10089         if (tmpsts == RMS$_NMF || context == 0) break;
10090         _ckvmssts(tmpsts);
10091         buff[VMS_MAXRSS - 1] = '\0';
10092         if ((p = strchr(buff, ';')))
10093             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10094         else
10095             e->vms_versions[e->vms_verscount] = -1;
10096     }
10097
10098     _ckvmssts(lib$find_file_end(&context));
10099     Safefree(text);
10100     Safefree(buff);
10101
10102 }  /* end of collectversions() */
10103
10104 /*
10105  *  Read the next entry from the directory.
10106  */
10107 /*{{{ struct dirent *readdir(DIR *dd)*/
10108 struct dirent *
10109 Perl_readdir(pTHX_ DIR *dd)
10110 {
10111     struct dsc$descriptor_s     res;
10112     char *p, *buff;
10113     unsigned long int tmpsts;
10114     unsigned long rsts;
10115     unsigned long flags = 0;
10116     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10117     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10118
10119     /* Set up result descriptor, and get next file. */
10120     Newx(buff, VMS_MAXRSS, char);
10121     res.dsc$a_pointer = buff;
10122     res.dsc$w_length = VMS_MAXRSS - 1;
10123     res.dsc$b_dtype = DSC$K_DTYPE_T;
10124     res.dsc$b_class = DSC$K_CLASS_S;
10125
10126 #ifdef VMS_LONGNAME_SUPPORT
10127     flags = LIB$M_FIL_LONG_NAMES;
10128 #endif
10129
10130     tmpsts = lib$find_file
10131         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10132     if (dd->context == 0)
10133         tmpsts = RMS$_NMF;  /* None left. (should be set, but make sure) */
10134
10135     if (!(tmpsts & 1)) {
10136       switch (tmpsts) {
10137         case RMS$_NMF:
10138           break;  /* no more files considered success */
10139         case RMS$_PRV:
10140           SETERRNO(EACCES, tmpsts); break;
10141         case RMS$_DEV:
10142           SETERRNO(ENODEV, tmpsts); break;
10143         case RMS$_DIR:
10144           SETERRNO(ENOTDIR, tmpsts); break;
10145         case RMS$_FNF: case RMS$_DNF:
10146           SETERRNO(ENOENT, tmpsts); break;
10147         default:
10148           SETERRNO(EVMSERR, tmpsts);
10149       }
10150       Safefree(buff);
10151       return NULL;
10152     }
10153     dd->count++;
10154     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10155     buff[res.dsc$w_length] = '\0';
10156     p = buff + res.dsc$w_length;
10157     while (--p >= buff) if (!isspace(*p)) break;
10158     *p = '\0';
10159     if (!decc_efs_case_preserve) {
10160       for (p = buff; *p; p++) *p = _tolower(*p);
10161     }
10162
10163     /* Skip any directory component and just copy the name. */
10164     sts = vms_split_path
10165        (buff,
10166         &v_spec,
10167         &v_len,
10168         &r_spec,
10169         &r_len,
10170         &d_spec,
10171         &d_len,
10172         &n_spec,
10173         &n_len,
10174         &e_spec,
10175         &e_len,
10176         &vs_spec,
10177         &vs_len);
10178
10179     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10180
10181         /* In Unix report mode, remove the ".dir;1" from the name */
10182         /* if it is a real directory. */
10183         if (decc_filename_unix_report && decc_efs_charset) {
10184             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10185                 Stat_t statbuf;
10186                 int ret_sts;
10187
10188                 ret_sts = flex_lstat(buff, &statbuf);
10189                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10190                     e_len = 0;
10191                     e_spec[0] = 0;
10192                 }
10193             }
10194         }
10195
10196         /* Drop NULL extensions on UNIX file specification */
10197         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10198             e_len = 0;
10199             e_spec[0] = '\0';
10200         }
10201     }
10202
10203     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10204     dd->entry.d_name[n_len + e_len] = '\0';
10205     dd->entry.d_namlen = n_len + e_len;
10206
10207     /* Convert the filename to UNIX format if needed */
10208     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10209
10210         /* Translate the encoded characters. */
10211         /* Fixme: Unicode handling could result in embedded 0 characters */
10212         if (strchr(dd->entry.d_name, '^') != NULL) {
10213             char new_name[256];
10214             char * q;
10215             p = dd->entry.d_name;
10216             q = new_name;
10217             while (*p != 0) {
10218                 int inchars_read, outchars_added;
10219                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10220                 p += inchars_read;
10221                 q += outchars_added;
10222                 /* fix-me */
10223                 /* if outchars_added > 1, then this is a wide file specification */
10224                 /* Wide file specifications need to be passed in Perl */
10225                 /* counted strings apparently with a Unicode flag */
10226             }
10227             *q = 0;
10228             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10229         }
10230     }
10231
10232     dd->entry.vms_verscount = 0;
10233     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10234     Safefree(buff);
10235     return &dd->entry;
10236
10237 }  /* end of readdir() */
10238 /*}}}*/
10239
10240 /*
10241  *  Read the next entry from the directory -- thread-safe version.
10242  */
10243 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10244 int
10245 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10246 {
10247     int retval;
10248
10249     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10250
10251     entry = readdir(dd);
10252     *result = entry;
10253     retval = ( *result == NULL ? errno : 0 );
10254
10255     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10256
10257     return retval;
10258
10259 }  /* end of readdir_r() */
10260 /*}}}*/
10261
10262 /*
10263  *  Return something that can be used in a seekdir later.
10264  */
10265 /*{{{ long telldir(DIR *dd)*/
10266 long
10267 Perl_telldir(DIR *dd)
10268 {
10269     return dd->count;
10270 }
10271 /*}}}*/
10272
10273 /*
10274  *  Return to a spot where we used to be.  Brute force.
10275  */
10276 /*{{{ void seekdir(DIR *dd,long count)*/
10277 void
10278 Perl_seekdir(pTHX_ DIR *dd, long count)
10279 {
10280     int old_flags;
10281
10282     /* If we haven't done anything yet... */
10283     if (dd->count == 0)
10284         return;
10285
10286     /* Remember some state, and clear it. */
10287     old_flags = dd->flags;
10288     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10289     _ckvmssts(lib$find_file_end(&dd->context));
10290     dd->context = 0;
10291
10292     /* The increment is in readdir(). */
10293     for (dd->count = 0; dd->count < count; )
10294         readdir(dd);
10295
10296     dd->flags = old_flags;
10297
10298 }  /* end of seekdir() */
10299 /*}}}*/
10300
10301 /* VMS subprocess management
10302  *
10303  * my_vfork() - just a vfork(), after setting a flag to record that
10304  * the current script is trying a Unix-style fork/exec.
10305  *
10306  * vms_do_aexec() and vms_do_exec() are called in response to the
10307  * perl 'exec' function.  If this follows a vfork call, then they
10308  * call out the regular perl routines in doio.c which do an
10309  * execvp (for those who really want to try this under VMS).
10310  * Otherwise, they do exactly what the perl docs say exec should
10311  * do - terminate the current script and invoke a new command
10312  * (See below for notes on command syntax.)
10313  *
10314  * do_aspawn() and do_spawn() implement the VMS side of the perl
10315  * 'system' function.
10316  *
10317  * Note on command arguments to perl 'exec' and 'system': When handled
10318  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10319  * are concatenated to form a DCL command string.  If the first non-numeric
10320  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10321  * the command string is handed off to DCL directly.  Otherwise,
10322  * the first token of the command is taken as the filespec of an image
10323  * to run.  The filespec is expanded using a default type of '.EXE' and
10324  * the process defaults for device, directory, etc., and if found, the resultant
10325  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10326  * the command string as parameters.  This is perhaps a bit complicated,
10327  * but I hope it will form a happy medium between what VMS folks expect
10328  * from lib$spawn and what Unix folks expect from exec.
10329  */
10330
10331 static int vfork_called;
10332
10333 /*{{{int my_vfork(void)*/
10334 int
10335 my_vfork(void)
10336 {
10337   vfork_called++;
10338   return vfork();
10339 }
10340 /*}}}*/
10341
10342
10343 static void
10344 vms_execfree(struct dsc$descriptor_s *vmscmd)
10345 {
10346   if (vmscmd) {
10347       if (vmscmd->dsc$a_pointer) {
10348           PerlMem_free(vmscmd->dsc$a_pointer);
10349       }
10350       PerlMem_free(vmscmd);
10351   }
10352 }
10353
10354 static char *
10355 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10356 {
10357   char *junk, *tmps = NULL;
10358   size_t cmdlen = 0;
10359   size_t rlen;
10360   SV **idx;
10361   STRLEN n_a;
10362
10363   idx = mark;
10364   if (really) {
10365     tmps = SvPV(really,rlen);
10366     if (*tmps) {
10367       cmdlen += rlen + 1;
10368       idx++;
10369     }
10370   }
10371
10372   for (idx++; idx <= sp; idx++) {
10373     if (*idx) {
10374       junk = SvPVx(*idx,rlen);
10375       cmdlen += rlen ? rlen + 1 : 0;
10376     }
10377   }
10378   Newx(PL_Cmd, cmdlen+1, char);
10379
10380   if (tmps && *tmps) {
10381     my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10382     mark++;
10383   }
10384   else *PL_Cmd = '\0';
10385   while (++mark <= sp) {
10386     if (*mark) {
10387       char *s = SvPVx(*mark,n_a);
10388       if (!*s) continue;
10389       if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10390       my_strlcat(PL_Cmd, s, cmdlen+1);
10391     }
10392   }
10393   return PL_Cmd;
10394
10395 }  /* end of setup_argstr() */
10396
10397
10398 static unsigned long int
10399 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10400                    struct dsc$descriptor_s **pvmscmd)
10401 {
10402   char * vmsspec;
10403   char * resspec;
10404   char image_name[NAM$C_MAXRSS+1];
10405   char image_argv[NAM$C_MAXRSS+1];
10406   $DESCRIPTOR(defdsc,".EXE");
10407   $DESCRIPTOR(defdsc2,".");
10408   struct dsc$descriptor_s resdsc;
10409   struct dsc$descriptor_s *vmscmd;
10410   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10411   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10412   char *s, *rest, *cp, *wordbreak;
10413   char * cmd;
10414   int cmdlen;
10415   int isdcl;
10416
10417   vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10418   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10419
10420   /* vmsspec is a DCL command buffer, not just a filename */
10421   vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10422   if (vmsspec == NULL)
10423       _ckvmssts_noperl(SS$_INSFMEM);
10424
10425   resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10426   if (resspec == NULL)
10427       _ckvmssts_noperl(SS$_INSFMEM);
10428
10429   /* Make a copy for modification */
10430   cmdlen = strlen(incmd);
10431   cmd = (char *)PerlMem_malloc(cmdlen+1);
10432   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10433   my_strlcpy(cmd, incmd, cmdlen + 1);
10434   image_name[0] = 0;
10435   image_argv[0] = 0;
10436
10437   resdsc.dsc$a_pointer = resspec;
10438   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10439   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10440   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10441
10442   vmscmd->dsc$a_pointer = NULL;
10443   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10444   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10445   vmscmd->dsc$w_length = 0;
10446   if (pvmscmd) *pvmscmd = vmscmd;
10447
10448   if (suggest_quote) *suggest_quote = 0;
10449
10450   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10451     PerlMem_free(cmd);
10452     PerlMem_free(vmsspec);
10453     PerlMem_free(resspec);
10454     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10455   }
10456
10457   s = cmd;
10458
10459   while (*s && isspace(*s)) s++;
10460
10461   if (*s == '@' || *s == '$') {
10462     vmsspec[0] = *s;  rest = s + 1;
10463     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10464   }
10465   else { cp = vmsspec; rest = s; }
10466
10467   /* If the first word is quoted, then we need to unquote it and
10468    * escape spaces within it.  We'll expand into the resspec buffer,
10469    * then copy back into the cmd buffer, expanding the latter if
10470    * necessary.
10471    */
10472   if (*rest == '"') {
10473     char *cp2;
10474     char *r = rest;
10475     bool in_quote = 0;
10476     int clen = cmdlen;
10477     int soff = s - cmd;
10478
10479     for (cp2 = resspec;
10480          *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10481          rest++) {
10482
10483       if (*rest == ' ') {    /* Escape ' ' to '^_'. */
10484         *cp2 = '^';
10485         *(++cp2) = '_';
10486         cp2++;
10487         clen++;
10488       }
10489       else if (*rest == '"') {
10490         clen--;
10491         if (in_quote) {     /* Must be closing quote. */
10492           rest++;
10493           break;
10494         }
10495         in_quote = 1;
10496       }
10497       else {
10498         *cp2 = *rest;
10499         cp2++;
10500       }
10501     }
10502     *cp2 = '\0';
10503
10504     /* Expand the command buffer if necessary. */
10505     if (clen > cmdlen) {
10506       cmd = (char *)PerlMem_realloc(cmd, clen);
10507       if (cmd == NULL)
10508         _ckvmssts_noperl(SS$_INSFMEM);
10509       /* Where we are may have changed, so recompute offsets */
10510       r = cmd + (r - s - soff);
10511       rest = cmd + (rest - s - soff);
10512       s = cmd + soff;
10513     }
10514
10515     /* Shift the non-verb portion of the command (if any) up or
10516      * down as necessary.
10517      */
10518     if (*rest)
10519       memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10520
10521     /* Copy the unquoted and escaped command verb into place. */
10522     memcpy(r, resspec, cp2 - resspec);
10523     cmd[clen] = '\0';
10524     cmdlen = clen;
10525     rest = r;         /* Rewind for subsequent operations. */
10526   }
10527
10528   if (*rest == '.' || *rest == '/') {
10529     char *cp2;
10530     for (cp2 = resspec;
10531          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10532          rest++, cp2++) *cp2 = *rest;
10533     *cp2 = '\0';
10534     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10535       s = vmsspec;
10536
10537       /* When a UNIX spec with no file type is translated to VMS, */
10538       /* A trailing '.' is appended under ODS-5 rules.            */
10539       /* Here we do not want that trailing "." as it prevents     */
10540       /* Looking for a implied ".exe" type. */
10541       if (decc_efs_charset) {
10542           int i;
10543           i = strlen(vmsspec);
10544           if (vmsspec[i-1] == '.') {
10545               vmsspec[i-1] = '\0';
10546           }
10547       }
10548
10549       if (*rest) {
10550         for (cp2 = vmsspec + strlen(vmsspec);
10551              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10552              rest++, cp2++) *cp2 = *rest;
10553         *cp2 = '\0';
10554       }
10555     }
10556   }
10557   /* Intuit whether verb (first word of cmd) is a DCL command:
10558    *   - if first nonspace char is '@', it's a DCL indirection
10559    * otherwise
10560    *   - if verb contains a filespec separator, it's not a DCL command
10561    *   - if it doesn't, caller tells us whether to default to a DCL
10562    *     command, or to a local image unless told it's DCL (by leading '$')
10563    */
10564   if (*s == '@') {
10565       isdcl = 1;
10566       if (suggest_quote) *suggest_quote = 1;
10567   } else {
10568     char *filespec = strpbrk(s,":<[.;");
10569     rest = wordbreak = strpbrk(s," \"\t/");
10570     if (!wordbreak) wordbreak = s + strlen(s);
10571     if (*s == '$') check_img = 0;
10572     if (filespec && (filespec < wordbreak)) isdcl = 0;
10573     else isdcl = !check_img;
10574   }
10575
10576   if (!isdcl) {
10577     int rsts;
10578     imgdsc.dsc$a_pointer = s;
10579     imgdsc.dsc$w_length = wordbreak - s;
10580     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10581     if (!(retsts&1)) {
10582         _ckvmssts_noperl(lib$find_file_end(&cxt));
10583         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10584       if (!(retsts & 1) && *s == '$') {
10585         _ckvmssts_noperl(lib$find_file_end(&cxt));
10586         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10587         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10588         if (!(retsts&1)) {
10589           _ckvmssts_noperl(lib$find_file_end(&cxt));
10590           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10591         }
10592       }
10593     }
10594     _ckvmssts_noperl(lib$find_file_end(&cxt));
10595
10596     if (retsts & 1) {
10597       FILE *fp;
10598       s = resspec;
10599       while (*s && !isspace(*s)) s++;
10600       *s = '\0';
10601
10602       /* check that it's really not DCL with no file extension */
10603       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10604       if (fp) {
10605         char b[256] = {0,0,0,0};
10606         read(fileno(fp), b, 256);
10607         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10608         if (isdcl) {
10609           int shebang_len;
10610
10611           /* Check for script */
10612           shebang_len = 0;
10613           if ((b[0] == '#') && (b[1] == '!'))
10614              shebang_len = 2;
10615 #ifdef ALTERNATE_SHEBANG
10616           else {
10617             shebang_len = strlen(ALTERNATE_SHEBANG);
10618             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10619               char * perlstr;
10620                 perlstr = strstr("perl",b);
10621                 if (perlstr == NULL)
10622                   shebang_len = 0;
10623             }
10624             else
10625               shebang_len = 0;
10626           }
10627 #endif
10628
10629           if (shebang_len > 0) {
10630           int i;
10631           int j;
10632           char tmpspec[NAM$C_MAXRSS + 1];
10633
10634             i = shebang_len;
10635              /* Image is following after white space */
10636             /*--------------------------------------*/
10637             while (isprint(b[i]) && isspace(b[i]))
10638                 i++;
10639
10640             j = 0;
10641             while (isprint(b[i]) && !isspace(b[i])) {
10642                 tmpspec[j++] = b[i++];
10643                 if (j >= NAM$C_MAXRSS)
10644                    break;
10645             }
10646             tmpspec[j] = '\0';
10647
10648              /* There may be some default parameters to the image */
10649             /*---------------------------------------------------*/
10650             j = 0;
10651             while (isprint(b[i])) {
10652                 image_argv[j++] = b[i++];
10653                 if (j >= NAM$C_MAXRSS)
10654                    break;
10655             }
10656             while ((j > 0) && !isprint(image_argv[j-1]))
10657                 j--;
10658             image_argv[j] = 0;
10659
10660             /* It will need to be converted to VMS format and validated */
10661             if (tmpspec[0] != '\0') {
10662               char * iname;
10663
10664                /* Try to find the exact program requested to be run */
10665               /*---------------------------------------------------*/
10666               iname = int_rmsexpand
10667                  (tmpspec, image_name, ".exe",
10668                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10669               if (iname != NULL) {
10670                 if (cando_by_name_int
10671                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10672                   /* MCR prefix needed */
10673                   isdcl = 0;
10674                 }
10675                 else {
10676                    /* Try again with a null type */
10677                   /*----------------------------*/
10678                   iname = int_rmsexpand
10679                     (tmpspec, image_name, ".",
10680                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10681                   if (iname != NULL) {
10682                     if (cando_by_name_int
10683                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10684                       /* MCR prefix needed */
10685                       isdcl = 0;
10686                     }
10687                   }
10688                 }
10689
10690                  /* Did we find the image to run the script? */
10691                 /*------------------------------------------*/
10692                 if (isdcl) {
10693                   char *tchr;
10694
10695                    /* Assume DCL or foreign command exists */
10696                   /*--------------------------------------*/
10697                   tchr = strrchr(tmpspec, '/');
10698                   if (tchr != NULL) {
10699                     tchr++;
10700                   }
10701                   else {
10702                     tchr = tmpspec;
10703                   }
10704                   my_strlcpy(image_name, tchr, sizeof(image_name));
10705                 }
10706               }
10707             }
10708           }
10709         }
10710         fclose(fp);
10711       }
10712       if (check_img && isdcl) {
10713           PerlMem_free(cmd);
10714           PerlMem_free(resspec);
10715           PerlMem_free(vmsspec);
10716           return RMS$_FNF;
10717       }
10718
10719       if (cando_by_name(S_IXUSR,0,resspec)) {
10720         vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10721         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10722         if (!isdcl) {
10723             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10724             if (image_name[0] != 0) {
10725                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10726                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10727             }
10728         } else if (image_name[0] != 0) {
10729             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10730             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10731         } else {
10732             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10733         }
10734         if (suggest_quote) *suggest_quote = 1;
10735
10736         /* If there is an image name, use original command */
10737         if (image_name[0] == 0)
10738             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10739         else {
10740             rest = cmd;
10741             while (*rest && isspace(*rest)) rest++;
10742         }
10743
10744         if (image_argv[0] != 0) {
10745           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10746           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10747         }
10748         if (rest) {
10749            int rest_len;
10750            int vmscmd_len;
10751
10752            rest_len = strlen(rest);
10753            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10754            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10755               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10756            else
10757              retsts = CLI$_BUFOVF;
10758         }
10759         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10760         PerlMem_free(cmd);
10761         PerlMem_free(vmsspec);
10762         PerlMem_free(resspec);
10763         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10764       }
10765       else
10766         retsts = RMS$_PRV;
10767     }
10768   }
10769   /* It's either a DCL command or we couldn't find a suitable image */
10770   vmscmd->dsc$w_length = strlen(cmd);
10771
10772   vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10773   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10774
10775   PerlMem_free(cmd);
10776   PerlMem_free(resspec);
10777   PerlMem_free(vmsspec);
10778
10779   /* check if it's a symbol (for quoting purposes) */
10780   if (suggest_quote && !*suggest_quote) {
10781     int iss;
10782     char equiv[LNM$C_NAMLENGTH];
10783     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10784     eqvdsc.dsc$a_pointer = equiv;
10785
10786     iss = lib$get_symbol(vmscmd,&eqvdsc);
10787     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10788   }
10789   if (!(retsts & 1)) {
10790     /* just hand off status values likely to be due to user error */
10791     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10792         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10793        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10794     else { _ckvmssts_noperl(retsts); }
10795   }
10796
10797   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10798
10799 }  /* end of setup_cmddsc() */
10800
10801
10802 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10803 bool
10804 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10805 {
10806 bool exec_sts;
10807 char * cmd;
10808
10809   if (sp > mark) {
10810     if (vfork_called) {           /* this follows a vfork - act Unixish */
10811       vfork_called--;
10812       if (vfork_called < 0) {
10813         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10814         vfork_called = 0;
10815       }
10816       else return do_aexec(really,mark,sp);
10817     }
10818                                            /* no vfork - act VMSish */
10819     cmd = setup_argstr(aTHX_ really,mark,sp);
10820     exec_sts = vms_do_exec(cmd);
10821     Safefree(cmd);  /* Clean up from setup_argstr() */
10822     return exec_sts;
10823   }
10824
10825   return FALSE;
10826 }  /* end of vms_do_aexec() */
10827 /*}}}*/
10828
10829 /* {{{bool vms_do_exec(char *cmd) */
10830 bool
10831 Perl_vms_do_exec(pTHX_ const char *cmd)
10832 {
10833   struct dsc$descriptor_s *vmscmd;
10834
10835   if (vfork_called) {             /* this follows a vfork - act Unixish */
10836     vfork_called--;
10837     if (vfork_called < 0) {
10838       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10839       vfork_called = 0;
10840     }
10841     else return do_exec(cmd);
10842   }
10843
10844   {                               /* no vfork - act VMSish */
10845     unsigned long int retsts;
10846
10847     TAINT_ENV();
10848     TAINT_PROPER("exec");
10849     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10850       retsts = lib$do_command(vmscmd);
10851
10852     switch (retsts) {
10853       case RMS$_FNF: case RMS$_DNF:
10854         set_errno(ENOENT); break;
10855       case RMS$_DIR:
10856         set_errno(ENOTDIR); break;
10857       case RMS$_DEV:
10858         set_errno(ENODEV); break;
10859       case RMS$_PRV:
10860         set_errno(EACCES); break;
10861       case RMS$_SYN:
10862         set_errno(EINVAL); break;
10863       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10864         set_errno(E2BIG); break;
10865       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10866         _ckvmssts_noperl(retsts); /* fall through */
10867       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10868         set_errno(EVMSERR);
10869     }
10870     set_vaxc_errno(retsts);
10871     if (ckWARN(WARN_EXEC)) {
10872       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10873              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10874     }
10875     vms_execfree(vmscmd);
10876   }
10877
10878   return FALSE;
10879
10880 }  /* end of vms_do_exec() */
10881 /*}}}*/
10882
10883 int do_spawn2(pTHX_ const char *, int);
10884
10885 int
10886 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10887 {
10888 unsigned long int sts;
10889 char * cmd;
10890 int flags = 0;
10891
10892   if (sp > mark) {
10893
10894     /* We'll copy the (undocumented?) Win32 behavior and allow a
10895      * numeric first argument.  But the only value we'll support
10896      * through do_aspawn is a value of 1, which means spawn without
10897      * waiting for completion -- other values are ignored.
10898      */
10899     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10900         ++mark;
10901         flags = SvIVx(*mark);
10902     }
10903
10904     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10905         flags = CLI$M_NOWAIT;
10906     else
10907         flags = 0;
10908
10909     cmd = setup_argstr(aTHX_ really, mark, sp);
10910     sts = do_spawn2(aTHX_ cmd, flags);
10911     /* pp_sys will clean up cmd */
10912     return sts;
10913   }
10914   return SS$_ABORT;
10915 }  /* end of do_aspawn() */
10916 /*}}}*/
10917
10918
10919 /* {{{int do_spawn(char* cmd) */
10920 int
10921 Perl_do_spawn(pTHX_ char* cmd)
10922 {
10923     PERL_ARGS_ASSERT_DO_SPAWN;
10924
10925     return do_spawn2(aTHX_ cmd, 0);
10926 }
10927 /*}}}*/
10928
10929 /* {{{int do_spawn_nowait(char* cmd) */
10930 int
10931 Perl_do_spawn_nowait(pTHX_ char* cmd)
10932 {
10933     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10934
10935     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10936 }
10937 /*}}}*/
10938
10939 /* {{{int do_spawn2(char *cmd) */
10940 int
10941 do_spawn2(pTHX_ const char *cmd, int flags)
10942 {
10943   unsigned long int sts, substs;
10944
10945   /* The caller of this routine expects to Safefree(PL_Cmd) */
10946   Newx(PL_Cmd,10,char);
10947
10948   TAINT_ENV();
10949   TAINT_PROPER("spawn");
10950   if (!cmd || !*cmd) {
10951     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10952     if (!(sts & 1)) {
10953       switch (sts) {
10954         case RMS$_FNF:  case RMS$_DNF:
10955           set_errno(ENOENT); break;
10956         case RMS$_DIR:
10957           set_errno(ENOTDIR); break;
10958         case RMS$_DEV:
10959           set_errno(ENODEV); break;
10960         case RMS$_PRV:
10961           set_errno(EACCES); break;
10962         case RMS$_SYN:
10963           set_errno(EINVAL); break;
10964         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10965           set_errno(E2BIG); break;
10966         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10967           _ckvmssts_noperl(sts); /* fall through */
10968         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10969           set_errno(EVMSERR);
10970       }
10971       set_vaxc_errno(sts);
10972       if (ckWARN(WARN_EXEC)) {
10973         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10974                     Strerror(errno));
10975       }
10976     }
10977     sts = substs;
10978   }
10979   else {
10980     char mode[3];
10981     PerlIO * fp;
10982     if (flags & CLI$M_NOWAIT)
10983         strcpy(mode, "n");
10984     else
10985         strcpy(mode, "nW");
10986
10987     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10988     if (fp != NULL)
10989       my_pclose(fp);
10990     /* sts will be the pid in the nowait case */
10991   }
10992   return sts;
10993 }  /* end of do_spawn2() */
10994 /*}}}*/
10995
10996
10997 static unsigned int *sockflags, sockflagsize;
10998
10999 /*
11000  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11001  * routines found in some versions of the CRTL can't deal with sockets.
11002  * We don't shim the other file open routines since a socket isn't
11003  * likely to be opened by a name.
11004  */
11005 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11006 FILE *my_fdopen(int fd, const char *mode)
11007 {
11008   FILE *fp = fdopen(fd, mode);
11009
11010   if (fp) {
11011     unsigned int fdoff = fd / sizeof(unsigned int);
11012     Stat_t sbuf; /* native stat; we don't need flex_stat */
11013     if (!sockflagsize || fdoff > sockflagsize) {
11014       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11015       else           Newx  (sockflags,fdoff+2,unsigned int);
11016       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11017       sockflagsize = fdoff + 2;
11018     }
11019     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11020       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11021   }
11022   return fp;
11023
11024 }
11025 /*}}}*/
11026
11027
11028 /*
11029  * Clear the corresponding bit when the (possibly) socket stream is closed.
11030  * There still a small hole: we miss an implicit close which might occur
11031  * via freopen().  >> Todo
11032  */
11033 /*{{{ int my_fclose(FILE *fp)*/
11034 int my_fclose(FILE *fp) {
11035   if (fp) {
11036     unsigned int fd = fileno(fp);
11037     unsigned int fdoff = fd / sizeof(unsigned int);
11038
11039     if (sockflagsize && fdoff < sockflagsize)
11040       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11041   }
11042   return fclose(fp);
11043 }
11044 /*}}}*/
11045
11046
11047 /*
11048  * A simple fwrite replacement which outputs itmsz*nitm chars without
11049  * introducing record boundaries every itmsz chars.
11050  * We are using fputs, which depends on a terminating null.  We may
11051  * well be writing binary data, so we need to accommodate not only
11052  * data with nulls sprinkled in the middle but also data with no null
11053  * byte at the end.
11054  */
11055 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11056 int
11057 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11058 {
11059   char *cp, *end, *cpd;
11060   char *data;
11061   unsigned int fd = fileno(dest);
11062   unsigned int fdoff = fd / sizeof(unsigned int);
11063   int retval;
11064   int bufsize = itmsz * nitm + 1;
11065
11066   if (fdoff < sockflagsize &&
11067       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11068     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11069     return nitm;
11070   }
11071
11072   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11073   memcpy( data, src, itmsz*nitm );
11074   data[itmsz*nitm] = '\0';
11075
11076   end = data + itmsz * nitm;
11077   retval = (int) nitm; /* on success return # items written */
11078
11079   cpd = data;
11080   while (cpd <= end) {
11081     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11082     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11083     if (cp < end)
11084       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11085     cpd = cp + 1;
11086   }
11087
11088   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11089   return retval;
11090
11091 }  /* end of my_fwrite() */
11092 /*}}}*/
11093
11094 /*{{{ int my_flush(FILE *fp)*/
11095 int
11096 Perl_my_flush(pTHX_ FILE *fp)
11097 {
11098     int res;
11099     if ((res = fflush(fp)) == 0 && fp) {
11100 #ifdef VMS_DO_SOCKETS
11101         Stat_t s;
11102         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11103 #endif
11104             res = fsync(fileno(fp));
11105     }
11106 /*
11107  * If the flush succeeded but set end-of-file, we need to clear
11108  * the error because our caller may check ferror().  BTW, this
11109  * probably means we just flushed an empty file.
11110  */
11111     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11112
11113     return res;
11114 }
11115 /*}}}*/
11116
11117 /* fgetname() is not returning the correct file specifications when
11118  * decc_filename_unix_report mode is active.  So we have to have it
11119  * aways return filenames in VMS mode and convert it ourselves.
11120  */
11121
11122 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11123 char *
11124 Perl_my_fgetname(FILE *fp, char * buf) {
11125     char * retname;
11126     char * vms_name;
11127
11128     retname = fgetname(fp, buf, 1);
11129
11130     /* If we are in VMS mode, then we are done */
11131     if (!decc_filename_unix_report || (retname == NULL)) {
11132        return retname;
11133     }
11134
11135     /* Convert this to Unix format */
11136     vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11137     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11138     retname = int_tounixspec(vms_name, buf, NULL);
11139     PerlMem_free(vms_name);
11140
11141     return retname;
11142 }
11143 /*}}}*/
11144
11145 /*
11146  * Here are replacements for the following Unix routines in the VMS environment:
11147  *      getpwuid    Get information for a particular UIC or UID
11148  *      getpwnam    Get information for a named user
11149  *      getpwent    Get information for each user in the rights database
11150  *      setpwent    Reset search to the start of the rights database
11151  *      endpwent    Finish searching for users in the rights database
11152  *
11153  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11154  * (defined in pwd.h), which contains the following fields:-
11155  *      struct passwd {
11156  *              char        *pw_name;    Username (in lower case)
11157  *              char        *pw_passwd;  Hashed password
11158  *              unsigned int pw_uid;     UIC
11159  *              unsigned int pw_gid;     UIC group  number
11160  *              char        *pw_unixdir; Default device/directory (VMS-style)
11161  *              char        *pw_gecos;   Owner name
11162  *              char        *pw_dir;     Default device/directory (Unix-style)
11163  *              char        *pw_shell;   Default CLI name (eg. DCL)
11164  *      };
11165  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11166  *
11167  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11168  * not the UIC member number (eg. what's returned by getuid()),
11169  * getpwuid() can accept either as input (if uid is specified, the caller's
11170  * UIC group is used), though it won't recognise gid=0.
11171  *
11172  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11173  * information about other users in your group or in other groups, respectively.
11174  * If the required privilege is not available, then these routines fill only
11175  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11176  * string).
11177  *
11178  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11179  */
11180
11181 /* sizes of various UAF record fields */
11182 #define UAI$S_USERNAME 12
11183 #define UAI$S_IDENT    31
11184 #define UAI$S_OWNER    31
11185 #define UAI$S_DEFDEV   31
11186 #define UAI$S_DEFDIR   63
11187 #define UAI$S_DEFCLI   31
11188 #define UAI$S_PWD       8
11189
11190 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11191                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11192                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11193
11194 static char __empty[]= "";
11195 static struct passwd __passwd_empty=
11196     {(char *) __empty, (char *) __empty, 0, 0,
11197      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11198 static int contxt= 0;
11199 static struct passwd __pwdcache;
11200 static char __pw_namecache[UAI$S_IDENT+1];
11201
11202 /*
11203  * This routine does most of the work extracting the user information.
11204  */
11205 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11206 {
11207     static struct {
11208         unsigned char length;
11209         char pw_gecos[UAI$S_OWNER+1];
11210     } owner;
11211     static union uicdef uic;
11212     static struct {
11213         unsigned char length;
11214         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11215     } defdev;
11216     static struct {
11217         unsigned char length;
11218         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11219     } defdir;
11220     static struct {
11221         unsigned char length;
11222         char pw_shell[UAI$S_DEFCLI+1];
11223     } defcli;
11224     static char pw_passwd[UAI$S_PWD+1];
11225
11226     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11227     struct dsc$descriptor_s name_desc;
11228     unsigned long int sts;
11229
11230     static struct itmlst_3 itmlst[]= {
11231         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11232         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11233         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11234         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11235         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11236         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11237         {0,                0,           NULL,    NULL}};
11238
11239     name_desc.dsc$w_length=  strlen(name);
11240     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11241     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11242     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11243
11244 /*  Note that sys$getuai returns many fields as counted strings. */
11245     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11246     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11247       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11248     }
11249     else { _ckvmssts(sts); }
11250     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11251
11252     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11253     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11254     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11255     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11256     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11257     owner.pw_gecos[lowner]=            '\0';
11258     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11259     defcli.pw_shell[ldefcli]=          '\0';
11260     if (valid_uic(uic)) {
11261         pwd->pw_uid= uic.uic$l_uic;
11262         pwd->pw_gid= uic.uic$v_group;
11263     }
11264     else
11265       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11266     pwd->pw_passwd=  pw_passwd;
11267     pwd->pw_gecos=   owner.pw_gecos;
11268     pwd->pw_dir=     defdev.pw_dir;
11269     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11270     pwd->pw_shell=   defcli.pw_shell;
11271     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11272         int ldir;
11273         ldir= strlen(pwd->pw_unixdir) - 1;
11274         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11275     }
11276     else
11277         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11278     if (!decc_efs_case_preserve)
11279         __mystrtolower(pwd->pw_unixdir);
11280     return 1;
11281 }
11282
11283 /*
11284  * Get information for a named user.
11285 */
11286 /*{{{struct passwd *getpwnam(char *name)*/
11287 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11288 {
11289     struct dsc$descriptor_s name_desc;
11290     union uicdef uic;
11291     unsigned long int sts;
11292
11293     __pwdcache = __passwd_empty;
11294     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11295       /* We still may be able to determine pw_uid and pw_gid */
11296       name_desc.dsc$w_length=  strlen(name);
11297       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11298       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11299       name_desc.dsc$a_pointer= (char *) name;
11300       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11301         __pwdcache.pw_uid= uic.uic$l_uic;
11302         __pwdcache.pw_gid= uic.uic$v_group;
11303       }
11304       else {
11305         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11306           set_vaxc_errno(sts);
11307           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11308           return NULL;
11309         }
11310         else { _ckvmssts(sts); }
11311       }
11312     }
11313     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11314     __pwdcache.pw_name= __pw_namecache;
11315     return &__pwdcache;
11316 }  /* end of my_getpwnam() */
11317 /*}}}*/
11318
11319 /*
11320  * Get information for a particular UIC or UID.
11321  * Called by my_getpwent with uid=-1 to list all users.
11322 */
11323 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11324 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11325 {
11326     const $DESCRIPTOR(name_desc,__pw_namecache);
11327     unsigned short lname;
11328     union uicdef uic;
11329     unsigned long int status;
11330
11331     if (uid == (unsigned int) -1) {
11332       do {
11333         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11334         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11335           set_vaxc_errno(status);
11336           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11337           my_endpwent();
11338           return NULL;
11339         }
11340         else { _ckvmssts(status); }
11341       } while (!valid_uic (uic));
11342     }
11343     else {
11344       uic.uic$l_uic= uid;
11345       if (!uic.uic$v_group)
11346         uic.uic$v_group= PerlProc_getgid();
11347       if (valid_uic(uic))
11348         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11349       else status = SS$_IVIDENT;
11350       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11351           status == RMS$_PRV) {
11352         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11353         return NULL;
11354       }
11355       else { _ckvmssts(status); }
11356     }
11357     __pw_namecache[lname]= '\0';
11358     __mystrtolower(__pw_namecache);
11359
11360     __pwdcache = __passwd_empty;
11361     __pwdcache.pw_name = __pw_namecache;
11362
11363 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11364     The identifier's value is usually the UIC, but it doesn't have to be,
11365     so if we can, we let fillpasswd update this. */
11366     __pwdcache.pw_uid =  uic.uic$l_uic;
11367     __pwdcache.pw_gid =  uic.uic$v_group;
11368
11369     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11370     return &__pwdcache;
11371
11372 }  /* end of my_getpwuid() */
11373 /*}}}*/
11374
11375 /*
11376  * Get information for next user.
11377 */
11378 /*{{{struct passwd *my_getpwent()*/
11379 struct passwd *Perl_my_getpwent(pTHX)
11380 {
11381     return (my_getpwuid((unsigned int) -1));
11382 }
11383 /*}}}*/
11384
11385 /*
11386  * Finish searching rights database for users.
11387 */
11388 /*{{{void my_endpwent()*/
11389 void Perl_my_endpwent(pTHX)
11390 {
11391     if (contxt) {
11392       _ckvmssts(sys$finish_rdb(&contxt));
11393       contxt= 0;
11394     }
11395 }
11396 /*}}}*/
11397
11398 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11399  * my_utime(), and flex_stat(), all of which operate on UTC unless
11400  * VMSISH_TIMES is true.
11401  */
11402 /* method used to handle UTC conversions:
11403  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11404  */
11405 static int gmtime_emulation_type;
11406 /* number of secs to add to UTC POSIX-style time to get local time */
11407 static long int utc_offset_secs;
11408
11409 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11410  * in vmsish.h.  #undef them here so we can call the CRTL routines
11411  * directly.
11412  */
11413 #undef gmtime
11414 #undef localtime
11415 #undef time
11416
11417
11418 static time_t toutc_dst(time_t loc) {
11419   struct tm *rsltmp;
11420
11421   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11422   loc -= utc_offset_secs;
11423   if (rsltmp->tm_isdst) loc -= 3600;
11424   return loc;
11425 }
11426 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11427        ((gmtime_emulation_type || my_time(NULL)), \
11428        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11429        ((secs) - utc_offset_secs))))
11430
11431 static time_t toloc_dst(time_t utc) {
11432   struct tm *rsltmp;
11433
11434   utc += utc_offset_secs;
11435   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11436   if (rsltmp->tm_isdst) utc += 3600;
11437   return utc;
11438 }
11439 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11440        ((gmtime_emulation_type || my_time(NULL)), \
11441        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11442        ((secs) + utc_offset_secs))))
11443
11444 /* my_time(), my_localtime(), my_gmtime()
11445  * By default traffic in UTC time values, using CRTL gmtime() or
11446  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11447  * Note: We need to use these functions even when the CRTL has working
11448  * UTC support, since they also handle C<use vmsish qw(times);>
11449  *
11450  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11451  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11452  */
11453
11454 /*{{{time_t my_time(time_t *timep)*/
11455 time_t Perl_my_time(pTHX_ time_t *timep)
11456 {
11457   time_t when;
11458   struct tm *tm_p;
11459
11460   if (gmtime_emulation_type == 0) {
11461     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11462                               /* results of calls to gmtime() and localtime() */
11463                               /* for same &base */
11464
11465     gmtime_emulation_type++;
11466     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11467       char off[LNM$C_NAMLENGTH+1];;
11468
11469       gmtime_emulation_type++;
11470       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11471         gmtime_emulation_type++;
11472         utc_offset_secs = 0;
11473         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11474       }
11475       else { utc_offset_secs = atol(off); }
11476     }
11477     else { /* We've got a working gmtime() */
11478       struct tm gmt, local;
11479
11480       gmt = *tm_p;
11481       tm_p = localtime(&base);
11482       local = *tm_p;
11483       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11484       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11485       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11486       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11487     }
11488   }
11489
11490   when = time(NULL);
11491 # ifdef VMSISH_TIME
11492   if (VMSISH_TIME) when = _toloc(when);
11493 # endif
11494   if (timep != NULL) *timep = when;
11495   return when;
11496
11497 }  /* end of my_time() */
11498 /*}}}*/
11499
11500
11501 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11502 struct tm *
11503 Perl_my_gmtime(pTHX_ const time_t *timep)
11504 {
11505   time_t when;
11506   struct tm *rsltmp;
11507
11508   if (timep == NULL) {
11509     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11510     return NULL;
11511   }
11512   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11513
11514   when = *timep;
11515 # ifdef VMSISH_TIME
11516   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11517 #  endif
11518   return gmtime(&when);
11519 }  /* end of my_gmtime() */
11520 /*}}}*/
11521
11522
11523 /*{{{struct tm *my_localtime(const time_t *timep)*/
11524 struct tm *
11525 Perl_my_localtime(pTHX_ const time_t *timep)
11526 {
11527   time_t when;
11528
11529   if (timep == NULL) {
11530     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11531     return NULL;
11532   }
11533   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11534   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11535
11536   when = *timep;
11537 # ifdef VMSISH_TIME
11538   if (VMSISH_TIME) when = _toutc(when);
11539 # endif
11540   /* CRTL localtime() wants UTC as input, does tz correction itself */
11541   return localtime(&when);
11542 } /*  end of my_localtime() */
11543 /*}}}*/
11544
11545 /* Reset definitions for later calls */
11546 #define gmtime(t)    my_gmtime(t)
11547 #define localtime(t) my_localtime(t)
11548 #define time(t)      my_time(t)
11549
11550
11551 /* my_utime - update modification/access time of a file
11552  *
11553  * VMS 7.3 and later implementation
11554  * Only the UTC translation is home-grown. The rest is handled by the
11555  * CRTL utime(), which will take into account the relevant feature
11556  * logicals and ODS-5 volume characteristics for true access times.
11557  *
11558  * pre VMS 7.3 implementation:
11559  * The calling sequence is identical to POSIX utime(), but under
11560  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11561  * not maintain access times.  Restrictions differ from the POSIX
11562  * definition in that the time can be changed as long as the
11563  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11564  * no separate checks are made to insure that the caller is the
11565  * owner of the file or has special privs enabled.
11566  * Code here is based on Joe Meadows' FILE utility.
11567  *
11568  */
11569
11570 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11571  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11572  * in 100 ns intervals.
11573  */
11574 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11575
11576 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11577 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11578 {
11579 #if __CRTL_VER >= 70300000
11580   struct utimbuf utc_utimes, *utc_utimesp;
11581
11582   if (utimes != NULL) {
11583     utc_utimes.actime = utimes->actime;
11584     utc_utimes.modtime = utimes->modtime;
11585 # ifdef VMSISH_TIME
11586     /* If input was local; convert to UTC for sys svc */
11587     if (VMSISH_TIME) {
11588       utc_utimes.actime = _toutc(utimes->actime);
11589       utc_utimes.modtime = _toutc(utimes->modtime);
11590     }
11591 # endif
11592     utc_utimesp = &utc_utimes;
11593   }
11594   else {
11595     utc_utimesp = NULL;
11596   }
11597
11598   return utime(file, utc_utimesp);
11599
11600 #else /* __CRTL_VER < 70300000 */
11601
11602   int i;
11603   int sts;
11604   long int bintime[2], len = 2, lowbit, unixtime,
11605            secscale = 10000000; /* seconds --> 100 ns intervals */
11606   unsigned long int chan, iosb[2], retsts;
11607   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11608   struct FAB myfab = cc$rms_fab;
11609   struct NAM mynam = cc$rms_nam;
11610 #if defined (__DECC) && defined (__VAX)
11611   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11612    * at least through VMS V6.1, which causes a type-conversion warning.
11613    */
11614 #  pragma message save
11615 #  pragma message disable cvtdiftypes
11616 #endif
11617   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11618   struct fibdef myfib;
11619 #if defined (__DECC) && defined (__VAX)
11620   /* This should be right after the declaration of myatr, but due
11621    * to a bug in VAX DEC C, this takes effect a statement early.
11622    */
11623 #  pragma message restore
11624 #endif
11625   /* cast ok for read only parameter */
11626   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11627                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11628                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11629
11630   if (file == NULL || *file == '\0') {
11631     SETERRNO(ENOENT, LIB$_INVARG);
11632     return -1;
11633   }
11634
11635   /* Convert to VMS format ensuring that it will fit in 255 characters */
11636   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11637       SETERRNO(ENOENT, LIB$_INVARG);
11638       return -1;
11639   }
11640   if (utimes != NULL) {
11641     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11642      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11643      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11644      * as input, we force the sign bit to be clear by shifting unixtime right
11645      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11646      */
11647     lowbit = (utimes->modtime & 1) ? secscale : 0;
11648     unixtime = (long int) utimes->modtime;
11649 #   ifdef VMSISH_TIME
11650     /* If input was UTC; convert to local for sys svc */
11651     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11652 #   endif
11653     unixtime >>= 1;  secscale <<= 1;
11654     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11655     if (!(retsts & 1)) {
11656       SETERRNO(EVMSERR, retsts);
11657       return -1;
11658     }
11659     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11660     if (!(retsts & 1)) {
11661       SETERRNO(EVMSERR, retsts);
11662       return -1;
11663     }
11664   }
11665   else {
11666     /* Just get the current time in VMS format directly */
11667     retsts = sys$gettim(bintime);
11668     if (!(retsts & 1)) {
11669       SETERRNO(EVMSERR, retsts);
11670       return -1;
11671     }
11672   }
11673
11674   myfab.fab$l_fna = vmsspec;
11675   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11676   myfab.fab$l_nam = &mynam;
11677   mynam.nam$l_esa = esa;
11678   mynam.nam$b_ess = (unsigned char) sizeof esa;
11679   mynam.nam$l_rsa = rsa;
11680   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11681   if (decc_efs_case_preserve)
11682       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11683
11684   /* Look for the file to be affected, letting RMS parse the file
11685    * specification for us as well.  I have set errno using only
11686    * values documented in the utime() man page for VMS POSIX.
11687    */
11688   retsts = sys$parse(&myfab,0,0);
11689   if (!(retsts & 1)) {
11690     set_vaxc_errno(retsts);
11691     if      (retsts == RMS$_PRV) set_errno(EACCES);
11692     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11693     else                         set_errno(EVMSERR);
11694     return -1;
11695   }
11696   retsts = sys$search(&myfab,0,0);
11697   if (!(retsts & 1)) {
11698     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11699     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11700     set_vaxc_errno(retsts);
11701     if      (retsts == RMS$_PRV) set_errno(EACCES);
11702     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11703     else                         set_errno(EVMSERR);
11704     return -1;
11705   }
11706
11707   devdsc.dsc$w_length = mynam.nam$b_dev;
11708   /* cast ok for read only parameter */
11709   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11710
11711   retsts = sys$assign(&devdsc,&chan,0,0);
11712   if (!(retsts & 1)) {
11713     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11714     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11715     set_vaxc_errno(retsts);
11716     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11717     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11718     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11719     else                               set_errno(EVMSERR);
11720     return -1;
11721   }
11722
11723   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11724   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11725
11726   memset((void *) &myfib, 0, sizeof myfib);
11727 #if defined(__DECC) || defined(__DECCXX)
11728   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11729   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11730   /* This prevents the revision time of the file being reset to the current
11731    * time as a result of our IO$_MODIFY $QIO. */
11732   myfib.fib$l_acctl = FIB$M_NORECORD;
11733 #else
11734   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11735   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11736   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11737 #endif
11738   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11739   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11740   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11741   _ckvmssts(sys$dassgn(chan));
11742   if (retsts & 1) retsts = iosb[0];
11743   if (!(retsts & 1)) {
11744     set_vaxc_errno(retsts);
11745     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11746     else                      set_errno(EVMSERR);
11747     return -1;
11748   }
11749
11750   return 0;
11751
11752 #endif /* #if __CRTL_VER >= 70300000 */
11753
11754 }  /* end of my_utime() */
11755 /*}}}*/
11756
11757 /*
11758  * flex_stat, flex_lstat, flex_fstat
11759  * basic stat, but gets it right when asked to stat
11760  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11761  */
11762
11763 #ifndef _USE_STD_STAT
11764 /* encode_dev packs a VMS device name string into an integer to allow
11765  * simple comparisons. This can be used, for example, to check whether two
11766  * files are located on the same device, by comparing their encoded device
11767  * names. Even a string comparison would not do, because stat() reuses the
11768  * device name buffer for each call; so without encode_dev, it would be
11769  * necessary to save the buffer and use strcmp (this would mean a number of
11770  * changes to the standard Perl code, to say nothing of what a Perl script
11771  * would have to do.
11772  *
11773  * The device lock id, if it exists, should be unique (unless perhaps compared
11774  * with lock ids transferred from other nodes). We have a lock id if the disk is
11775  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11776  * device names. Thus we use the lock id in preference, and only if that isn't
11777  * available, do we try to pack the device name into an integer (flagged by
11778  * the sign bit (LOCKID_MASK) being set).
11779  *
11780  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11781  * name and its encoded form, but it seems very unlikely that we will find
11782  * two files on different disks that share the same encoded device names,
11783  * and even more remote that they will share the same file id (if the test
11784  * is to check for the same file).
11785  *
11786  * A better method might be to use sys$device_scan on the first call, and to
11787  * search for the device, returning an index into the cached array.
11788  * The number returned would be more intelligible.
11789  * This is probably not worth it, and anyway would take quite a bit longer
11790  * on the first call.
11791  */
11792 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11793 static mydev_t encode_dev (pTHX_ const char *dev)
11794 {
11795   int i;
11796   unsigned long int f;
11797   mydev_t enc;
11798   char c;
11799   const char *q;
11800
11801   if (!dev || !dev[0]) return 0;
11802
11803 #if LOCKID_MASK
11804   {
11805     struct dsc$descriptor_s dev_desc;
11806     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11807
11808     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11809        can try that first. */
11810     dev_desc.dsc$w_length =  strlen (dev);
11811     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11812     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11813     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11814     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11815     if (!$VMS_STATUS_SUCCESS(status)) {
11816       switch (status) {
11817         case SS$_NOSUCHDEV:
11818           SETERRNO(ENODEV, status);
11819           return 0;
11820         default:
11821           _ckvmssts(status);
11822       }
11823     }
11824     if (lockid) return (lockid & ~LOCKID_MASK);
11825   }
11826 #endif
11827
11828   /* Otherwise we try to encode the device name */
11829   enc = 0;
11830   f = 1;
11831   i = 0;
11832   for (q = dev + strlen(dev); q--; q >= dev) {
11833     if (*q == ':')
11834         break;
11835     if (isdigit (*q))
11836       c= (*q) - '0';
11837     else if (isalpha (toupper (*q)))
11838       c= toupper (*q) - 'A' + (char)10;
11839     else
11840       continue; /* Skip '$'s */
11841     i++;
11842     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11843     if (i>1) f *= 36;
11844     enc += f * (unsigned long int) c;
11845   }
11846   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11847
11848 }  /* end of encode_dev() */
11849 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11850         device_no = encode_dev(aTHX_ devname)
11851 #else
11852 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11853         device_no = new_dev_no
11854 #endif
11855
11856 static int
11857 is_null_device(const char *name)
11858 {
11859   if (decc_bug_devnull != 0) {
11860     if (strncmp("/dev/null", name, 9) == 0)
11861       return 1;
11862   }
11863     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11864        The underscore prefix, controller letter, and unit number are
11865        independently optional; for our purposes, the colon punctuation
11866        is not.  The colon can be trailed by optional directory and/or
11867        filename, but two consecutive colons indicates a nodename rather
11868        than a device.  [pr]  */
11869   if (*name == '_') ++name;
11870   if (tolower(*name++) != 'n') return 0;
11871   if (tolower(*name++) != 'l') return 0;
11872   if (tolower(*name) == 'a') ++name;
11873   if (*name == '0') ++name;
11874   return (*name++ == ':') && (*name != ':');
11875 }
11876
11877 static int
11878 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11879
11880 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11881
11882 static I32
11883 Perl_cando_by_name_int
11884    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11885 {
11886   char usrname[L_cuserid];
11887   struct dsc$descriptor_s usrdsc =
11888          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11889   char *vmsname = NULL, *fileified = NULL;
11890   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11891   unsigned short int retlen, trnlnm_iter_count;
11892   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11893   union prvdef curprv;
11894   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11895          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11896          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11897   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11898          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11899          {0,0,0,0}};
11900   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11901          {0,0,0,0}};
11902   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11903   Stat_t st;
11904   static int profile_context = -1;
11905
11906   if (!fname || !*fname) return FALSE;
11907
11908   /* Make sure we expand logical names, since sys$check_access doesn't */
11909   fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11910   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11911   if (!strpbrk(fname,"/]>:")) {
11912       my_strlcpy(fileified, fname, VMS_MAXRSS);
11913       trnlnm_iter_count = 0;
11914       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11915         trnlnm_iter_count++;
11916         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11917       }
11918       fname = fileified;
11919   }
11920
11921   vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11922   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11923   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11924     /* Don't know if already in VMS format, so make sure */
11925     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11926       PerlMem_free(fileified);
11927       PerlMem_free(vmsname);
11928       return FALSE;
11929     }
11930   }
11931   else {
11932     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11933   }
11934
11935   /* sys$check_access needs a file spec, not a directory spec.
11936    * flex_stat now will handle a null thread context during startup.
11937    */
11938
11939   retlen = namdsc.dsc$w_length = strlen(vmsname);
11940   if (vmsname[retlen-1] == ']'
11941       || vmsname[retlen-1] == '>'
11942       || vmsname[retlen-1] == ':'
11943       || (!flex_stat_int(vmsname, &st, 1) &&
11944           S_ISDIR(st.st_mode))) {
11945
11946       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11947         PerlMem_free(fileified);
11948         PerlMem_free(vmsname);
11949         return FALSE;
11950       }
11951       fname = fileified;
11952   }
11953   else {
11954       fname = vmsname;
11955   }
11956
11957   retlen = namdsc.dsc$w_length = strlen(fname);
11958   namdsc.dsc$a_pointer = (char *)fname;
11959
11960   switch (bit) {
11961     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11962       access = ARM$M_EXECUTE;
11963       flags = CHP$M_READ;
11964       break;
11965     case S_IRUSR: case S_IRGRP: case S_IROTH:
11966       access = ARM$M_READ;
11967       flags = CHP$M_READ | CHP$M_USEREADALL;
11968       break;
11969     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11970       access = ARM$M_WRITE;
11971       flags = CHP$M_READ | CHP$M_WRITE;
11972       break;
11973     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11974       access = ARM$M_DELETE;
11975       flags = CHP$M_READ | CHP$M_WRITE;
11976       break;
11977     default:
11978       if (fileified != NULL)
11979         PerlMem_free(fileified);
11980       if (vmsname != NULL)
11981         PerlMem_free(vmsname);
11982       return FALSE;
11983   }
11984
11985   /* Before we call $check_access, create a user profile with the current
11986    * process privs since otherwise it just uses the default privs from the
11987    * UAF and might give false positives or negatives.  This only works on
11988    * VMS versions v6.0 and later since that's when sys$create_user_profile
11989    * became available.
11990    */
11991
11992   /* get current process privs and username */
11993   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11994   _ckvmssts_noperl(iosb[0]);
11995
11996   /* find out the space required for the profile */
11997   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11998                                     &usrprodsc.dsc$w_length,&profile_context));
11999
12000   /* allocate space for the profile and get it filled in */
12001   usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
12002   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12003   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12004                                     &usrprodsc.dsc$w_length,&profile_context));
12005
12006   /* use the profile to check access to the file; free profile & analyze results */
12007   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12008   PerlMem_free(usrprodsc.dsc$a_pointer);
12009   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12010
12011   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12012       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12013       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12014     set_vaxc_errno(retsts);
12015     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12016     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12017     else set_errno(ENOENT);
12018     if (fileified != NULL)
12019       PerlMem_free(fileified);
12020     if (vmsname != NULL)
12021       PerlMem_free(vmsname);
12022     return FALSE;
12023   }
12024   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12025     if (fileified != NULL)
12026       PerlMem_free(fileified);
12027     if (vmsname != NULL)
12028       PerlMem_free(vmsname);
12029     return TRUE;
12030   }
12031   _ckvmssts_noperl(retsts);
12032
12033   if (fileified != NULL)
12034     PerlMem_free(fileified);
12035   if (vmsname != NULL)
12036     PerlMem_free(vmsname);
12037   return FALSE;  /* Should never get here */
12038
12039 }
12040
12041 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12042 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12043  * subset of the applicable information.
12044  */
12045 bool
12046 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12047 {
12048   return cando_by_name_int
12049         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12050 }  /* end of cando() */
12051 /*}}}*/
12052
12053
12054 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12055 I32
12056 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12057 {
12058    return cando_by_name_int(bit, effective, fname, 0);
12059
12060 }  /* end of cando_by_name() */
12061 /*}}}*/
12062
12063
12064 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12065 int
12066 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12067 {
12068   dSAVE_ERRNO; /* fstat may set this even on success */
12069   if (!fstat(fd, &statbufp->crtl_stat)) {
12070     char *cptr;
12071     char *vms_filename;
12072     vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12073     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12074
12075     /* Save name for cando by name in VMS format */
12076     cptr = getname(fd, vms_filename, 1);
12077
12078     /* This should not happen, but just in case */
12079     if (cptr == NULL) {
12080         statbufp->st_devnam[0] = 0;
12081     }
12082     else {
12083         /* Make sure that the saved name fits in 255 characters */
12084         cptr = int_rmsexpand_vms
12085                        (vms_filename,
12086                         statbufp->st_devnam,
12087                         0);
12088         if (cptr == NULL)
12089             statbufp->st_devnam[0] = 0;
12090     }
12091     PerlMem_free(vms_filename);
12092
12093     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12094     VMS_DEVICE_ENCODE
12095         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12096
12097 #   ifdef VMSISH_TIME
12098     if (VMSISH_TIME) {
12099       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12100       statbufp->st_atime = _toloc(statbufp->st_atime);
12101       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12102     }
12103 #   endif
12104     RESTORE_ERRNO;
12105     return 0;
12106   }
12107   return -1;
12108
12109 }  /* end of flex_fstat() */
12110 /*}}}*/
12111
12112 static int
12113 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12114 {
12115     char *temp_fspec = NULL;
12116     char *fileified = NULL;
12117     const char *save_spec;
12118     char *ret_spec;
12119     int retval = -1;
12120     char efs_hack = 0;
12121     char already_fileified = 0;
12122     dSAVEDERRNO;
12123
12124     if (!fspec) {
12125         errno = EINVAL;
12126         return retval;
12127     }
12128
12129     if (decc_bug_devnull != 0) {
12130       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12131         memset(statbufp,0,sizeof *statbufp);
12132         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12133         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12134         statbufp->st_uid = 0x00010001;
12135         statbufp->st_gid = 0x0001;
12136         time((time_t *)&statbufp->st_mtime);
12137         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12138         return 0;
12139       }
12140     }
12141
12142     SAVE_ERRNO;
12143
12144 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12145   /*
12146    * If we are in POSIX filespec mode, accept the filename as is.
12147    */
12148   if (decc_posix_compliant_pathnames == 0) {
12149 #endif
12150
12151     /* Try for a simple stat first.  If fspec contains a filename without
12152      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12153      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12154      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12155      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12156      * the file with null type, specify this by calling flex_stat() with
12157      * a '.' at the end of fspec.
12158      */
12159
12160     if (lstat_flag == 0)
12161         retval = stat(fspec, &statbufp->crtl_stat);
12162     else
12163         retval = lstat(fspec, &statbufp->crtl_stat);
12164
12165     if (!retval) {
12166         save_spec = fspec;
12167     }
12168     else {
12169         /* In the odd case where we have write but not read access
12170          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12171          */
12172         fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12173         if (fileified == NULL)
12174               _ckvmssts_noperl(SS$_INSFMEM);
12175
12176         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12177         if (ret_spec != NULL) {
12178             if (lstat_flag == 0)
12179                 retval = stat(fileified, &statbufp->crtl_stat);
12180             else
12181                 retval = lstat(fileified, &statbufp->crtl_stat);
12182             save_spec = fileified;
12183             already_fileified = 1;
12184         }
12185     }
12186
12187     if (retval && vms_bug_stat_filename) {
12188
12189         temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12190         if (temp_fspec == NULL)
12191             _ckvmssts_noperl(SS$_INSFMEM);
12192
12193         /* We should try again as a vmsified file specification. */
12194
12195         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12196         if (ret_spec != NULL) {
12197             if (lstat_flag == 0)
12198                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12199             else
12200                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12201             save_spec = temp_fspec;
12202         }
12203     }
12204
12205     if (retval) {
12206         /* Last chance - allow multiple dots without EFS CHARSET */
12207         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12208          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12209          * enable it if it isn't already.
12210          */
12211 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12212         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12213             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12214 #endif
12215         if (lstat_flag == 0)
12216             retval = stat(fspec, &statbufp->crtl_stat);
12217         else
12218             retval = lstat(fspec, &statbufp->crtl_stat);
12219         save_spec = fspec;
12220 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12221         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12222             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12223             efs_hack = 1;
12224         }
12225 #endif
12226     }
12227
12228 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12229   } else {
12230     if (lstat_flag == 0)
12231       retval = stat(temp_fspec, &statbufp->crtl_stat);
12232     else
12233       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12234       save_spec = temp_fspec;
12235   }
12236 #endif
12237
12238 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12239   /* As you were... */
12240   if (!decc_efs_charset)
12241     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12242 #endif
12243
12244     if (!retval) {
12245       char *cptr;
12246       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12247
12248       /* If this is an lstat, do not follow the link */
12249       if (lstat_flag)
12250         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12251
12252 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12253       /* If we used the efs_hack above, we must also use it here for */
12254       /* perl_cando to work */
12255       if (efs_hack && (decc_efs_charset_index > 0)) {
12256           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12257       }
12258 #endif
12259
12260       /* If we've got a directory, save a fileified, expanded version of it
12261        * in st_devnam.  If not a directory, just an expanded version.
12262        */
12263       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12264           fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12265           if (fileified == NULL)
12266               _ckvmssts_noperl(SS$_INSFMEM);
12267
12268           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12269           if (cptr != NULL)
12270               save_spec = fileified;
12271       }
12272
12273       cptr = int_rmsexpand(save_spec,
12274                            statbufp->st_devnam,
12275                            NULL,
12276                            rmsex_flags,
12277                            0,
12278                            0);
12279
12280 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12281       if (efs_hack && (decc_efs_charset_index > 0)) {
12282           decc$feature_set_value(decc_efs_charset, 1, 0);
12283       }
12284 #endif
12285
12286       /* Fix me: If this is NULL then stat found a file, and we could */
12287       /* not convert the specification to VMS - Should never happen */
12288       if (cptr == NULL)
12289         statbufp->st_devnam[0] = 0;
12290
12291       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12292       VMS_DEVICE_ENCODE
12293         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12294 #     ifdef VMSISH_TIME
12295       if (VMSISH_TIME) {
12296         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12297         statbufp->st_atime = _toloc(statbufp->st_atime);
12298         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12299       }
12300 #     endif
12301     }
12302     /* If we were successful, leave errno where we found it */
12303     if (retval == 0) RESTORE_ERRNO;
12304     if (temp_fspec)
12305         PerlMem_free(temp_fspec);
12306     if (fileified)
12307         PerlMem_free(fileified);
12308     return retval;
12309
12310 }  /* end of flex_stat_int() */
12311
12312
12313 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12314 int
12315 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12316 {
12317    return flex_stat_int(fspec, statbufp, 0);
12318 }
12319 /*}}}*/
12320
12321 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12322 int
12323 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12324 {
12325    return flex_stat_int(fspec, statbufp, 1);
12326 }
12327 /*}}}*/
12328
12329
12330 /*{{{char *my_getlogin()*/
12331 /* VMS cuserid == Unix getlogin, except calling sequence */
12332 char *
12333 my_getlogin(void)
12334 {
12335     static char user[L_cuserid];
12336     return cuserid(user);
12337 }
12338 /*}}}*/
12339
12340
12341 /*  rmscopy - copy a file using VMS RMS routines
12342  *
12343  *  Copies contents and attributes of spec_in to spec_out, except owner
12344  *  and protection information.  Name and type of spec_in are used as
12345  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12346  *  should try to propagate timestamps from the input file to the output file.
12347  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12348  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12349  *  propagated to the output file at creation iff the output file specification
12350  *  did not contain an explicit name or type, and the revision date is always
12351  *  updated at the end of the copy operation.  If it is greater than 0, then
12352  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12353  *  other than the revision date should be propagated, and bit 1 indicates
12354  *  that the revision date should be propagated.
12355  *
12356  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12357  *
12358  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12359  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12360  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12361  * as part of the Perl standard distribution under the terms of the
12362  * GNU General Public License or the Perl Artistic License.  Copies
12363  * of each may be found in the Perl standard distribution.
12364  */ /* FIXME */
12365 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12366 int
12367 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12368 {
12369     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12370          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12371     unsigned long int sts;
12372     int dna_len;
12373     struct FAB fab_in, fab_out;
12374     struct RAB rab_in, rab_out;
12375     rms_setup_nam(nam);
12376     rms_setup_nam(nam_out);
12377     struct XABDAT xabdat;
12378     struct XABFHC xabfhc;
12379     struct XABRDT xabrdt;
12380     struct XABSUM xabsum;
12381
12382     vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12383     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12384     vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12385     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12386     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12387         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12388       PerlMem_free(vmsin);
12389       PerlMem_free(vmsout);
12390       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12391       return 0;
12392     }
12393
12394     esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12395     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12396     esal = NULL;
12397 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12398     esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12399     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12400 #endif
12401     fab_in = cc$rms_fab;
12402     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12403     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12404     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12405     fab_in.fab$l_fop = FAB$M_SQO;
12406     rms_bind_fab_nam(fab_in, nam);
12407     fab_in.fab$l_xab = (void *) &xabdat;
12408
12409     rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12410     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12411     rsal = NULL;
12412 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12413     rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12414     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12415 #endif
12416     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12417     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12418     rms_nam_esl(nam) = 0;
12419     rms_nam_rsl(nam) = 0;
12420     rms_nam_esll(nam) = 0;
12421     rms_nam_rsll(nam) = 0;
12422 #ifdef NAM$M_NO_SHORT_UPCASE
12423     if (decc_efs_case_preserve)
12424         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12425 #endif
12426
12427     xabdat = cc$rms_xabdat;        /* To get creation date */
12428     xabdat.xab$l_nxt = (void *) &xabfhc;
12429
12430     xabfhc = cc$rms_xabfhc;        /* To get record length */
12431     xabfhc.xab$l_nxt = (void *) &xabsum;
12432
12433     xabsum = cc$rms_xabsum;        /* To get key and area information */
12434
12435     if (!((sts = sys$open(&fab_in)) & 1)) {
12436       PerlMem_free(vmsin);
12437       PerlMem_free(vmsout);
12438       PerlMem_free(esa);
12439       if (esal != NULL)
12440         PerlMem_free(esal);
12441       PerlMem_free(rsa);
12442       if (rsal != NULL)
12443         PerlMem_free(rsal);
12444       set_vaxc_errno(sts);
12445       switch (sts) {
12446         case RMS$_FNF: case RMS$_DNF:
12447           set_errno(ENOENT); break;
12448         case RMS$_DIR:
12449           set_errno(ENOTDIR); break;
12450         case RMS$_DEV:
12451           set_errno(ENODEV); break;
12452         case RMS$_SYN:
12453           set_errno(EINVAL); break;
12454         case RMS$_PRV:
12455           set_errno(EACCES); break;
12456         default:
12457           set_errno(EVMSERR);
12458       }
12459       return 0;
12460     }
12461
12462     nam_out = nam;
12463     fab_out = fab_in;
12464     fab_out.fab$w_ifi = 0;
12465     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12466     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12467     fab_out.fab$l_fop = FAB$M_SQO;
12468     rms_bind_fab_nam(fab_out, nam_out);
12469     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12470     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12471     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12472     esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12473     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12474     rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12475     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12476     esal_out = NULL;
12477     rsal_out = NULL;
12478 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12479     esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12480     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12481     rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12482     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12483 #endif
12484     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12485     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12486
12487     if (preserve_dates == 0) {  /* Act like DCL COPY */
12488       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12489       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12490       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12491         PerlMem_free(vmsin);
12492         PerlMem_free(vmsout);
12493         PerlMem_free(esa);
12494         if (esal != NULL)
12495             PerlMem_free(esal);
12496         PerlMem_free(rsa);
12497         if (rsal != NULL)
12498             PerlMem_free(rsal);
12499         PerlMem_free(esa_out);
12500         if (esal_out != NULL)
12501             PerlMem_free(esal_out);
12502         PerlMem_free(rsa_out);
12503         if (rsal_out != NULL)
12504             PerlMem_free(rsal_out);
12505         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12506         set_vaxc_errno(sts);
12507         return 0;
12508       }
12509       fab_out.fab$l_xab = (void *) &xabdat;
12510       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12511         preserve_dates = 1;
12512     }
12513     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12514       preserve_dates =0;      /* bitmask from this point forward   */
12515
12516     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12517     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12518       PerlMem_free(vmsin);
12519       PerlMem_free(vmsout);
12520       PerlMem_free(esa);
12521       if (esal != NULL)
12522           PerlMem_free(esal);
12523       PerlMem_free(rsa);
12524       if (rsal != NULL)
12525           PerlMem_free(rsal);
12526       PerlMem_free(esa_out);
12527       if (esal_out != NULL)
12528           PerlMem_free(esal_out);
12529       PerlMem_free(rsa_out);
12530       if (rsal_out != NULL)
12531           PerlMem_free(rsal_out);
12532       set_vaxc_errno(sts);
12533       switch (sts) {
12534         case RMS$_DNF:
12535           set_errno(ENOENT); break;
12536         case RMS$_DIR:
12537           set_errno(ENOTDIR); break;
12538         case RMS$_DEV:
12539           set_errno(ENODEV); break;
12540         case RMS$_SYN:
12541           set_errno(EINVAL); break;
12542         case RMS$_PRV:
12543           set_errno(EACCES); break;
12544         default:
12545           set_errno(EVMSERR);
12546       }
12547       return 0;
12548     }
12549     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12550     if (preserve_dates & 2) {
12551       /* sys$close() will process xabrdt, not xabdat */
12552       xabrdt = cc$rms_xabrdt;
12553 #ifndef __GNUC__
12554       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12555 #else
12556       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12557        * is unsigned long[2], while DECC & VAXC use a struct */
12558       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12559 #endif
12560       fab_out.fab$l_xab = (void *) &xabrdt;
12561     }
12562
12563     ubf = (char *)PerlMem_malloc(32256);
12564     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12565     rab_in = cc$rms_rab;
12566     rab_in.rab$l_fab = &fab_in;
12567     rab_in.rab$l_rop = RAB$M_BIO;
12568     rab_in.rab$l_ubf = ubf;
12569     rab_in.rab$w_usz = 32256;
12570     if (!((sts = sys$connect(&rab_in)) & 1)) {
12571       sys$close(&fab_in); sys$close(&fab_out);
12572       PerlMem_free(vmsin);
12573       PerlMem_free(vmsout);
12574       PerlMem_free(ubf);
12575       PerlMem_free(esa);
12576       if (esal != NULL)
12577           PerlMem_free(esal);
12578       PerlMem_free(rsa);
12579       if (rsal != NULL)
12580           PerlMem_free(rsal);
12581       PerlMem_free(esa_out);
12582       if (esal_out != NULL)
12583           PerlMem_free(esal_out);
12584       PerlMem_free(rsa_out);
12585       if (rsal_out != NULL)
12586           PerlMem_free(rsal_out);
12587       set_errno(EVMSERR); set_vaxc_errno(sts);
12588       return 0;
12589     }
12590
12591     rab_out = cc$rms_rab;
12592     rab_out.rab$l_fab = &fab_out;
12593     rab_out.rab$l_rbf = ubf;
12594     if (!((sts = sys$connect(&rab_out)) & 1)) {
12595       sys$close(&fab_in); sys$close(&fab_out);
12596       PerlMem_free(vmsin);
12597       PerlMem_free(vmsout);
12598       PerlMem_free(ubf);
12599       PerlMem_free(esa);
12600       if (esal != NULL)
12601           PerlMem_free(esal);
12602       PerlMem_free(rsa);
12603       if (rsal != NULL)
12604           PerlMem_free(rsal);
12605       PerlMem_free(esa_out);
12606       if (esal_out != NULL)
12607           PerlMem_free(esal_out);
12608       PerlMem_free(rsa_out);
12609       if (rsal_out != NULL)
12610           PerlMem_free(rsal_out);
12611       set_errno(EVMSERR); set_vaxc_errno(sts);
12612       return 0;
12613     }
12614
12615     while ((sts = sys$read(&rab_in))) {  /* always true  */
12616       if (sts == RMS$_EOF) break;
12617       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12618       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12619         sys$close(&fab_in); sys$close(&fab_out);
12620         PerlMem_free(vmsin);
12621         PerlMem_free(vmsout);
12622         PerlMem_free(ubf);
12623         PerlMem_free(esa);
12624         if (esal != NULL)
12625             PerlMem_free(esal);
12626         PerlMem_free(rsa);
12627         if (rsal != NULL)
12628             PerlMem_free(rsal);
12629         PerlMem_free(esa_out);
12630         if (esal_out != NULL)
12631             PerlMem_free(esal_out);
12632         PerlMem_free(rsa_out);
12633         if (rsal_out != NULL)
12634             PerlMem_free(rsal_out);
12635         set_errno(EVMSERR); set_vaxc_errno(sts);
12636         return 0;
12637       }
12638     }
12639
12640
12641     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12642     sys$close(&fab_in);  sys$close(&fab_out);
12643     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12644
12645     PerlMem_free(vmsin);
12646     PerlMem_free(vmsout);
12647     PerlMem_free(ubf);
12648     PerlMem_free(esa);
12649     if (esal != NULL)
12650         PerlMem_free(esal);
12651     PerlMem_free(rsa);
12652     if (rsal != NULL)
12653         PerlMem_free(rsal);
12654     PerlMem_free(esa_out);
12655     if (esal_out != NULL)
12656         PerlMem_free(esal_out);
12657     PerlMem_free(rsa_out);
12658     if (rsal_out != NULL)
12659         PerlMem_free(rsal_out);
12660
12661     if (!(sts & 1)) {
12662       set_errno(EVMSERR); set_vaxc_errno(sts);
12663       return 0;
12664     }
12665
12666     return 1;
12667
12668 }  /* end of rmscopy() */
12669 /*}}}*/
12670
12671
12672 /***  The following glue provides 'hooks' to make some of the routines
12673  * from this file available from Perl.  These routines are sufficiently
12674  * basic, and are required sufficiently early in the build process,
12675  * that's it's nice to have them available to miniperl as well as the
12676  * full Perl, so they're set up here instead of in an extension.  The
12677  * Perl code which handles importation of these names into a given
12678  * package lives in [.VMS]Filespec.pm in @INC.
12679  */
12680
12681 void
12682 rmsexpand_fromperl(pTHX_ CV *cv)
12683 {
12684   dXSARGS;
12685   char *fspec, *defspec = NULL, *rslt;
12686   STRLEN n_a;
12687   int fs_utf8, dfs_utf8;
12688
12689   fs_utf8 = 0;
12690   dfs_utf8 = 0;
12691   if (!items || items > 2)
12692     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12693   fspec = SvPV(ST(0),n_a);
12694   fs_utf8 = SvUTF8(ST(0));
12695   if (!fspec || !*fspec) XSRETURN_UNDEF;
12696   if (items == 2) {
12697     defspec = SvPV(ST(1),n_a);
12698     dfs_utf8 = SvUTF8(ST(1));
12699   }
12700   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12701   ST(0) = sv_newmortal();
12702   if (rslt != NULL) {
12703     sv_usepvn(ST(0),rslt,strlen(rslt));
12704     if (fs_utf8) {
12705         SvUTF8_on(ST(0));
12706     }
12707   }
12708   XSRETURN(1);
12709 }
12710
12711 void
12712 vmsify_fromperl(pTHX_ CV *cv)
12713 {
12714   dXSARGS;
12715   char *vmsified;
12716   STRLEN n_a;
12717   int utf8_fl;
12718
12719   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12720   utf8_fl = SvUTF8(ST(0));
12721   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12722   ST(0) = sv_newmortal();
12723   if (vmsified != NULL) {
12724     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12725     if (utf8_fl) {
12726         SvUTF8_on(ST(0));
12727     }
12728   }
12729   XSRETURN(1);
12730 }
12731
12732 void
12733 unixify_fromperl(pTHX_ CV *cv)
12734 {
12735   dXSARGS;
12736   char *unixified;
12737   STRLEN n_a;
12738   int utf8_fl;
12739
12740   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12741   utf8_fl = SvUTF8(ST(0));
12742   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12743   ST(0) = sv_newmortal();
12744   if (unixified != NULL) {
12745     sv_usepvn(ST(0),unixified,strlen(unixified));
12746     if (utf8_fl) {
12747         SvUTF8_on(ST(0));
12748     }
12749   }
12750   XSRETURN(1);
12751 }
12752
12753 void
12754 fileify_fromperl(pTHX_ CV *cv)
12755 {
12756   dXSARGS;
12757   char *fileified;
12758   STRLEN n_a;
12759   int utf8_fl;
12760
12761   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12762   utf8_fl = SvUTF8(ST(0));
12763   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12764   ST(0) = sv_newmortal();
12765   if (fileified != NULL) {
12766     sv_usepvn(ST(0),fileified,strlen(fileified));
12767     if (utf8_fl) {
12768         SvUTF8_on(ST(0));
12769     }
12770   }
12771   XSRETURN(1);
12772 }
12773
12774 void
12775 pathify_fromperl(pTHX_ CV *cv)
12776 {
12777   dXSARGS;
12778   char *pathified;
12779   STRLEN n_a;
12780   int utf8_fl;
12781
12782   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12783   utf8_fl = SvUTF8(ST(0));
12784   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12785   ST(0) = sv_newmortal();
12786   if (pathified != NULL) {
12787     sv_usepvn(ST(0),pathified,strlen(pathified));
12788     if (utf8_fl) {
12789         SvUTF8_on(ST(0));
12790     }
12791   }
12792   XSRETURN(1);
12793 }
12794
12795 void
12796 vmspath_fromperl(pTHX_ CV *cv)
12797 {
12798   dXSARGS;
12799   char *vmspath;
12800   STRLEN n_a;
12801   int utf8_fl;
12802
12803   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12804   utf8_fl = SvUTF8(ST(0));
12805   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12806   ST(0) = sv_newmortal();
12807   if (vmspath != NULL) {
12808     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12809     if (utf8_fl) {
12810         SvUTF8_on(ST(0));
12811     }
12812   }
12813   XSRETURN(1);
12814 }
12815
12816 void
12817 unixpath_fromperl(pTHX_ CV *cv)
12818 {
12819   dXSARGS;
12820   char *unixpath;
12821   STRLEN n_a;
12822   int utf8_fl;
12823
12824   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12825   utf8_fl = SvUTF8(ST(0));
12826   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12827   ST(0) = sv_newmortal();
12828   if (unixpath != NULL) {
12829     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12830     if (utf8_fl) {
12831         SvUTF8_on(ST(0));
12832     }
12833   }
12834   XSRETURN(1);
12835 }
12836
12837 void
12838 candelete_fromperl(pTHX_ CV *cv)
12839 {
12840   dXSARGS;
12841   char *fspec, *fsp;
12842   SV *mysv;
12843   IO *io;
12844   STRLEN n_a;
12845
12846   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12847
12848   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12849   Newx(fspec, VMS_MAXRSS, char);
12850   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12851   if (isGV_with_GP(mysv)) {
12852     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12853       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12854       ST(0) = &PL_sv_no;
12855       Safefree(fspec);
12856       XSRETURN(1);
12857     }
12858     fsp = fspec;
12859   }
12860   else {
12861     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12862       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12863       ST(0) = &PL_sv_no;
12864       Safefree(fspec);
12865       XSRETURN(1);
12866     }
12867   }
12868
12869   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12870   Safefree(fspec);
12871   XSRETURN(1);
12872 }
12873
12874 void
12875 rmscopy_fromperl(pTHX_ CV *cv)
12876 {
12877   dXSARGS;
12878   char *inspec, *outspec, *inp, *outp;
12879   int date_flag;
12880   SV *mysv;
12881   IO *io;
12882   STRLEN n_a;
12883
12884   if (items < 2 || items > 3)
12885     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12886
12887   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12888   Newx(inspec, VMS_MAXRSS, char);
12889   if (isGV_with_GP(mysv)) {
12890     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12891       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12892       ST(0) = sv_2mortal(newSViv(0));
12893       Safefree(inspec);
12894       XSRETURN(1);
12895     }
12896     inp = inspec;
12897   }
12898   else {
12899     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12900       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12901       ST(0) = sv_2mortal(newSViv(0));
12902       Safefree(inspec);
12903       XSRETURN(1);
12904     }
12905   }
12906   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12907   Newx(outspec, VMS_MAXRSS, char);
12908   if (isGV_with_GP(mysv)) {
12909     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12910       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12911       ST(0) = sv_2mortal(newSViv(0));
12912       Safefree(inspec);
12913       Safefree(outspec);
12914       XSRETURN(1);
12915     }
12916     outp = outspec;
12917   }
12918   else {
12919     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12920       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12921       ST(0) = sv_2mortal(newSViv(0));
12922       Safefree(inspec);
12923       Safefree(outspec);
12924       XSRETURN(1);
12925     }
12926   }
12927   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12928
12929   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12930   Safefree(inspec);
12931   Safefree(outspec);
12932   XSRETURN(1);
12933 }
12934
12935 /* The mod2fname is limited to shorter filenames by design, so it should
12936  * not be modified to support longer EFS pathnames
12937  */
12938 void
12939 mod2fname(pTHX_ CV *cv)
12940 {
12941   dXSARGS;
12942   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12943        workbuff[NAM$C_MAXRSS*1 + 1];
12944   SSize_t counter, num_entries;
12945   /* ODS-5 ups this, but we want to be consistent, so... */
12946   int max_name_len = 39;
12947   AV *in_array = (AV *)SvRV(ST(0));
12948
12949   num_entries = av_len(in_array);
12950
12951   /* All the names start with PL_. */
12952   strcpy(ultimate_name, "PL_");
12953
12954   /* Clean up our working buffer */
12955   Zero(work_name, sizeof(work_name), char);
12956
12957   /* Run through the entries and build up a working name */
12958   for(counter = 0; counter <= num_entries; counter++) {
12959     /* If it's not the first name then tack on a __ */
12960     if (counter) {
12961       my_strlcat(work_name, "__", sizeof(work_name));
12962     }
12963     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12964   }
12965
12966   /* Check to see if we actually have to bother...*/
12967   if (strlen(work_name) + 3 <= max_name_len) {
12968     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12969   } else {
12970     /* It's too darned big, so we need to go strip. We use the same */
12971     /* algorithm as xsubpp does. First, strip out doubled __ */
12972     char *source, *dest, last;
12973     dest = workbuff;
12974     last = 0;
12975     for (source = work_name; *source; source++) {
12976       if (last == *source && last == '_') {
12977         continue;
12978       }
12979       *dest++ = *source;
12980       last = *source;
12981     }
12982     /* Go put it back */
12983     my_strlcpy(work_name, workbuff, sizeof(work_name));
12984     /* Is it still too big? */
12985     if (strlen(work_name) + 3 > max_name_len) {
12986       /* Strip duplicate letters */
12987       last = 0;
12988       dest = workbuff;
12989       for (source = work_name; *source; source++) {
12990         if (last == toupper(*source)) {
12991         continue;
12992         }
12993         *dest++ = *source;
12994         last = toupper(*source);
12995       }
12996       my_strlcpy(work_name, workbuff, sizeof(work_name));
12997     }
12998
12999     /* Is it *still* too big? */
13000     if (strlen(work_name) + 3 > max_name_len) {
13001       /* Too bad, we truncate */
13002       work_name[max_name_len - 2] = 0;
13003     }
13004     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
13005   }
13006
13007   /* Okay, return it */
13008   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13009   XSRETURN(1);
13010 }
13011
13012 void
13013 hushexit_fromperl(pTHX_ CV *cv)
13014 {
13015     dXSARGS;
13016
13017     if (items > 0) {
13018         VMSISH_HUSHED = SvTRUE(ST(0));
13019     }
13020     ST(0) = boolSV(VMSISH_HUSHED);
13021     XSRETURN(1);
13022 }
13023
13024
13025 PerlIO *
13026 Perl_vms_start_glob
13027    (pTHX_ SV *tmpglob,
13028     IO *io)
13029 {
13030     PerlIO *fp;
13031     struct vs_str_st *rslt;
13032     char *vmsspec;
13033     char *rstr;
13034     char *begin, *cp;
13035     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13036     PerlIO *tmpfp;
13037     STRLEN i;
13038     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13039     struct dsc$descriptor_vs rsdsc;
13040     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13041     unsigned long hasver = 0, isunix = 0;
13042     unsigned long int lff_flags = 0;
13043     int rms_sts;
13044     int vms_old_glob = 1;
13045
13046     if (!SvOK(tmpglob)) {
13047         SETERRNO(ENOENT,RMS$_FNF);
13048         return NULL;
13049     }
13050
13051     vms_old_glob = !decc_filename_unix_report;
13052
13053 #ifdef VMS_LONGNAME_SUPPORT
13054     lff_flags = LIB$M_FIL_LONG_NAMES;
13055 #endif
13056     /* The Newx macro will not allow me to assign a smaller array
13057      * to the rslt pointer, so we will assign it to the begin char pointer
13058      * and then copy the value into the rslt pointer.
13059      */
13060     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13061     rslt = (struct vs_str_st *)begin;
13062     rslt->length = 0;
13063     rstr = &rslt->str[0];
13064     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13065     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13066     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13067     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13068
13069     Newx(vmsspec, VMS_MAXRSS, char);
13070
13071         /* We could find out if there's an explicit dev/dir or version
13072            by peeking into lib$find_file's internal context at
13073            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13074            but that's unsupported, so I don't want to do it now and
13075            have it bite someone in the future. */
13076         /* Fix-me: vms_split_path() is the only way to do this, the
13077            existing method will fail with many legal EFS or UNIX specifications
13078          */
13079
13080     cp = SvPV(tmpglob,i);
13081
13082     for (; i; i--) {
13083         if (cp[i] == ';') hasver = 1;
13084         if (cp[i] == '.') {
13085             if (sts) hasver = 1;
13086             else sts = 1;
13087         }
13088         if (cp[i] == '/') {
13089             hasdir = isunix = 1;
13090             break;
13091         }
13092         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13093             hasdir = 1;
13094             break;
13095         }
13096     }
13097
13098     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13099     if ((hasdir == 0) && decc_filename_unix_report) {
13100         isunix = 1;
13101     }
13102
13103     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13104         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13105         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13106         int wildstar = 0;
13107         int wildquery = 0;
13108         int found = 0;
13109         Stat_t st;
13110         int stat_sts;
13111         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13112         if (!stat_sts && S_ISDIR(st.st_mode)) {
13113             char * vms_dir;
13114             const char * fname;
13115             STRLEN fname_len;
13116
13117             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13118             /* path delimiter of ':>]', if so, then the old behavior has */
13119             /* obviously been specifically requested */
13120
13121             fname = SvPVX_const(tmpglob);
13122             fname_len = strlen(fname);
13123             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13124             if (vms_old_glob || (vms_dir != NULL)) {
13125                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13126                                             SvPVX(tmpglob),vmsspec,NULL);
13127                 ok = (wilddsc.dsc$a_pointer != NULL);
13128                 /* maybe passed 'foo' rather than '[.foo]', thus not
13129                    detected above */
13130                 hasdir = 1;
13131             } else {
13132                 /* Operate just on the directory, the special stat/fstat for */
13133                 /* leaves the fileified  specification in the st_devnam */
13134                 /* member. */
13135                 wilddsc.dsc$a_pointer = st.st_devnam;
13136                 ok = 1;
13137             }
13138         }
13139         else {
13140             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13141             ok = (wilddsc.dsc$a_pointer != NULL);
13142         }
13143         if (ok)
13144             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13145
13146         /* If not extended character set, replace ? with % */
13147         /* With extended character set, ? is a wildcard single character */
13148         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13149             if (*cp == '?') {
13150                 wildquery = 1;
13151                 if (!decc_efs_charset)
13152                     *cp = '%';
13153             } else if (*cp == '%') {
13154                 wildquery = 1;
13155             } else if (*cp == '*') {
13156                 wildstar = 1;
13157             }
13158         }
13159
13160         if (ok) {
13161             wv_sts = vms_split_path(
13162                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13163                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13164                 &wvs_spec, &wvs_len);
13165         } else {
13166             wn_spec = NULL;
13167             wn_len = 0;
13168             we_spec = NULL;
13169             we_len = 0;
13170         }
13171
13172         sts = SS$_NORMAL;
13173         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13174          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13175          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13176          int valid_find;
13177
13178             valid_find = 0;
13179             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13180                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13181             if (!$VMS_STATUS_SUCCESS(sts))
13182                 break;
13183
13184             /* with varying string, 1st word of buffer contains result length */
13185             rstr[rslt->length] = '\0';
13186
13187              /* Find where all the components are */
13188              v_sts = vms_split_path
13189                        (rstr,
13190                         &v_spec,
13191                         &v_len,
13192                         &r_spec,
13193                         &r_len,
13194                         &d_spec,
13195                         &d_len,
13196                         &n_spec,
13197                         &n_len,
13198                         &e_spec,
13199                         &e_len,
13200                         &vs_spec,
13201                         &vs_len);
13202
13203             /* If no version on input, truncate the version on output */
13204             if (!hasver && (vs_len > 0)) {
13205                 *vs_spec = '\0';
13206                 vs_len = 0;
13207             }
13208
13209             if (isunix) {
13210
13211                 /* In Unix report mode, remove the ".dir;1" from the name */
13212                 /* if it is a real directory */
13213                 if (decc_filename_unix_report && decc_efs_charset) {
13214                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13215                         Stat_t statbuf;
13216                         int ret_sts;
13217
13218                         ret_sts = flex_lstat(rstr, &statbuf);
13219                         if ((ret_sts == 0) &&
13220                             S_ISDIR(statbuf.st_mode)) {
13221                             e_len = 0;
13222                             e_spec[0] = 0;
13223                         }
13224                     }
13225                 }
13226
13227                 /* No version & a null extension on UNIX handling */
13228                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13229                     e_len = 0;
13230                     *e_spec = '\0';
13231                 }
13232             }
13233
13234             if (!decc_efs_case_preserve) {
13235                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13236             }
13237
13238             /* Find File treats a Null extension as return all extensions */
13239             /* This is contrary to Perl expectations */
13240
13241             if (wildstar || wildquery || vms_old_glob) {
13242                 /* really need to see if the returned file name matched */
13243                 /* but for now will assume that it matches */
13244                 valid_find = 1;
13245             } else {
13246                 /* Exact Match requested */
13247                 /* How are directories handled? - like a file */
13248                 if ((e_len == we_len) && (n_len == wn_len)) {
13249                     int t1;
13250                     t1 = e_len;
13251                     if (t1 > 0)
13252                         t1 = strncmp(e_spec, we_spec, e_len);
13253                     if (t1 == 0) {
13254                        t1 = n_len;
13255                        if (t1 > 0)
13256                            t1 = strncmp(n_spec, we_spec, n_len);
13257                        if (t1 == 0)
13258                            valid_find = 1;
13259                     }
13260                 }
13261             }
13262
13263             if (valid_find) {
13264                 found++;
13265
13266                 if (hasdir) {
13267                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13268                     begin = rstr;
13269                 }
13270                 else {
13271                     /* Start with the name */
13272                     begin = n_spec;
13273                 }
13274                 strcat(begin,"\n");
13275                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13276             }
13277         }
13278         if (cxt) (void)lib$find_file_end(&cxt);
13279
13280         if (!found) {
13281             /* Be POSIXish: return the input pattern when no matches */
13282             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13283             strcat(rstr,"\n");
13284             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13285         }
13286
13287         if (ok && sts != RMS$_NMF &&
13288             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13289         if (!ok) {
13290             if (!(sts & 1)) {
13291                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13292             }
13293             PerlIO_close(tmpfp);
13294             fp = NULL;
13295         }
13296         else {
13297             PerlIO_rewind(tmpfp);
13298             IoTYPE(io) = IoTYPE_RDONLY;
13299             IoIFP(io) = fp = tmpfp;
13300             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13301         }
13302     }
13303     Safefree(vmsspec);
13304     Safefree(rslt);
13305     return fp;
13306 }
13307
13308
13309 static char *
13310 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13311                    int *utf8_fl);
13312
13313 void
13314 unixrealpath_fromperl(pTHX_ CV *cv)
13315 {
13316     dXSARGS;
13317     char *fspec, *rslt_spec, *rslt;
13318     STRLEN n_a;
13319
13320     if (!items || items != 1)
13321         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13322
13323     fspec = SvPV(ST(0),n_a);
13324     if (!fspec || !*fspec) XSRETURN_UNDEF;
13325
13326     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13327     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13328
13329     ST(0) = sv_newmortal();
13330     if (rslt != NULL)
13331         sv_usepvn(ST(0),rslt,strlen(rslt));
13332     else
13333         Safefree(rslt_spec);
13334         XSRETURN(1);
13335 }
13336
13337 static char *
13338 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13339                    int *utf8_fl);
13340
13341 void
13342 vmsrealpath_fromperl(pTHX_ CV *cv)
13343 {
13344     dXSARGS;
13345     char *fspec, *rslt_spec, *rslt;
13346     STRLEN n_a;
13347
13348     if (!items || items != 1)
13349         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13350
13351     fspec = SvPV(ST(0),n_a);
13352     if (!fspec || !*fspec) XSRETURN_UNDEF;
13353
13354     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13355     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13356
13357     ST(0) = sv_newmortal();
13358     if (rslt != NULL)
13359         sv_usepvn(ST(0),rslt,strlen(rslt));
13360     else
13361         Safefree(rslt_spec);
13362         XSRETURN(1);
13363 }
13364
13365 #ifdef HAS_SYMLINK
13366 /*
13367  * A thin wrapper around decc$symlink to make sure we follow the
13368  * standard and do not create a symlink with a zero-length name,
13369  * and convert the target to Unix format, as the CRTL can't handle
13370  * targets in VMS format.
13371  */
13372 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13373 int
13374 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13375 {
13376     int sts;
13377     char * utarget;
13378
13379     if (!link_name || !*link_name) {
13380       SETERRNO(ENOENT, SS$_NOSUCHFILE);
13381       return -1;
13382     }
13383
13384     utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13385     /* An untranslatable filename should be passed through. */
13386     (void) int_tounixspec(contents, utarget, NULL);
13387     sts = symlink(utarget, link_name);
13388     PerlMem_free(utarget);
13389     return sts;
13390 }
13391 /*}}}*/
13392
13393 #endif /* HAS_SYMLINK */
13394
13395 int do_vms_case_tolerant(void);
13396
13397 void
13398 case_tolerant_process_fromperl(pTHX_ CV *cv)
13399 {
13400   dXSARGS;
13401   ST(0) = boolSV(do_vms_case_tolerant());
13402   XSRETURN(1);
13403 }
13404
13405 #ifdef USE_ITHREADS
13406
13407 void
13408 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13409                           struct interp_intern *dst)
13410 {
13411     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13412
13413     memcpy(dst,src,sizeof(struct interp_intern));
13414 }
13415
13416 #endif
13417
13418 void
13419 Perl_sys_intern_clear(pTHX)
13420 {
13421 }
13422
13423 void
13424 Perl_sys_intern_init(pTHX)
13425 {
13426     unsigned int ix = RAND_MAX;
13427     double x;
13428
13429     VMSISH_HUSHED = 0;
13430
13431     MY_POSIX_EXIT = vms_posix_exit;
13432
13433     x = (float)ix;
13434     MY_INV_RAND_MAX = 1./x;
13435 }
13436
13437 void
13438 init_os_extras(void)
13439 {
13440   dTHX;
13441   char* file = __FILE__;
13442   if (decc_disable_to_vms_logname_translation) {
13443     no_translate_barewords = TRUE;
13444   } else {
13445     no_translate_barewords = FALSE;
13446   }
13447
13448   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13449   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13450   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13451   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13452   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13453   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13454   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13455   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13456   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13457   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13458   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13459   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13460   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13461   newXSproto("VMS::Filespec::case_tolerant_process",
13462       case_tolerant_process_fromperl,file,"");
13463
13464   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13465
13466   return;
13467 }
13468
13469 #if __CRTL_VER == 80200000
13470 /* This missed getting in to the DECC SDK for 8.2 */
13471 char *realpath(const char *file_name, char * resolved_name, ...);
13472 #endif
13473
13474 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13475 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13476  * The perl fallback routine to provide realpath() is not as efficient
13477  * on OpenVMS.
13478  */
13479
13480 #ifdef __cplusplus
13481 extern "C" {
13482 #endif
13483
13484 /* Hack, use old stat() as fastest way of getting ino_t and device */
13485 int decc$stat(const char *name, void * statbuf);
13486 #if !defined(__VAX) && __CRTL_VER >= 80200000
13487 int decc$lstat(const char *name, void * statbuf);
13488 #else
13489 #define decc$lstat decc$stat
13490 #endif
13491
13492 #ifdef __cplusplus
13493 }
13494 #endif
13495
13496
13497 /* Realpath is fragile.  In 8.3 it does not work if the feature
13498  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13499  * links are implemented in RMS, not the CRTL. It also can fail if the
13500  * user does not have read/execute access to some of the directories.
13501  * So in order for Do What I Mean mode to work, if realpath() fails,
13502  * fall back to looking up the filename by the device name and FID.
13503  */
13504
13505 int vms_fid_to_name(char * outname, int outlen,
13506                     const char * name, int lstat_flag, mode_t * mode)
13507 {
13508 #pragma message save
13509 #pragma message disable MISALGNDSTRCT
13510 #pragma message disable MISALGNDMEM
13511 #pragma member_alignment save
13512 #pragma nomember_alignment
13513 struct statbuf_t {
13514     char           * st_dev;
13515     unsigned short st_ino[3];
13516     unsigned short old_st_mode;
13517     unsigned long  padl[30];  /* plenty of room */
13518 } statbuf;
13519 #pragma message restore
13520 #pragma member_alignment restore
13521
13522     int sts;
13523     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13524     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13525     char *fileified;
13526     char *temp_fspec;
13527     char *ret_spec;
13528
13529     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13530      * unexpected answers
13531      */
13532
13533     fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13534     if (fileified == NULL)
13535         _ckvmssts_noperl(SS$_INSFMEM);
13536
13537     temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13538     if (temp_fspec == NULL)
13539         _ckvmssts_noperl(SS$_INSFMEM);
13540
13541     sts = -1;
13542     /* First need to try as a directory */
13543     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13544     if (ret_spec != NULL) {
13545         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13546         if (ret_spec != NULL) {
13547             if (lstat_flag == 0)
13548                 sts = decc$stat(fileified, &statbuf);
13549             else
13550                 sts = decc$lstat(fileified, &statbuf);
13551         }
13552     }
13553
13554     /* Then as a VMS file spec */
13555     if (sts != 0) {
13556         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13557         if (ret_spec != NULL) {
13558             if (lstat_flag == 0) {
13559                 sts = decc$stat(temp_fspec, &statbuf);
13560             } else {
13561                 sts = decc$lstat(temp_fspec, &statbuf);
13562             }
13563         }
13564     }
13565
13566     if (sts) {
13567         /* Next try - allow multiple dots with out EFS CHARSET */
13568         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13569          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13570          * enable it if it isn't already.
13571          */
13572 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13573         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13574             decc$feature_set_value(decc_efs_charset_index, 1, 1);
13575 #endif
13576         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13577         if (lstat_flag == 0) {
13578             sts = decc$stat(name, &statbuf);
13579         } else {
13580             sts = decc$lstat(name, &statbuf);
13581         }
13582 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13583         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13584             decc$feature_set_value(decc_efs_charset_index, 1, 0);
13585 #endif
13586     }
13587
13588
13589     /* and then because the Perl Unix to VMS conversion is not perfect */
13590     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13591     /* characters from filenames so we need to try it as-is */
13592     if (sts) {
13593         if (lstat_flag == 0) {
13594             sts = decc$stat(name, &statbuf);
13595         } else {
13596             sts = decc$lstat(name, &statbuf);
13597         }
13598     }
13599
13600     if (sts == 0) {
13601         int vms_sts;
13602
13603         dvidsc.dsc$a_pointer=statbuf.st_dev;
13604         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13605
13606         specdsc.dsc$a_pointer = outname;
13607         specdsc.dsc$w_length = outlen-1;
13608
13609         vms_sts = lib$fid_to_name
13610             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13611         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13612             outname[specdsc.dsc$w_length] = 0;
13613
13614             /* Return the mode */
13615             if (mode) {
13616                 *mode = statbuf.old_st_mode;
13617             }
13618         }
13619     }
13620     PerlMem_free(temp_fspec);
13621     PerlMem_free(fileified);
13622     return sts;
13623 }
13624
13625
13626
13627 static char *
13628 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13629                    int *utf8_fl)
13630 {
13631     char * rslt = NULL;
13632
13633 #ifdef HAS_SYMLINK
13634     if (decc_posix_compliant_pathnames > 0 ) {
13635         /* realpath currently only works if posix compliant pathnames are
13636          * enabled.  It may start working when they are not, but in that
13637          * case we still want the fallback behavior for backwards compatibility
13638          */
13639         rslt = realpath(filespec, outbuf);
13640     }
13641 #endif
13642
13643     if (rslt == NULL) {
13644         char * vms_spec;
13645         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13646         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13647         mode_t my_mode;
13648
13649         /* Fall back to fid_to_name */
13650
13651         Newx(vms_spec, VMS_MAXRSS + 1, char);
13652
13653         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13654         if (sts == 0) {
13655
13656
13657             /* Now need to trim the version off */
13658             sts = vms_split_path
13659                   (vms_spec,
13660                    &v_spec,
13661                    &v_len,
13662                    &r_spec,
13663                    &r_len,
13664                    &d_spec,
13665                    &d_len,
13666                    &n_spec,
13667                    &n_len,
13668                    &e_spec,
13669                    &e_len,
13670                    &vs_spec,
13671                    &vs_len);
13672
13673
13674                 if (sts == 0) {
13675                     int haslower = 0;
13676                     const char *cp;
13677
13678                     /* Trim off the version */
13679                     int file_len = v_len + r_len + d_len + n_len + e_len;
13680                     vms_spec[file_len] = 0;
13681
13682                     /* Trim off the .DIR if this is a directory */
13683                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13684                         if (S_ISDIR(my_mode)) {
13685                             e_len = 0;
13686                             e_spec[0] = 0;
13687                         }
13688                     }
13689
13690                     /* Drop NULL extensions on UNIX file specification */
13691                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
13692                         e_len = 0;
13693                         e_spec[0] = '\0';
13694                     }
13695
13696                     /* The result is expected to be in UNIX format */
13697                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13698
13699                     /* Downcase if input had any lower case letters and
13700                      * case preservation is not in effect.
13701                      */
13702                     if (!decc_efs_case_preserve) {
13703                         for (cp = filespec; *cp; cp++)
13704                             if (islower(*cp)) { haslower = 1; break; }
13705
13706                         if (haslower) __mystrtolower(rslt);
13707                     }
13708                 }
13709         } else {
13710
13711             /* Now for some hacks to deal with backwards and forward */
13712             /* compatibility */
13713             if (!decc_efs_charset) {
13714
13715                 /* 1. ODS-2 mode wants to do a syntax only translation */
13716                 rslt = int_rmsexpand(filespec, outbuf,
13717                                     NULL, 0, NULL, utf8_fl);
13718
13719             } else {
13720                 if (decc_filename_unix_report) {
13721                     char * dir_name;
13722                     char * vms_dir_name;
13723                     char * file_name;
13724
13725                     /* 2. ODS-5 / UNIX report mode should return a failure */
13726                     /*    if the parent directory also does not exist */
13727                     /*    Otherwise, get the real path for the parent */
13728                     /*    and add the child to it. */
13729
13730                     /* basename / dirname only available for VMS 7.0+ */
13731                     /* So we may need to implement them as common routines */
13732
13733                     Newx(dir_name, VMS_MAXRSS + 1, char);
13734                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13735                     dir_name[0] = '\0';
13736                     file_name = NULL;
13737
13738                     /* First try a VMS parse */
13739                     sts = vms_split_path
13740                           (filespec,
13741                            &v_spec,
13742                            &v_len,
13743                            &r_spec,
13744                            &r_len,
13745                            &d_spec,
13746                            &d_len,
13747                            &n_spec,
13748                            &n_len,
13749                            &e_spec,
13750                            &e_len,
13751                            &vs_spec,
13752                            &vs_len);
13753
13754                     if (sts == 0) {
13755                         /* This is VMS */
13756
13757                         int dir_len = v_len + r_len + d_len + n_len;
13758                         if (dir_len > 0) {
13759                            memcpy(dir_name, filespec, dir_len);
13760                            dir_name[dir_len] = '\0';
13761                            file_name = (char *)&filespec[dir_len + 1];
13762                         }
13763                     } else {
13764                         /* This must be UNIX */
13765                         char * tchar;
13766
13767                         tchar = strrchr(filespec, '/');
13768
13769                         if (tchar != NULL) {
13770                             int dir_len = tchar - filespec;
13771                             memcpy(dir_name, filespec, dir_len);
13772                             dir_name[dir_len] = '\0';
13773                             file_name = (char *) &filespec[dir_len + 1];
13774                         }
13775                     }
13776
13777                     /* Dir name is defaulted */
13778                     if (dir_name[0] == 0) {
13779                         dir_name[0] = '.';
13780                         dir_name[1] = '\0';
13781                     }
13782
13783                     /* Need realpath for the directory */
13784                     sts = vms_fid_to_name(vms_dir_name,
13785                                           VMS_MAXRSS + 1,
13786                                           dir_name, 0, NULL);
13787
13788                     if (sts == 0) {
13789                         /* Now need to pathify it. */
13790                         char *tdir = int_pathify_dirspec(vms_dir_name,
13791                                                          outbuf);
13792
13793                         /* And now add the original filespec to it */
13794                         if (file_name != NULL) {
13795                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13796                         }
13797                         return outbuf;
13798                     }
13799                     Safefree(vms_dir_name);
13800                     Safefree(dir_name);
13801                 }
13802             }
13803         }
13804         Safefree(vms_spec);
13805     }
13806     return rslt;
13807 }
13808
13809 static char *
13810 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13811                    int *utf8_fl)
13812 {
13813     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13814     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13815
13816     /* Fall back to fid_to_name */
13817
13818     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13819     if (sts != 0) {
13820         return NULL;
13821     }
13822     else {
13823
13824
13825         /* Now need to trim the version off */
13826         sts = vms_split_path
13827                   (outbuf,
13828                    &v_spec,
13829                    &v_len,
13830                    &r_spec,
13831                    &r_len,
13832                    &d_spec,
13833                    &d_len,
13834                    &n_spec,
13835                    &n_len,
13836                    &e_spec,
13837                    &e_len,
13838                    &vs_spec,
13839                    &vs_len);
13840
13841
13842         if (sts == 0) {
13843             int haslower = 0;
13844             const char *cp;
13845
13846             /* Trim off the version */
13847             int file_len = v_len + r_len + d_len + n_len + e_len;
13848             outbuf[file_len] = 0;
13849
13850             /* Downcase if input had any lower case letters and
13851              * case preservation is not in effect.
13852              */
13853             if (!decc_efs_case_preserve) {
13854                 for (cp = filespec; *cp; cp++)
13855                     if (islower(*cp)) { haslower = 1; break; }
13856
13857                 if (haslower) __mystrtolower(outbuf);
13858             }
13859         }
13860     }
13861     return outbuf;
13862 }
13863
13864
13865 /*}}}*/
13866 /* External entry points */
13867 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13868 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13869
13870 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13871 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13872
13873 /* case_tolerant */
13874
13875 /*{{{int do_vms_case_tolerant(void)*/
13876 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13877  * controlled by a process setting.
13878  */
13879 int do_vms_case_tolerant(void)
13880 {
13881     return vms_process_case_tolerant;
13882 }
13883 /*}}}*/
13884 /* External entry points */
13885 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13886 int Perl_vms_case_tolerant(void)
13887 { return do_vms_case_tolerant(); }
13888 #else
13889 int Perl_vms_case_tolerant(void)
13890 { return vms_process_case_tolerant; }
13891 #endif
13892
13893
13894  /* Start of DECC RTL Feature handling */
13895
13896 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13897
13898 static int
13899 set_feature_default(const char *name, int value)
13900 {
13901     int status;
13902     int index;
13903     char val_str[10];
13904
13905     /* If the feature has been explicitly disabled in the environment,
13906      * then don't enable it here.
13907      */
13908     if (value > 0) {
13909         status = simple_trnlnm(name, val_str, sizeof(val_str));
13910         if ($VMS_STATUS_SUCCESS(status)) {
13911             val_str[0] = _toupper(val_str[0]);
13912             if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
13913                 return 0;
13914         }
13915     }
13916
13917     index = decc$feature_get_index(name);
13918
13919     status = decc$feature_set_value(index, 1, value);
13920     if (index == -1 || (status == -1)) {
13921       return -1;
13922     }
13923
13924     status = decc$feature_get_value(index, 1);
13925     if (status != value) {
13926       return -1;
13927     }
13928
13929     /* Various things may check for an environment setting
13930      * rather than the feature directly, so set that too.
13931      */
13932     vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13933
13934     return 0;
13935 }
13936 #endif
13937
13938
13939 /* C RTL Feature settings */
13940
13941 #if defined(__DECC) || defined(__DECCXX)
13942
13943 #ifdef __cplusplus
13944 extern "C" {
13945 #endif
13946
13947 extern void
13948 vmsperl_set_features(void)
13949 {
13950     int status;
13951     int s;
13952     char val_str[10];
13953 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13954     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13955     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13956     unsigned long case_perm;
13957     unsigned long case_image;
13958 #endif
13959
13960     /* Allow an exception to bring Perl into the VMS debugger */
13961     vms_debug_on_exception = 0;
13962     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13963     if ($VMS_STATUS_SUCCESS(status)) {
13964        val_str[0] = _toupper(val_str[0]);
13965        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13966          vms_debug_on_exception = 1;
13967        else
13968          vms_debug_on_exception = 0;
13969     }
13970
13971     /* Debug unix/vms file translation routines */
13972     vms_debug_fileify = 0;
13973     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13974     if ($VMS_STATUS_SUCCESS(status)) {
13975         val_str[0] = _toupper(val_str[0]);
13976         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13977             vms_debug_fileify = 1;
13978         else
13979             vms_debug_fileify = 0;
13980     }
13981
13982
13983     /* Historically PERL has been doing vmsify / stat differently than */
13984     /* the CRTL.  In particular, under some conditions the CRTL will   */
13985     /* remove some illegal characters like spaces from filenames       */
13986     /* resulting in some differences.  The stat()/lstat() wrapper has  */
13987     /* been reporting such file names as invalid and fails to stat them */
13988     /* fixing this bug so that stat()/lstat() accept these like the     */
13989     /* CRTL does will result in several tests failing.                  */
13990     /* This should really be fixed, but for now, set up a feature to    */
13991     /* enable it so that the impact can be studied.                     */
13992     vms_bug_stat_filename = 0;
13993     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13994     if ($VMS_STATUS_SUCCESS(status)) {
13995         val_str[0] = _toupper(val_str[0]);
13996         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13997             vms_bug_stat_filename = 1;
13998         else
13999             vms_bug_stat_filename = 0;
14000     }
14001
14002
14003     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14004     vms_vtf7_filenames = 0;
14005     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14006     if ($VMS_STATUS_SUCCESS(status)) {
14007        val_str[0] = _toupper(val_str[0]);
14008        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14009          vms_vtf7_filenames = 1;
14010        else
14011          vms_vtf7_filenames = 0;
14012     }
14013
14014     /* unlink all versions on unlink() or rename() */
14015     vms_unlink_all_versions = 0;
14016     status = simple_trnlnm
14017         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14018     if ($VMS_STATUS_SUCCESS(status)) {
14019        val_str[0] = _toupper(val_str[0]);
14020        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14021          vms_unlink_all_versions = 1;
14022        else
14023          vms_unlink_all_versions = 0;
14024     }
14025
14026 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14027     /* Detect running under GNV Bash or other UNIX like shell */
14028     gnv_unix_shell = 0;
14029     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14030     if ($VMS_STATUS_SUCCESS(status)) {
14031          gnv_unix_shell = 1;
14032          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14033          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14034          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14035          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14036          vms_unlink_all_versions = 1;
14037          vms_posix_exit = 1;
14038     }
14039     /* Some reasonable defaults that are not CRTL defaults */
14040     set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14041     set_feature_default("DECC$ARGV_PARSE_STYLE", 1);     /* Requires extended parse. */
14042     set_feature_default("DECC$EFS_CHARSET", 1);
14043 #endif
14044
14045     /* hacks to see if known bugs are still present for testing */
14046
14047     /* PCP mode requires creating /dev/null special device file */
14048     decc_bug_devnull = 0;
14049     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14050     if ($VMS_STATUS_SUCCESS(status)) {
14051        val_str[0] = _toupper(val_str[0]);
14052        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14053           decc_bug_devnull = 1;
14054        else
14055           decc_bug_devnull = 0;
14056     }
14057
14058 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14059     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14060     if (s >= 0) {
14061         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14062         if (decc_disable_to_vms_logname_translation < 0)
14063             decc_disable_to_vms_logname_translation = 0;
14064     }
14065
14066     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14067     if (s >= 0) {
14068         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14069         if (decc_efs_case_preserve < 0)
14070             decc_efs_case_preserve = 0;
14071     }
14072
14073     s = decc$feature_get_index("DECC$EFS_CHARSET");
14074     decc_efs_charset_index = s;
14075     if (s >= 0) {
14076         decc_efs_charset = decc$feature_get_value(s, 1);
14077         if (decc_efs_charset < 0)
14078             decc_efs_charset = 0;
14079     }
14080
14081     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14082     if (s >= 0) {
14083         decc_filename_unix_report = decc$feature_get_value(s, 1);
14084         if (decc_filename_unix_report > 0) {
14085             decc_filename_unix_report = 1;
14086             vms_posix_exit = 1;
14087         }
14088         else
14089             decc_filename_unix_report = 0;
14090     }
14091
14092     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14093     if (s >= 0) {
14094         decc_filename_unix_only = decc$feature_get_value(s, 1);
14095         if (decc_filename_unix_only > 0) {
14096             decc_filename_unix_only = 1;
14097         }
14098         else {
14099             decc_filename_unix_only = 0;
14100         }
14101     }
14102
14103     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14104     if (s >= 0) {
14105         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14106         if (decc_filename_unix_no_version < 0)
14107             decc_filename_unix_no_version = 0;
14108     }
14109
14110     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14111     if (s >= 0) {
14112         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14113         if (decc_readdir_dropdotnotype < 0)
14114             decc_readdir_dropdotnotype = 0;
14115     }
14116
14117 #if __CRTL_VER >= 80200000
14118     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14119     if (s >= 0) {
14120         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14121         if (decc_posix_compliant_pathnames < 0)
14122             decc_posix_compliant_pathnames = 0;
14123         if (decc_posix_compliant_pathnames > 4)
14124             decc_posix_compliant_pathnames = 0;
14125     }
14126
14127 #endif
14128 #else
14129     status = simple_trnlnm
14130         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14131     if ($VMS_STATUS_SUCCESS(status)) {
14132         val_str[0] = _toupper(val_str[0]);
14133         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14134            decc_disable_to_vms_logname_translation = 1;
14135         }
14136     }
14137
14138 #ifndef __VAX
14139     status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14140     if ($VMS_STATUS_SUCCESS(status)) {
14141         val_str[0] = _toupper(val_str[0]);
14142         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14143            decc_efs_case_preserve = 1;
14144         }
14145     }
14146 #endif
14147
14148     status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14149     if ($VMS_STATUS_SUCCESS(status)) {
14150         val_str[0] = _toupper(val_str[0]);
14151         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14152            decc_filename_unix_report = 1;
14153         }
14154     }
14155     status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14156     if ($VMS_STATUS_SUCCESS(status)) {
14157         val_str[0] = _toupper(val_str[0]);
14158         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14159            decc_filename_unix_only = 1;
14160            decc_filename_unix_report = 1;
14161         }
14162     }
14163     status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14164     if ($VMS_STATUS_SUCCESS(status)) {
14165         val_str[0] = _toupper(val_str[0]);
14166         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14167            decc_filename_unix_no_version = 1;
14168         }
14169     }
14170     status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14171     if ($VMS_STATUS_SUCCESS(status)) {
14172         val_str[0] = _toupper(val_str[0]);
14173         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14174            decc_readdir_dropdotnotype = 1;
14175         }
14176     }
14177 #endif
14178
14179 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14180
14181      /* Report true case tolerance */
14182     /*----------------------------*/
14183     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14184     if (!$VMS_STATUS_SUCCESS(status))
14185         case_perm = PPROP$K_CASE_BLIND;
14186     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14187     if (!$VMS_STATUS_SUCCESS(status))
14188         case_image = PPROP$K_CASE_BLIND;
14189     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14190         (case_image == PPROP$K_CASE_SENSITIVE))
14191         vms_process_case_tolerant = 0;
14192
14193 #endif
14194
14195     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14196     /* for strict backward compatibility */
14197     status = simple_trnlnm
14198         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14199     if ($VMS_STATUS_SUCCESS(status)) {
14200        val_str[0] = _toupper(val_str[0]);
14201        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14202          vms_posix_exit = 1;
14203        else
14204          vms_posix_exit = 0;
14205     }
14206 }
14207
14208 /* Use 32-bit pointers because that's what the image activator
14209  * assumes for the LIB$INITIALZE psect.
14210  */
14211 #if __INITIAL_POINTER_SIZE
14212 #pragma pointer_size save
14213 #pragma pointer_size 32
14214 #endif
14215
14216 /* Create a reference to the LIB$INITIALIZE function. */
14217 extern void LIB$INITIALIZE(void);
14218 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14219
14220 /* Create an array of pointers to the init functions in the special
14221  * LIB$INITIALIZE section. In our case, the array only has one entry.
14222  */
14223 #pragma extern_model save
14224 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
14225 extern void (* const vmsperl_unused_global_2[])() =
14226 {
14227    vmsperl_set_features,
14228 };
14229 #pragma extern_model restore
14230
14231 #if __INITIAL_POINTER_SIZE
14232 #pragma pointer_size restore
14233 #endif
14234
14235 #ifdef __cplusplus
14236 }
14237 #endif
14238
14239 #endif /* defined(__DECC) || defined(__DECCXX) */
14240 /*  End of vms.c */