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 /* Routine to remove the 2-byte prefix from the translation of a
 882  * process-permanent file (PPF).
 883  */
 884 static inline unsigned short int
 885 S_remove_ppf_prefix(const char *lnm, char *eqv, unsigned short int eqvlen)
 886 {
 887     if (*((int *)lnm) == *((int *)"SYS$")                    &&
 888         eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00      &&
 889         ( (lnm[4] == 'O' && !strcmp(lnm,"SYS$OUTPUT"))  ||
 890           (lnm[4] == 'I' && !strcmp(lnm,"SYS$INPUT"))   ||
 891           (lnm[4] == 'E' && !strcmp(lnm,"SYS$ERROR"))   ||
 892           (lnm[4] == 'C' && !strcmp(lnm,"SYS$COMMAND")) )  ) {
 893
 894         memmove(eqv, eqv+4, eqvlen-4);
 895         eqvlen -= 4;
 896     }
 897     return eqvlen;
 898 }
 899
 900 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 901 int
 902 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 903   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 904 {
 905     const char *cp1;
 906     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 907     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 908     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 909     int midx;
 910     unsigned char acmode;
 911     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 912                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 913     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 914                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 915                                  {0, 0, 0, 0}};
 916     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 917 #if defined(PERL_IMPLICIT_CONTEXT)
 918     pTHX = NULL;
 919     if (PL_curinterp) {
 920       aTHX = PERL_GET_INTERP;
 921     } else {
 922       aTHX = NULL;
 923     }
 924 #endif
 925
 926     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 927       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 928     }
 929     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 930       *cp2 = _toupper(*cp1);
 931       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 932         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 933         return 0;
 934       }
 935     }
 936     lnmdsc.dsc$w_length = cp1 - lnm;
 937     lnmdsc.dsc$a_pointer = uplnm;
 938     uplnm[lnmdsc.dsc$w_length] = '\0';
 939     secure = flags & PERL__TRNENV_SECURE;
 940     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 941     if (!tabvec || !*tabvec) tabvec = env_tables;
 942
 943     for (curtab = 0; tabvec[curtab]; curtab++) {
 944       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 945         if (!ivenv && !secure) {
 946           char *eq;
 947           int i;
 948           if (!environ) {
 949             ivenv = 1;
 950 #if defined(PERL_IMPLICIT_CONTEXT)
 951             if (aTHX == NULL) {
 952                 fprintf(stderr,
 953                     "Can't read CRTL environ\n");
 954             } else
 955 #endif
 956                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 957             continue;
 958           }
 959           retsts = SS$_NOLOGNAM;
 960           for (i = 0; environ[i]; i++) {
 961             if ((eq = strchr(environ[i],'=')) &&
 962                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 963                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 964               eq++;
 965               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 966               if (!eqvlen) continue;
 967               retsts = SS$_NORMAL;
 968               break;
 969             }
 970           }
 971           if (retsts != SS$_NOLOGNAM) break;
 972         }
 973       }
 974       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 975                !str$case_blind_compare(&tmpdsc,&clisym)) {
 976         if (!ivsym && !secure) {
 977           unsigned short int deflen = LNM$C_NAMLENGTH;
 978           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 979           /* dynamic dsc to accommodate possible long value */
 980           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 981           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 982           if (retsts & 1) {
 983             if (eqvlen > MAX_DCL_SYMBOL) {
 984               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 985               eqvlen = MAX_DCL_SYMBOL;
 986               /* Special hack--we might be called before the interpreter's */
 987               /* fully initialized, in which case either thr or PL_curcop */
 988               /* might be bogus. We have to check, since ckWARN needs them */
 989               /* both to be valid if running threaded */
 990 #if defined(PERL_IMPLICIT_CONTEXT)
 991               if (aTHX == NULL) {
 992                   fprintf(stderr,
 993                      "Value of CLI symbol \"%s\" too long",lnm);
 994               } else
 995 #endif
 996                 if (ckWARN(WARN_MISC)) {
 997                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 998                 }
 999             }
1000             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1001           }
1002           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1003           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1004           if (retsts == LIB$_NOSUCHSYM) continue;
1005           break;
1006         }
1007       }
1008       else if (!ivlnm) {
1009         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1010           midx = my_maxidx(lnm);
1011           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1012             lnmlst[1].bufadr = cp2;
1013             eqvlen = 0;
1014             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1015             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1016             if (retsts == SS$_NOLOGNAM) break;
1017             eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
1018             cp2 += eqvlen;
1019             *cp2 = '\0';
1020           }
1021           if ((retsts == SS$_IVLOGNAM) ||
1022               (retsts == SS$_NOLOGNAM)) { continue; }
1023           eqvlen = strlen(eqv);
1024         }
1025         else {
1026           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1027           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1028           if (retsts == SS$_NOLOGNAM) continue;
1029           eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
1030           eqv[eqvlen] = '\0';
1031         }
1032         break;
1033       }
1034     }
1035     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1036     else if (retsts == LIB$_NOSUCHSYM ||
1037              retsts == SS$_NOLOGNAM) {
1038      /* Unsuccessful lookup is normal -- no need to set errno */
1039      return 0;
1040     }
1041     else if (retsts == LIB$_INVSYMNAM ||
1042              retsts == SS$_IVLOGNAM   ||
1043              retsts == SS$_IVLOGTAB) {
1044       set_errno(EINVAL);  set_vaxc_errno(retsts);
1045     }
1046     else _ckvmssts_noperl(retsts);
1047     return 0;
1048 }  /* end of vmstrnenv */
1049 /*}}}*/
1050
1051 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1052 /* Define as a function so we can access statics. */
1053 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1054 {
1055     int flags = 0;
1056
1057 #if defined(PERL_IMPLICIT_CONTEXT)
1058     if (aTHX != NULL)
1059 #endif
1060 #ifdef SECURE_INTERNAL_GETENV
1061         flags = (PL_curinterp ? TAINTING_get : will_taint) ?
1062                  PERL__TRNENV_SECURE : 0;
1063 #endif
1064
1065     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1066 }
1067 /*}}}*/
1068
1069 /* my_getenv
1070  * Note: Uses Perl temp to store result so char * can be returned to
1071  * caller; this pointer will be invalidated at next Perl statement
1072  * transition.
1073  * We define this as a function rather than a macro in terms of my_getenv_len()
1074  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1075  * allocate SVs).
1076  */
1077 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1078 char *
1079 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1080 {
1081     const char *cp1;
1082     static char *__my_getenv_eqv = NULL;
1083     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1084     unsigned long int idx = 0;
1085     int success, secure;
1086     int midx, flags;
1087     SV *tmpsv;
1088
1089     midx = my_maxidx(lnm) + 1;
1090
1091     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1092       /* Set up a temporary buffer for the return value; Perl will
1093        * clean it up at the next statement transition */
1094       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1095       if (!tmpsv) return NULL;
1096       eqv = SvPVX(tmpsv);
1097     }
1098     else {
1099       /* Assume no interpreter ==> single thread */
1100       if (__my_getenv_eqv != NULL) {
1101         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1102       }
1103       else {
1104         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1105       }
1106       eqv = __my_getenv_eqv;
1107     }
1108
1109     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1110     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1111       int len;
1112       getcwd(eqv,LNM$C_NAMLENGTH);
1113
1114       len = strlen(eqv);
1115
1116       /* Get rid of "000000/ in rooted filespecs */
1117       if (len > 7) {
1118         char * zeros;
1119         zeros = strstr(eqv, "/000000/");
1120         if (zeros != NULL) {
1121           int mlen;
1122           mlen = len - (zeros - eqv) - 7;
1123           memmove(zeros, &zeros[7], mlen);
1124           len = len - 7;
1125           eqv[len] = '\0';
1126         }
1127       }
1128       return eqv;
1129     }
1130     else {
1131       /* Impose security constraints only if tainting */
1132       if (sys) {
1133         /* Impose security constraints only if tainting */
1134         secure = PL_curinterp ? TAINTING_get : will_taint;
1135       }
1136       else {
1137         secure = 0;
1138       }
1139
1140       flags =
1141 #ifdef SECURE_INTERNAL_GETENV
1142               secure ? PERL__TRNENV_SECURE : 0
1143 #else
1144               0
1145 #endif
1146       ;
1147
1148       /* For the getenv interface we combine all the equivalence names
1149        * of a search list logical into one value to acquire a maximum
1150        * value length of 255*128 (assuming %ENV is using logicals).
1151        */
1152       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1153
1154       /* If the name contains a semicolon-delimited index, parse it
1155        * off and make sure we only retrieve the equivalence name for
1156        * that index.  */
1157       if ((cp2 = strchr(lnm,';')) != NULL) {
1158         my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1159         idx = strtoul(cp2+1,NULL,0);
1160         lnm = uplnm;
1161         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1162       }
1163
1164       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1165
1166       return success ? eqv : NULL;
1167     }
1168
1169 }  /* end of my_getenv() */
1170 /*}}}*/
1171
1172
1173 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1174 char *
1175 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1176 {
1177     const char *cp1;
1178     char *buf, *cp2;
1179     unsigned long idx = 0;
1180     int midx, flags;
1181     static char *__my_getenv_len_eqv = NULL;
1182     int secure;
1183     SV *tmpsv;
1184
1185     midx = my_maxidx(lnm) + 1;
1186
1187     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1188       /* Set up a temporary buffer for the return value; Perl will
1189        * clean it up at the next statement transition */
1190       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1191       if (!tmpsv) return NULL;
1192       buf = SvPVX(tmpsv);
1193     }
1194     else {
1195       /* Assume no interpreter ==> single thread */
1196       if (__my_getenv_len_eqv != NULL) {
1197         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1198       }
1199       else {
1200         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1201       }
1202       buf = __my_getenv_len_eqv;
1203     }
1204
1205     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1206     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1207     char * zeros;
1208
1209       getcwd(buf,LNM$C_NAMLENGTH);
1210       *len = strlen(buf);
1211
1212       /* Get rid of "000000/ in rooted filespecs */
1213       if (*len > 7) {
1214       zeros = strstr(buf, "/000000/");
1215       if (zeros != NULL) {
1216         int mlen;
1217         mlen = *len - (zeros - buf) - 7;
1218         memmove(zeros, &zeros[7], mlen);
1219         *len = *len - 7;
1220         buf[*len] = '\0';
1221         }
1222       }
1223       return buf;
1224     }
1225     else {
1226       if (sys) {
1227         /* Impose security constraints only if tainting */
1228         secure = PL_curinterp ? TAINTING_get : will_taint;
1229       }
1230       else {
1231         secure = 0;
1232       }
1233
1234       flags =
1235 #ifdef SECURE_INTERNAL_GETENV
1236               secure ? PERL__TRNENV_SECURE : 0
1237 #else
1238               0
1239 #endif
1240       ;
1241
1242       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1243
1244       if ((cp2 = strchr(lnm,';')) != NULL) {
1245         my_strlcpy(buf, lnm, cp2 - lnm + 1);
1246         idx = strtoul(cp2+1,NULL,0);
1247         lnm = buf;
1248         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1249       }
1250
1251       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1252
1253       /* Get rid of "000000/ in rooted filespecs */
1254       if (*len > 7) {
1255       char * zeros;
1256         zeros = strstr(buf, "/000000/");
1257         if (zeros != NULL) {
1258           int mlen;
1259           mlen = *len - (zeros - buf) - 7;
1260           memmove(zeros, &zeros[7], mlen);
1261           *len = *len - 7;
1262           buf[*len] = '\0';
1263         }
1264       }
1265
1266       return *len ? buf : NULL;
1267     }
1268
1269 }  /* end of my_getenv_len() */
1270 /*}}}*/
1271
1272 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1273
1274 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1275
1276 /*{{{ void prime_env_iter() */
1277 void
1278 prime_env_iter(void)
1279 /* Fill the %ENV associative array with all logical names we can
1280  * find, in preparation for iterating over it.
1281  */
1282 {
1283   static int primed = 0;
1284   HV *seenhv = NULL, *envhv;
1285   SV *sv = NULL;
1286   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1287   unsigned short int chan;
1288 #ifndef CLI$M_TRUSTED
1289 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1290 #endif
1291   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1292   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1293   long int i;
1294   bool have_sym = FALSE, have_lnm = FALSE;
1295   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1296   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1297   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1298   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1299   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1300 #if defined(PERL_IMPLICIT_CONTEXT)
1301   pTHX;
1302 #endif
1303 #if defined(USE_ITHREADS)
1304   static perl_mutex primenv_mutex;
1305   MUTEX_INIT(&primenv_mutex);
1306 #endif
1307
1308 #if defined(PERL_IMPLICIT_CONTEXT)
1309     /* We jump through these hoops because we can be called at */
1310     /* platform-specific initialization time, which is before anything is */
1311     /* set up--we can't even do a plain dTHX since that relies on the */
1312     /* interpreter structure to be initialized */
1313     if (PL_curinterp) {
1314       aTHX = PERL_GET_INTERP;
1315     } else {
1316       /* we never get here because the NULL pointer will cause the */
1317       /* several of the routines called by this routine to access violate */
1318
1319       /* This routine is only called by hv.c/hv_iterinit which has a */
1320       /* context, so the real fix may be to pass it through instead of */
1321       /* the hoops above */
1322       aTHX = NULL;
1323     }
1324 #endif
1325
1326   if (primed || !PL_envgv) return;
1327   MUTEX_LOCK(&primenv_mutex);
1328   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1329   envhv = GvHVn(PL_envgv);
1330   /* Perform a dummy fetch as an lval to insure that the hash table is
1331    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1332   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1333
1334   for (i = 0; env_tables[i]; i++) {
1335      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1336          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1337      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1338   }
1339   if (have_sym || have_lnm) {
1340     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1341     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1342     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1343     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1344   }
1345
1346   for (i--; i >= 0; i--) {
1347     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1348       char *start;
1349       int j;
1350       for (j = 0; environ[j]; j++) {
1351         if (!(start = strchr(environ[j],'='))) {
1352           if (ckWARN(WARN_INTERNAL))
1353             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1354         }
1355         else {
1356           start++;
1357           sv = newSVpv(start,0);
1358           SvTAINTED_on(sv);
1359           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1360         }
1361       }
1362       continue;
1363     }
1364     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1365              !str$case_blind_compare(&tmpdsc,&clisym)) {
1366       my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1367       cmddsc.dsc$w_length = 20;
1368       if (env_tables[i]->dsc$w_length == 12 &&
1369           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1370           !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local  *", sizeof(cmd)-12);
1371       flags = defflags | CLI$M_NOLOGNAM;
1372     }
1373     else {
1374       my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1375       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1376         my_strlcat(cmd," /Table=", sizeof(cmd));
1377         cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, sizeof(cmd));
1378       }
1379       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1380       flags = defflags | CLI$M_NOCLISYM;
1381     }
1382
1383     /* Create a new subprocess to execute each command, to exclude the
1384      * remote possibility that someone could subvert a mbx or file used
1385      * to write multiple commands to a single subprocess.
1386      */
1387     do {
1388       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1389                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1390       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1391       defflags &= ~CLI$M_TRUSTED;
1392     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1393     _ckvmssts(retsts);
1394     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1395     if (seenhv) SvREFCNT_dec(seenhv);
1396     seenhv = newHV();
1397     while (1) {
1398       char *cp1, *cp2, *key;
1399       unsigned long int sts, iosb[2], retlen, keylen;
1400       U32 hash;
1401
1402       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1403       if (sts & 1) sts = iosb[0] & 0xffff;
1404       if (sts == SS$_ENDOFFILE) {
1405         int wakect = 0;
1406         while (substs == 0) { sys$hiber(); wakect++;}
1407         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1408         _ckvmssts(substs);
1409         break;
1410       }
1411       _ckvmssts(sts);
1412       retlen = iosb[0] >> 16;
1413       if (!retlen) continue;  /* blank line */
1414       buf[retlen] = '\0';
1415       if (iosb[1] != subpid) {
1416         if (iosb[1]) {
1417           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1418         }
1419         continue;
1420       }
1421       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1422         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1423
1424       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1425       if (*cp1 == '(' || /* Logical name table name */
1426           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1427       if (*cp1 == '"') cp1++;
1428       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1429       key = cp1;  keylen = cp2 - cp1;
1430       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1431       while (*cp2 && *cp2 != '=') cp2++;
1432       while (*cp2 && *cp2 == '=') cp2++;
1433       while (*cp2 && *cp2 == ' ') cp2++;
1434       if (*cp2 == '"') {  /* String translation; may embed "" */
1435         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1436         cp2++;  cp1--; /* Skip "" surrounding translation */
1437       }
1438       else {  /* Numeric translation */
1439         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1440         cp1--;  /* stop on last non-space char */
1441       }
1442       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1443         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1444         continue;
1445       }
1446       PERL_HASH(hash,key,keylen);
1447
1448       if (cp1 == cp2 && *cp2 == '.') {
1449         /* A single dot usually means an unprintable character, such as a null
1450          * to indicate a zero-length value.  Get the actual value to make sure.
1451          */
1452         char lnm[LNM$C_NAMLENGTH+1];
1453         char eqv[MAX_DCL_SYMBOL+1];
1454         int trnlen;
1455         strncpy(lnm, key, keylen);
1456         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1457         sv = newSVpvn(eqv, strlen(eqv));
1458       }
1459       else {
1460         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1461       }
1462
1463       SvTAINTED_on(sv);
1464       hv_store(envhv,key,keylen,sv,hash);
1465       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1466     }
1467     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1468       /* get the PPFs for this process, not the subprocess */
1469       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1470       char eqv[LNM$C_NAMLENGTH+1];
1471       int trnlen, i;
1472       for (i = 0; ppfs[i]; i++) {
1473         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1474         sv = newSVpv(eqv,trnlen);
1475         SvTAINTED_on(sv);
1476         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1477       }
1478     }
1479   }
1480   primed = 1;
1481   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1482   if (buf) Safefree(buf);
1483   if (seenhv) SvREFCNT_dec(seenhv);
1484   MUTEX_UNLOCK(&primenv_mutex);
1485   return;
1486
1487 }  /* end of prime_env_iter */
1488 /*}}}*/
1489
1490
1491 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1492 /* Define or delete an element in the same "environment" as
1493  * vmstrnenv().  If an element is to be deleted, it's removed from
1494  * the first place it's found.  If it's to be set, it's set in the
1495  * place designated by the first element of the table vector.
1496  * Like setenv() returns 0 for success, non-zero on error.
1497  */
1498 int
1499 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1500 {
1501     const char *cp1;
1502     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1503     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1504     int nseg = 0, j;
1505     unsigned long int retsts, usermode = PSL$C_USER;
1506     struct itmlst_3 *ile, *ilist;
1507     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1508                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1509                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1510     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1511     $DESCRIPTOR(local,"_LOCAL");
1512
1513     if (!lnm) {
1514         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1515         return SS$_IVLOGNAM;
1516     }
1517
1518     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1519       *cp2 = _toupper(*cp1);
1520       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1521         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1522         return SS$_IVLOGNAM;
1523       }
1524     }
1525     lnmdsc.dsc$w_length = cp1 - lnm;
1526     if (!tabvec || !*tabvec) tabvec = env_tables;
1527
1528     if (!eqv) {  /* we're deleting n element */
1529       for (curtab = 0; tabvec[curtab]; curtab++) {
1530         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1531         int i;
1532           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1533             if ((cp1 = strchr(environ[i],'=')) &&
1534                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1535                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1536 #ifdef HAS_SETENV
1537               return setenv(lnm,"",1) ? vaxc$errno : 0;
1538             }
1539           }
1540           ivenv = 1; retsts = SS$_NOLOGNAM;
1541 #else
1542               if (ckWARN(WARN_INTERNAL))
1543                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1544               ivenv = 1; retsts = SS$_NOSUCHPGM;
1545               break;
1546             }
1547           }
1548 #endif
1549         }
1550         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1551                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1552           unsigned int symtype;
1553           if (tabvec[curtab]->dsc$w_length == 12 &&
1554               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1555               !str$case_blind_compare(&tmpdsc,&local))
1556             symtype = LIB$K_CLI_LOCAL_SYM;
1557           else symtype = LIB$K_CLI_GLOBAL_SYM;
1558           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1559           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1560           if (retsts == LIB$_NOSUCHSYM) continue;
1561           break;
1562         }
1563         else if (!ivlnm) {
1564           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1565           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1566           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1567           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1568           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1569         }
1570       }
1571     }
1572     else {  /* we're defining a value */
1573       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1574 #ifdef HAS_SETENV
1575         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1576 #else
1577         if (ckWARN(WARN_INTERNAL))
1578           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1579         retsts = SS$_NOSUCHPGM;
1580 #endif
1581       }
1582       else {
1583         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1584         eqvdsc.dsc$w_length  = strlen(eqv);
1585         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1586             !str$case_blind_compare(&tmpdsc,&clisym)) {
1587           unsigned int symtype;
1588           if (tabvec[0]->dsc$w_length == 12 &&
1589               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1590                !str$case_blind_compare(&tmpdsc,&local))
1591             symtype = LIB$K_CLI_LOCAL_SYM;
1592           else symtype = LIB$K_CLI_GLOBAL_SYM;
1593           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1594         }
1595         else {
1596           if (!*eqv) eqvdsc.dsc$w_length = 1;
1597           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1598
1599             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1600             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1601               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1602                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1603               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1604               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1605             }
1606
1607             Newx(ilist,nseg+1,struct itmlst_3);
1608             ile = ilist;
1609             if (!ile) {
1610               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1611               return SS$_INSFMEM;
1612             }
1613             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1614
1615             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1616               ile->itmcode = LNM$_STRING;
1617               ile->bufadr = c;
1618               if ((j+1) == nseg) {
1619                 ile->buflen = strlen(c);
1620                 /* in case we are truncating one that's too long */
1621                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1622               }
1623               else {
1624                 ile->buflen = LNM$C_NAMLENGTH;
1625               }
1626             }
1627
1628             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1629             Safefree (ilist);
1630           }
1631           else {
1632             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1633           }
1634         }
1635       }
1636     }
1637     if (!(retsts & 1)) {
1638       switch (retsts) {
1639         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1640         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1641           set_errno(EVMSERR); break;
1642         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1643         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1644           set_errno(EINVAL); break;
1645         case SS$_NOPRIV:
1646           set_errno(EACCES); break;
1647         default:
1648           _ckvmssts(retsts);
1649           set_errno(EVMSERR);
1650        }
1651        set_vaxc_errno(retsts);
1652        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1653     }
1654     else {
1655       /* We reset error values on success because Perl does an hv_fetch()
1656        * before each hv_store(), and if the thing we're setting didn't
1657        * previously exist, we've got a leftover error message.  (Of course,
1658        * this fails in the face of
1659        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1660        * in that the error reported in $! isn't spurious,
1661        * but it's right more often than not.)
1662        */
1663       set_errno(0); set_vaxc_errno(retsts);
1664       return 0;
1665     }
1666
1667 }  /* end of vmssetenv() */
1668 /*}}}*/
1669
1670 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1671 /* This has to be a function since there's a prototype for it in proto.h */
1672 void
1673 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1674 {
1675     if (lnm && *lnm) {
1676       int len = strlen(lnm);
1677       if  (len == 7) {
1678         char uplnm[8];
1679         int i;
1680         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1681         if (!strcmp(uplnm,"DEFAULT")) {
1682           if (eqv && *eqv) my_chdir(eqv);
1683           return;
1684         }
1685     }
1686   }
1687   (void) vmssetenv(lnm,eqv,NULL);
1688 }
1689 /*}}}*/
1690
1691 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1692 /*  vmssetuserlnm
1693  *  sets a user-mode logical in the process logical name table
1694  *  used for redirection of sys$error
1695  */
1696 void
1697 Perl_vmssetuserlnm(const char *name, const char *eqv)
1698 {
1699     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1700     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1701     unsigned long int iss, attr = LNM$M_CONFINE;
1702     unsigned char acmode = PSL$C_USER;
1703     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1704                                  {0, 0, 0, 0}};
1705     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1706     d_name.dsc$w_length = strlen(name);
1707
1708     lnmlst[0].buflen = strlen(eqv);
1709     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1710
1711     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1712     if (!(iss&1)) lib$signal(iss);
1713 }
1714 /*}}}*/
1715
1716
1717 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1718 /* my_crypt - VMS password hashing
1719  * my_crypt() provides an interface compatible with the Unix crypt()
1720  * C library function, and uses sys$hash_password() to perform VMS
1721  * password hashing.  The quadword hashed password value is returned
1722  * as a NUL-terminated 8 character string.  my_crypt() does not change
1723  * the case of its string arguments; in order to match the behavior
1724  * of LOGINOUT et al., alphabetic characters in both arguments must
1725  *  be upcased by the caller.
1726  *
1727  * - fix me to call ACM services when available
1728  */
1729 char *
1730 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1731 {
1732 #   ifndef UAI$C_PREFERRED_ALGORITHM
1733 #     define UAI$C_PREFERRED_ALGORITHM 127
1734 #   endif
1735     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1736     unsigned short int salt = 0;
1737     unsigned long int sts;
1738     struct const_dsc {
1739         unsigned short int dsc$w_length;
1740         unsigned char      dsc$b_type;
1741         unsigned char      dsc$b_class;
1742         const char *       dsc$a_pointer;
1743     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1744        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1745     struct itmlst_3 uailst[3] = {
1746         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1747         { sizeof salt, UAI$_SALT,    &salt, 0},
1748         { 0,           0,            NULL,  NULL}};
1749     static char hash[9];
1750
1751     usrdsc.dsc$w_length = strlen(usrname);
1752     usrdsc.dsc$a_pointer = usrname;
1753     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1754       switch (sts) {
1755         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1756           set_errno(EACCES);
1757           break;
1758         case RMS$_RNF:
1759           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1760           break;
1761         default:
1762           set_errno(EVMSERR);
1763       }
1764       set_vaxc_errno(sts);
1765       if (sts != RMS$_RNF) return NULL;
1766     }
1767
1768     txtdsc.dsc$w_length = strlen(textpasswd);
1769     txtdsc.dsc$a_pointer = textpasswd;
1770     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1771       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1772     }
1773
1774     return (char *) hash;
1775
1776 }  /* end of my_crypt() */
1777 /*}}}*/
1778
1779
1780 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1781 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1782 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1783
1784 /* fixup barenames that are directories for internal use.
1785  * There have been problems with the consistent handling of UNIX
1786  * style directory names when routines are presented with a name that
1787  * has no directory delimiters at all.  So this routine will eventually
1788  * fix the issue.
1789  */
1790 static char * fixup_bare_dirnames(const char * name)
1791 {
1792   if (decc_disable_to_vms_logname_translation) {
1793 /* fix me */
1794   }
1795   return NULL;
1796 }
1797
1798 /* 8.3, remove() is now broken on symbolic links */
1799 static int rms_erase(const char * vmsname);
1800
1801
1802 /* mp_do_kill_file
1803  * A little hack to get around a bug in some implementation of remove()
1804  * that do not know how to delete a directory
1805  *
1806  * Delete any file to which user has control access, regardless of whether
1807  * delete access is explicitly allowed.
1808  * Limitations: User must have write access to parent directory.
1809  *              Does not block signals or ASTs; if interrupted in midstream
1810  *              may leave file with an altered ACL.
1811  * HANDLE WITH CARE!
1812  */
1813 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1814 static int
1815 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1816 {
1817     char *vmsname;
1818     char *rslt;
1819     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1820     unsigned long int cxt = 0, aclsts, fndsts;
1821     int rmsts = -1;
1822     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1823     struct myacedef {
1824       unsigned char myace$b_length;
1825       unsigned char myace$b_type;
1826       unsigned short int myace$w_flags;
1827       unsigned long int myace$l_access;
1828       unsigned long int myace$l_ident;
1829     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1830                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1831       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1832      struct itmlst_3
1833        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1834                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1835        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1836        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1837        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1838        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1839
1840     /* Expand the input spec using RMS, since the CRTL remove() and
1841      * system services won't do this by themselves, so we may miss
1842      * a file "hiding" behind a logical name or search list. */
1843     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1844     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1845
1846     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1847     if (rslt == NULL) {
1848         PerlMem_free(vmsname);
1849         return -1;
1850       }
1851
1852     /* Erase the file */
1853     rmsts = rms_erase(vmsname);
1854
1855     /* Did it succeed */
1856     if ($VMS_STATUS_SUCCESS(rmsts)) {
1857         PerlMem_free(vmsname);
1858         return 0;
1859       }
1860
1861     /* If not, can changing protections help? */
1862     if (rmsts != RMS$_PRV) {
1863       set_vaxc_errno(rmsts);
1864       PerlMem_free(vmsname);
1865       return -1;
1866     }
1867
1868     /* No, so we get our own UIC to use as a rights identifier,
1869      * and the insert an ACE at the head of the ACL which allows us
1870      * to delete the file.
1871      */
1872     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1873     fildsc.dsc$w_length = strlen(vmsname);
1874     fildsc.dsc$a_pointer = vmsname;
1875     cxt = 0;
1876     newace.myace$l_ident = oldace.myace$l_ident;
1877     rmsts = -1;
1878     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1879       switch (aclsts) {
1880         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1881           set_errno(ENOENT); break;
1882         case RMS$_DIR:
1883           set_errno(ENOTDIR); break;
1884         case RMS$_DEV:
1885           set_errno(ENODEV); break;
1886         case RMS$_SYN: case SS$_INVFILFOROP:
1887           set_errno(EINVAL); break;
1888         case RMS$_PRV:
1889           set_errno(EACCES); break;
1890         default:
1891           _ckvmssts_noperl(aclsts);
1892       }
1893       set_vaxc_errno(aclsts);
1894       PerlMem_free(vmsname);
1895       return -1;
1896     }
1897     /* Grab any existing ACEs with this identifier in case we fail */
1898     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1899     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1900                     || fndsts == SS$_NOMOREACE ) {
1901       /* Add the new ACE . . . */
1902       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1903         goto yourroom;
1904
1905       rmsts = rms_erase(vmsname);
1906       if ($VMS_STATUS_SUCCESS(rmsts)) {
1907         rmsts = 0;
1908         }
1909         else {
1910         rmsts = -1;
1911         /* We blew it - dir with files in it, no write priv for
1912          * parent directory, etc.  Put things back the way they were. */
1913         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1914           goto yourroom;
1915         if (fndsts & 1) {
1916           addlst[0].bufadr = &oldace;
1917           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1918             goto yourroom;
1919         }
1920       }
1921     }
1922
1923     yourroom:
1924     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1925     /* We just deleted it, so of course it's not there.  Some versions of
1926      * VMS seem to return success on the unlock operation anyhow (after all
1927      * the unlock is successful), but others don't.
1928      */
1929     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1930     if (aclsts & 1) aclsts = fndsts;
1931     if (!(aclsts & 1)) {
1932       set_errno(EVMSERR);
1933       set_vaxc_errno(aclsts);
1934     }
1935
1936     PerlMem_free(vmsname);
1937     return rmsts;
1938
1939 }  /* end of kill_file() */
1940 /*}}}*/
1941
1942
1943 /*{{{int do_rmdir(char *name)*/
1944 int
1945 Perl_do_rmdir(pTHX_ const char *name)
1946 {
1947     char * dirfile;
1948     int retval;
1949     Stat_t st;
1950
1951     /* lstat returns a VMS fileified specification of the name */
1952     /* that is looked up, and also lets verifies that this is a directory */
1953
1954     retval = flex_lstat(name, &st);
1955     if (retval != 0) {
1956         char * ret_spec;
1957
1958         /* Due to a historical feature, flex_stat/lstat can not see some */
1959         /* Unix format file names that the rest of the CRTL can see */
1960         /* Fixing that feature will cause some perl tests to fail */
1961         /* So try this one more time. */
1962
1963         retval = lstat(name, &st.crtl_stat);
1964         if (retval != 0)
1965             return -1;
1966
1967         /* force it to a file spec for the kill file to work. */
1968         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1969         if (ret_spec == NULL) {
1970             errno = EIO;
1971             return -1;
1972         }
1973     }
1974
1975     if (!S_ISDIR(st.st_mode)) {
1976         errno = ENOTDIR;
1977         retval = -1;
1978     }
1979     else {
1980         dirfile = st.st_devnam;
1981
1982         /* It may be possible for flex_stat to find a file and vmsify() to */
1983         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
1984         /* with that case, so fail it */
1985         if (dirfile[0] == 0) {
1986             errno = EIO;
1987             return -1;
1988         }
1989
1990         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1991     }
1992
1993     return retval;
1994
1995 }  /* end of do_rmdir */
1996 /*}}}*/
1997
1998 /* kill_file
1999  * Delete any file to which user has control access, regardless of whether
2000  * delete access is explicitly allowed.
2001  * Limitations: User must have write access to parent directory.
2002  *              Does not block signals or ASTs; if interrupted in midstream
2003  *              may leave file with an altered ACL.
2004  * HANDLE WITH CARE!
2005  */
2006 /*{{{int kill_file(char *name)*/
2007 int
2008 Perl_kill_file(pTHX_ const char *name)
2009 {
2010     char * vmsfile;
2011     Stat_t st;
2012     int rmsts;
2013
2014     /* Convert the filename to VMS format and see if it is a directory */
2015     /* flex_lstat returns a vmsified file specification */
2016     rmsts = flex_lstat(name, &st);
2017     if (rmsts != 0) {
2018
2019         /* Due to a historical feature, flex_stat/lstat can not see some */
2020         /* Unix format file names that the rest of the CRTL can see when */
2021         /* ODS-2 file specifications are in use. */
2022         /* Fixing that feature will cause some perl tests to fail */
2023         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2024         st.st_mode = 0;
2025         vmsfile = (char *) name; /* cast ok */
2026
2027     } else {
2028         vmsfile = st.st_devnam;
2029         if (vmsfile[0] == 0) {
2030             /* It may be possible for flex_stat to find a file and vmsify() */
2031             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2032             /* deal with that case, so fail it */
2033             errno = EIO;
2034             return -1;
2035         }
2036     }
2037
2038     /* Remove() is allowed to delete directories, according to the X/Open
2039      * specifications.
2040      * This may need special handling to work with the ACL hacks.
2041      */
2042     if (S_ISDIR(st.st_mode)) {
2043         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2044         return rmsts;
2045     }
2046
2047     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2048
2049     /* Need to delete all versions ? */
2050     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2051         int i = 0;
2052
2053         /* Just use lstat() here as do not need st_dev */
2054         /* and we know that the file is in VMS format or that */
2055         /* because of a historical bug, flex_stat can not see the file */
2056         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2057             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2058             if (rmsts != 0)
2059                 break;
2060             i++;
2061
2062             /* Make sure that we do not loop forever */
2063             if (i > 32767) {
2064                 errno = EIO;
2065                 rmsts = -1;
2066                 break;
2067             }
2068         }
2069     }
2070
2071     return rmsts;
2072
2073 }  /* end of kill_file() */
2074 /*}}}*/
2075
2076
2077 /*{{{int my_mkdir(char *,Mode_t)*/
2078 int
2079 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2080 {
2081   STRLEN dirlen = strlen(dir);
2082
2083   /* zero length string sometimes gives ACCVIO */
2084   if (dirlen == 0) return -1;
2085
2086   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2087    * null file name/type.  However, it's commonplace under Unix,
2088    * so we'll allow it for a gain in portability.
2089    */
2090   if (dir[dirlen-1] == '/') {
2091     char *newdir = savepvn(dir,dirlen-1);
2092     int ret = mkdir(newdir,mode);
2093     Safefree(newdir);
2094     return ret;
2095   }
2096   else return mkdir(dir,mode);
2097 }  /* end of my_mkdir */
2098 /*}}}*/
2099
2100 /*{{{int my_chdir(char *)*/
2101 int
2102 Perl_my_chdir(pTHX_ const char *dir)
2103 {
2104   STRLEN dirlen = strlen(dir);
2105   const char *dir1 = dir;
2106
2107   /* zero length string sometimes gives ACCVIO */
2108   if (dirlen == 0) {
2109     SETERRNO(EINVAL, SS$_BADPARAM);
2110     return -1;
2111   }
2112
2113   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2114    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2115    * so that existing scripts do not need to be changed.
2116    */
2117   while ((dirlen > 0) && (*dir1 == ' ')) {
2118     dir1++;
2119     dirlen--;
2120   }
2121
2122   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2123    * that implies
2124    * null file name/type.  However, it's commonplace under Unix,
2125    * so we'll allow it for a gain in portability.
2126    *
2127    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2128    */
2129   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2130       char *newdir;
2131       int ret;
2132       newdir = (char *)PerlMem_malloc(dirlen);
2133       if (newdir ==NULL)
2134           _ckvmssts_noperl(SS$_INSFMEM);
2135       memcpy(newdir, dir1, dirlen-1);
2136       newdir[dirlen-1] = '\0';
2137       ret = chdir(newdir);
2138       PerlMem_free(newdir);
2139       return ret;
2140   }
2141   else return chdir(dir1);
2142 }  /* end of my_chdir */
2143 /*}}}*/
2144
2145
2146 /*{{{int my_chmod(char *, mode_t)*/
2147 int
2148 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2149 {
2150   Stat_t st;
2151   int ret = -1;
2152   char * changefile;
2153   STRLEN speclen = strlen(file_spec);
2154
2155   /* zero length string sometimes gives ACCVIO */
2156   if (speclen == 0) return -1;
2157
2158   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2159    * that implies null file name/type.  However, it's commonplace under Unix,
2160    * so we'll allow it for a gain in portability.
2161    *
2162    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2163    * in VMS file.dir notation.
2164    */
2165   changefile = (char *) file_spec; /* cast ok */
2166   ret = flex_lstat(file_spec, &st);
2167   if (ret != 0) {
2168
2169         /* Due to a historical feature, flex_stat/lstat can not see some */
2170         /* Unix format file names that the rest of the CRTL can see when */
2171         /* ODS-2 file specifications are in use. */
2172         /* Fixing that feature will cause some perl tests to fail */
2173         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2174         st.st_mode = 0;
2175
2176   } else {
2177       /* It may be possible to get here with nothing in st_devname */
2178       /* chmod still may work though */
2179       if (st.st_devnam[0] != 0) {
2180           changefile = st.st_devnam;
2181       }
2182   }
2183   ret = chmod(changefile, mode);
2184   return ret;
2185 }  /* end of my_chmod */
2186 /*}}}*/
2187
2188
2189 /*{{{FILE *my_tmpfile()*/
2190 FILE *
2191 my_tmpfile(void)
2192 {
2193   FILE *fp;
2194   char *cp;
2195
2196   if ((fp = tmpfile())) return fp;
2197
2198   cp = (char *)PerlMem_malloc(L_tmpnam+24);
2199   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2200
2201   if (decc_filename_unix_only == 0)
2202     strcpy(cp,"Sys$Scratch:");
2203   else
2204     strcpy(cp,"/tmp/");
2205   tmpnam(cp+strlen(cp));
2206   strcat(cp,".Perltmp");
2207   fp = fopen(cp,"w+","fop=dlt");
2208   PerlMem_free(cp);
2209   return fp;
2210 }
2211 /*}}}*/
2212
2213
2214 /*
2215  * The C RTL's sigaction fails to check for invalid signal numbers so we
2216  * help it out a bit.  The docs are correct, but the actual routine doesn't
2217  * do what the docs say it will.
2218  */
2219 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2220 int
2221 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2222                    struct sigaction* oact)
2223 {
2224   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2225         SETERRNO(EINVAL, SS$_INVARG);
2226         return -1;
2227   }
2228   return sigaction(sig, act, oact);
2229 }
2230 /*}}}*/
2231
2232 #ifdef KILL_BY_SIGPRC
2233 #include <errnodef.h>
2234
2235 /* We implement our own kill() using the undocumented system service
2236    sys$sigprc for one of two reasons:
2237
2238    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2239    target process to do a sys$exit, which usually can't be handled
2240    gracefully...certainly not by Perl and the %SIG{} mechanism.
2241
2242    2.) If the kill() in the CRTL can't be called from a signal
2243    handler without disappearing into the ether, i.e., the signal
2244    it purportedly sends is never trapped. Still true as of VMS 7.3.
2245
2246    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2247    in the target process rather than calling sys$exit.
2248
2249    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2250    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2251    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2252    with condition codes C$_SIG0+nsig*8, catching the exception on the
2253    target process and resignaling with appropriate arguments.
2254
2255    But we don't have that VMS 7.0+ exception handler, so if you
2256    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2257
2258    Also note that SIGTERM is listed in the docs as being "unimplemented",
2259    yet always seems to be signaled with a VMS condition code of 4 (and
2260    correctly handled for that code).  So we hardwire it in.
2261
2262    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2263    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2264    than signalling with an unrecognized (and unhandled by CRTL) code.
2265 */
2266
2267 #define _MY_SIG_MAX 28
2268
2269 static unsigned int
2270 Perl_sig_to_vmscondition_int(int sig)
2271 {
2272     static unsigned int sig_code[_MY_SIG_MAX+1] =
2273     {
2274         0,                  /*  0 ZERO     */
2275         SS$_HANGUP,         /*  1 SIGHUP   */
2276         SS$_CONTROLC,       /*  2 SIGINT   */
2277         SS$_CONTROLY,       /*  3 SIGQUIT  */
2278         SS$_RADRMOD,        /*  4 SIGILL   */
2279         SS$_BREAK,          /*  5 SIGTRAP  */
2280         SS$_OPCCUS,         /*  6 SIGABRT  */
2281         SS$_COMPAT,         /*  7 SIGEMT   */
2282 #ifdef __VAX
2283         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2284 #else
2285         SS$_HPARITH,        /*  8 SIGFPE AXP */
2286 #endif
2287         SS$_ABORT,          /*  9 SIGKILL  */
2288         SS$_ACCVIO,         /* 10 SIGBUS   */
2289         SS$_ACCVIO,         /* 11 SIGSEGV  */
2290         SS$_BADPARAM,       /* 12 SIGSYS   */
2291         SS$_NOMBX,          /* 13 SIGPIPE  */
2292         SS$_ASTFLT,         /* 14 SIGALRM  */
2293         4,                  /* 15 SIGTERM  */
2294         0,                  /* 16 SIGUSR1  */
2295         0,                  /* 17 SIGUSR2  */
2296         0,                  /* 18 */
2297         0,                  /* 19 */
2298         0,                  /* 20 SIGCHLD  */
2299         0,                  /* 21 SIGCONT  */
2300         0,                  /* 22 SIGSTOP  */
2301         0,                  /* 23 SIGTSTP  */
2302         0,                  /* 24 SIGTTIN  */
2303         0,                  /* 25 SIGTTOU  */
2304         0,                  /* 26 */
2305         0,                  /* 27 */
2306         0                   /* 28 SIGWINCH  */
2307     };
2308
2309     static int initted = 0;
2310     if (!initted) {
2311         initted = 1;
2312         sig_code[16] = C$_SIGUSR1;
2313         sig_code[17] = C$_SIGUSR2;
2314         sig_code[20] = C$_SIGCHLD;
2315 #if __CRTL_VER >= 70300000
2316         sig_code[28] = C$_SIGWINCH;
2317 #endif
2318     }
2319
2320     if (sig < _SIG_MIN) return 0;
2321     if (sig > _MY_SIG_MAX) return 0;
2322     return sig_code[sig];
2323 }
2324
2325 unsigned int
2326 Perl_sig_to_vmscondition(int sig)
2327 {
2328 #ifdef SS$_DEBUG
2329     if (vms_debug_on_exception != 0)
2330         lib$signal(SS$_DEBUG);
2331 #endif
2332     return Perl_sig_to_vmscondition_int(sig);
2333 }
2334
2335
2336 #define sys$sigprc SYS$SIGPRC
2337 #ifdef __cplusplus
2338 extern "C" {
2339 #endif
2340 int sys$sigprc(unsigned int *pidadr,
2341                struct dsc$descriptor_s *prcname,
2342                unsigned int code);
2343 #ifdef __cplusplus
2344 }
2345 #endif
2346
2347 int
2348 Perl_my_kill(int pid, int sig)
2349 {
2350     int iss;
2351     unsigned int code;
2352
2353      /* sig 0 means validate the PID */
2354     /*------------------------------*/
2355     if (sig == 0) {
2356         const unsigned long int jpicode = JPI$_PID;
2357         pid_t ret_pid;
2358         int status;
2359         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2360         if ($VMS_STATUS_SUCCESS(status))
2361            return 0;
2362         switch (status) {
2363         case SS$_NOSUCHNODE:
2364         case SS$_UNREACHABLE:
2365         case SS$_NONEXPR:
2366            errno = ESRCH;
2367            break;
2368         case SS$_NOPRIV:
2369            errno = EPERM;
2370            break;
2371         default:
2372            errno = EVMSERR;
2373         }
2374         vaxc$errno=status;
2375         return -1;
2376     }
2377
2378     code = Perl_sig_to_vmscondition_int(sig);
2379
2380     if (!code) {
2381         SETERRNO(EINVAL, SS$_BADPARAM);
2382         return -1;
2383     }
2384
2385     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2386      * signals are to be sent to multiple processes.
2387      *  pid = 0 - all processes in group except ones that the system exempts
2388      *  pid = -1 - all processes except ones that the system exempts
2389      *  pid = -n - all processes in group (abs(n)) except ...
2390      * For now, just report as not supported.
2391      */
2392
2393     if (pid <= 0) {
2394         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2395         return -1;
2396     }
2397
2398     iss = sys$sigprc((unsigned int *)&pid,0,code);
2399     if (iss&1) return 0;
2400
2401     switch (iss) {
2402       case SS$_NOPRIV:
2403         set_errno(EPERM);  break;
2404       case SS$_NONEXPR:
2405       case SS$_NOSUCHNODE:
2406       case SS$_UNREACHABLE:
2407         set_errno(ESRCH);  break;
2408       case SS$_INSFMEM:
2409         set_errno(ENOMEM); break;
2410       default:
2411         _ckvmssts_noperl(iss);
2412         set_errno(EVMSERR);
2413     }
2414     set_vaxc_errno(iss);
2415
2416     return -1;
2417 }
2418 #endif
2419
2420 /* Routine to convert a VMS status code to a UNIX status code.
2421 ** More tricky than it appears because of conflicting conventions with
2422 ** existing code.
2423 **
2424 ** VMS status codes are a bit mask, with the least significant bit set for
2425 ** success.
2426 **
2427 ** Special UNIX status of EVMSERR indicates that no translation is currently
2428 ** available, and programs should check the VMS status code.
2429 **
2430 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2431 ** decoding.
2432 */
2433
2434 #ifndef C_FACILITY_NO
2435 #define C_FACILITY_NO 0x350000
2436 #endif
2437 #ifndef DCL_IVVERB
2438 #define DCL_IVVERB 0x38090
2439 #endif
2440
2441 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2442 {
2443 int facility;
2444 int fac_sp;
2445 int msg_no;
2446 int msg_status;
2447 int unix_status;
2448
2449   /* Assume the best or the worst */
2450   if (vms_status & STS$M_SUCCESS)
2451     unix_status = 0;
2452   else
2453     unix_status = EVMSERR;
2454
2455   msg_status = vms_status & ~STS$M_CONTROL;
2456
2457   facility = vms_status & STS$M_FAC_NO;
2458   fac_sp = vms_status & STS$M_FAC_SP;
2459   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2460
2461   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2462     switch(msg_no) {
2463     case SS$_NORMAL:
2464         unix_status = 0;
2465         break;
2466     case SS$_ACCVIO:
2467         unix_status = EFAULT;
2468         break;
2469     case SS$_DEVOFFLINE:
2470         unix_status = EBUSY;
2471         break;
2472     case SS$_CLEARED:
2473         unix_status = ENOTCONN;
2474         break;
2475     case SS$_IVCHAN:
2476     case SS$_IVLOGNAM:
2477     case SS$_BADPARAM:
2478     case SS$_IVLOGTAB:
2479     case SS$_NOLOGNAM:
2480     case SS$_NOLOGTAB:
2481     case SS$_INVFILFOROP:
2482     case SS$_INVARG:
2483     case SS$_NOSUCHID:
2484     case SS$_IVIDENT:
2485         unix_status = EINVAL;
2486         break;
2487     case SS$_UNSUPPORTED:
2488         unix_status = ENOTSUP;
2489         break;
2490     case SS$_FILACCERR:
2491     case SS$_NOGRPPRV:
2492     case SS$_NOSYSPRV:
2493         unix_status = EACCES;
2494         break;
2495     case SS$_DEVICEFULL:
2496         unix_status = ENOSPC;
2497         break;
2498     case SS$_NOSUCHDEV:
2499         unix_status = ENODEV;
2500         break;
2501     case SS$_NOSUCHFILE:
2502     case SS$_NOSUCHOBJECT:
2503         unix_status = ENOENT;
2504         break;
2505     case SS$_ABORT:                                 /* Fatal case */
2506     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2507     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2508         unix_status = EINTR;
2509         break;
2510     case SS$_BUFFEROVF:
2511         unix_status = E2BIG;
2512         break;
2513     case SS$_INSFMEM:
2514         unix_status = ENOMEM;
2515         break;
2516     case SS$_NOPRIV:
2517         unix_status = EPERM;
2518         break;
2519     case SS$_NOSUCHNODE:
2520     case SS$_UNREACHABLE:
2521         unix_status = ESRCH;
2522         break;
2523     case SS$_NONEXPR:
2524         unix_status = ECHILD;
2525         break;
2526     default:
2527         if ((facility == 0) && (msg_no < 8)) {
2528           /* These are not real VMS status codes so assume that they are
2529           ** already UNIX status codes
2530           */
2531           unix_status = msg_no;
2532           break;
2533         }
2534     }
2535   }
2536   else {
2537     /* Translate a POSIX exit code to a UNIX exit code */
2538     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2539         unix_status = (msg_no & 0x07F8) >> 3;
2540     }
2541     else {
2542
2543          /* Documented traditional behavior for handling VMS child exits */
2544         /*--------------------------------------------------------------*/
2545         if (child_flag != 0) {
2546
2547              /* Success / Informational return 0 */
2548             /*----------------------------------*/
2549             if (msg_no & STS$K_SUCCESS)
2550                 return 0;
2551
2552              /* Warning returns 1 */
2553             /*-------------------*/
2554             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2555                 return 1;
2556
2557              /* Everything else pass through the severity bits */
2558             /*------------------------------------------------*/
2559             return (msg_no & STS$M_SEVERITY);
2560         }
2561
2562          /* Normal VMS status to ERRNO mapping attempt */
2563         /*--------------------------------------------*/
2564         switch(msg_status) {
2565         /* case RMS$_EOF: */ /* End of File */
2566         case RMS$_FNF:  /* File Not Found */
2567         case RMS$_DNF:  /* Dir Not Found */
2568                 unix_status = ENOENT;
2569                 break;
2570         case RMS$_RNF:  /* Record Not Found */
2571                 unix_status = ESRCH;
2572                 break;
2573         case RMS$_DIR:
2574                 unix_status = ENOTDIR;
2575                 break;
2576         case RMS$_DEV:
2577                 unix_status = ENODEV;
2578                 break;
2579         case RMS$_IFI:
2580         case RMS$_FAC:
2581         case RMS$_ISI:
2582                 unix_status = EBADF;
2583                 break;
2584         case RMS$_FEX:
2585                 unix_status = EEXIST;
2586                 break;
2587         case RMS$_SYN:
2588         case RMS$_FNM:
2589         case LIB$_INVSTRDES:
2590         case LIB$_INVARG:
2591         case LIB$_NOSUCHSYM:
2592         case LIB$_INVSYMNAM:
2593         case DCL_IVVERB:
2594                 unix_status = EINVAL;
2595                 break;
2596         case CLI$_BUFOVF:
2597         case RMS$_RTB:
2598         case CLI$_TKNOVF:
2599         case CLI$_RSLOVF:
2600                 unix_status = E2BIG;
2601                 break;
2602         case RMS$_PRV:  /* No privilege */
2603         case RMS$_ACC:  /* ACP file access failed */
2604         case RMS$_WLK:  /* Device write locked */
2605                 unix_status = EACCES;
2606                 break;
2607         case RMS$_MKD:  /* Failed to mark for delete */
2608                 unix_status = EPERM;
2609                 break;
2610         /* case RMS$_NMF: */  /* No more files */
2611         }
2612     }
2613   }
2614
2615   return unix_status;
2616 }
2617
2618 /* Try to guess at what VMS error status should go with a UNIX errno
2619  * value.  This is hard to do as there could be many possible VMS
2620  * error statuses that caused the errno value to be set.
2621  */
2622
2623 int Perl_unix_status_to_vms(int unix_status)
2624 {
2625 int test_unix_status;
2626
2627      /* Trivial cases first */
2628     /*---------------------*/
2629     if (unix_status == EVMSERR)
2630         return vaxc$errno;
2631
2632      /* Is vaxc$errno sane? */
2633     /*---------------------*/
2634     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2635     if (test_unix_status == unix_status)
2636         return vaxc$errno;
2637
2638      /* If way out of range, must be VMS code already */
2639     /*-----------------------------------------------*/
2640     if (unix_status > EVMSERR)
2641         return unix_status;
2642
2643      /* If out of range, punt */
2644     /*-----------------------*/
2645     if (unix_status > __ERRNO_MAX)
2646         return SS$_ABORT;
2647
2648
2649      /* Ok, now we have to do it the hard way. */
2650     /*----------------------------------------*/
2651     switch(unix_status) {
2652     case 0:     return SS$_NORMAL;
2653     case EPERM: return SS$_NOPRIV;
2654     case ENOENT: return SS$_NOSUCHOBJECT;
2655     case ESRCH: return SS$_UNREACHABLE;
2656     case EINTR: return SS$_ABORT;
2657     /* case EIO: */
2658     /* case ENXIO:  */
2659     case E2BIG: return SS$_BUFFEROVF;
2660     /* case ENOEXEC */
2661     case EBADF: return RMS$_IFI;
2662     case ECHILD: return SS$_NONEXPR;
2663     /* case EAGAIN */
2664     case ENOMEM: return SS$_INSFMEM;
2665     case EACCES: return SS$_FILACCERR;
2666     case EFAULT: return SS$_ACCVIO;
2667     /* case ENOTBLK */
2668     case EBUSY: return SS$_DEVOFFLINE;
2669     case EEXIST: return RMS$_FEX;
2670     /* case EXDEV */
2671     case ENODEV: return SS$_NOSUCHDEV;
2672     case ENOTDIR: return RMS$_DIR;
2673     /* case EISDIR */
2674     case EINVAL: return SS$_INVARG;
2675     /* case ENFILE */
2676     /* case EMFILE */
2677     /* case ENOTTY */
2678     /* case ETXTBSY */
2679     /* case EFBIG */
2680     case ENOSPC: return SS$_DEVICEFULL;
2681     case ESPIPE: return LIB$_INVARG;
2682     /* case EROFS: */
2683     /* case EMLINK: */
2684     /* case EPIPE: */
2685     /* case EDOM */
2686     case ERANGE: return LIB$_INVARG;
2687     /* case EWOULDBLOCK */
2688     /* case EINPROGRESS */
2689     /* case EALREADY */
2690     /* case ENOTSOCK */
2691     /* case EDESTADDRREQ */
2692     /* case EMSGSIZE */
2693     /* case EPROTOTYPE */
2694     /* case ENOPROTOOPT */
2695     /* case EPROTONOSUPPORT */
2696     /* case ESOCKTNOSUPPORT */
2697     /* case EOPNOTSUPP */
2698     /* case EPFNOSUPPORT */
2699     /* case EAFNOSUPPORT */
2700     /* case EADDRINUSE */
2701     /* case EADDRNOTAVAIL */
2702     /* case ENETDOWN */
2703     /* case ENETUNREACH */
2704     /* case ENETRESET */
2705     /* case ECONNABORTED */
2706     /* case ECONNRESET */
2707     /* case ENOBUFS */
2708     /* case EISCONN */
2709     case ENOTCONN: return SS$_CLEARED;
2710     /* case ESHUTDOWN */
2711     /* case ETOOMANYREFS */
2712     /* case ETIMEDOUT */
2713     /* case ECONNREFUSED */
2714     /* case ELOOP */
2715     /* case ENAMETOOLONG */
2716     /* case EHOSTDOWN */
2717     /* case EHOSTUNREACH */
2718     /* case ENOTEMPTY */
2719     /* case EPROCLIM */
2720     /* case EUSERS  */
2721     /* case EDQUOT  */
2722     /* case ENOMSG  */
2723     /* case EIDRM */
2724     /* case EALIGN */
2725     /* case ESTALE */
2726     /* case EREMOTE */
2727     /* case ENOLCK */
2728     /* case ENOSYS */
2729     /* case EFTYPE */
2730     /* case ECANCELED */
2731     /* case EFAIL */
2732     /* case EINPROG */
2733     case ENOTSUP:
2734         return SS$_UNSUPPORTED;
2735     /* case EDEADLK */
2736     /* case ENWAIT */
2737     /* case EILSEQ */
2738     /* case EBADCAT */
2739     /* case EBADMSG */
2740     /* case EABANDONED */
2741     default:
2742         return SS$_ABORT; /* punt */
2743     }
2744 }
2745
2746
2747 /* default piping mailbox size */
2748 #ifdef __VAX
2749 #  define PERL_BUFSIZ        512
2750 #else
2751 #  define PERL_BUFSIZ        8192
2752 #endif
2753
2754
2755 static void
2756 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2757 {
2758   unsigned long int mbxbufsiz;
2759   static unsigned long int syssize = 0;
2760   unsigned long int dviitm = DVI$_DEVNAM;
2761   char csize[LNM$C_NAMLENGTH+1];
2762   int sts;
2763
2764   if (!syssize) {
2765     unsigned long syiitm = SYI$_MAXBUF;
2766     /*
2767      * Get the SYSGEN parameter MAXBUF
2768      *
2769      * If the logical 'PERL_MBX_SIZE' is defined
2770      * use the value of the logical instead of PERL_BUFSIZ, but
2771      * keep the size between 128 and MAXBUF.
2772      *
2773      */
2774     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2775   }
2776
2777   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2778       mbxbufsiz = atoi(csize);
2779   } else {
2780       mbxbufsiz = PERL_BUFSIZ;
2781   }
2782   if (mbxbufsiz < 128) mbxbufsiz = 128;
2783   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2784
2785   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2786
2787   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2788   _ckvmssts_noperl(sts);
2789   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2790
2791 }  /* end of create_mbx() */
2792
2793
2794 /*{{{  my_popen and my_pclose*/
2795
2796 typedef struct _iosb           IOSB;
2797 typedef struct _iosb*         pIOSB;
2798 typedef struct _pipe           Pipe;
2799 typedef struct _pipe*         pPipe;
2800 typedef struct pipe_details    Info;
2801 typedef struct pipe_details*  pInfo;
2802 typedef struct _srqp            RQE;
2803 typedef struct _srqp*          pRQE;
2804 typedef struct _tochildbuf      CBuf;
2805 typedef struct _tochildbuf*    pCBuf;
2806
2807 struct _iosb {
2808     unsigned short status;
2809     unsigned short count;
2810     unsigned long  dvispec;
2811 };
2812
2813 #pragma member_alignment save
2814 #pragma nomember_alignment quadword
2815 struct _srqp {          /* VMS self-relative queue entry */
2816     unsigned long qptr[2];
2817 };
2818 #pragma member_alignment restore
2819 static RQE  RQE_ZERO = {0,0};
2820
2821 struct _tochildbuf {
2822     RQE             q;
2823     int             eof;
2824     unsigned short  size;
2825     char            *buf;
2826 };
2827
2828 struct _pipe {
2829     RQE            free;
2830     RQE            wait;
2831     int            fd_out;
2832     unsigned short chan_in;
2833     unsigned short chan_out;
2834     char          *buf;
2835     unsigned int   bufsize;
2836     IOSB           iosb;
2837     IOSB           iosb2;
2838     int           *pipe_done;
2839     int            retry;
2840     int            type;
2841     int            shut_on_empty;
2842     int            need_wake;
2843     pPipe         *home;
2844     pInfo          info;
2845     pCBuf          curr;
2846     pCBuf          curr2;
2847 #if defined(PERL_IMPLICIT_CONTEXT)
2848     void            *thx;           /* Either a thread or an interpreter */
2849                                     /* pointer, depending on how we're built */
2850 #endif
2851 };
2852
2853
2854 struct pipe_details
2855 {
2856     pInfo           next;
2857     PerlIO *fp;  /* file pointer to pipe mailbox */
2858     int useFILE; /* using stdio, not perlio */
2859     int pid;   /* PID of subprocess */
2860     int mode;  /* == 'r' if pipe open for reading */
2861     int done;  /* subprocess has completed */
2862     int waiting; /* waiting for completion/closure */
2863     int             closing;        /* my_pclose is closing this pipe */
2864     unsigned long   completion;     /* termination status of subprocess */
2865     pPipe           in;             /* pipe in to sub */
2866     pPipe           out;            /* pipe out of sub */
2867     pPipe           err;            /* pipe of sub's sys$error */
2868     int             in_done;        /* true when in pipe finished */
2869     int             out_done;
2870     int             err_done;
2871     unsigned short  xchan;          /* channel to debug xterm */
2872     unsigned short  xchan_valid;    /* channel is assigned */
2873 };
2874
2875 struct exit_control_block
2876 {
2877     struct exit_control_block *flink;
2878     unsigned long int (*exit_routine)(void);
2879     unsigned long int arg_count;
2880     unsigned long int *status_address;
2881     unsigned long int exit_status;
2882 };
2883
2884 typedef struct _closed_pipes    Xpipe;
2885 typedef struct _closed_pipes*  pXpipe;
2886
2887 struct _closed_pipes {
2888     int             pid;            /* PID of subprocess */
2889     unsigned long   completion;     /* termination status of subprocess */
2890 };
2891 #define NKEEPCLOSED 50
2892 static Xpipe closed_list[NKEEPCLOSED];
2893 static int   closed_index = 0;
2894 static int   closed_num = 0;
2895
2896 #define RETRY_DELAY     "0 ::0.20"
2897 #define MAX_RETRY              50
2898
2899 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2900 static unsigned long mypid;
2901 static unsigned long delaytime[2];
2902
2903 static pInfo open_pipes = NULL;
2904 static $DESCRIPTOR(nl_desc, "NL:");
2905
2906 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2907
2908
2909
2910 static unsigned long int
2911 pipe_exit_routine(void)
2912 {
2913     pInfo info;
2914     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2915     int sts, did_stuff, j;
2916
2917    /*
2918     * Flush any pending i/o, but since we are in process run-down, be
2919     * careful about referencing PerlIO structures that may already have
2920     * been deallocated.  We may not even have an interpreter anymore.
2921     */
2922     info = open_pipes;
2923     while (info) {
2924         if (info->fp) {
2925 #if defined(PERL_IMPLICIT_CONTEXT)
2926            /* We need to use the Perl context of the thread that created */
2927            /* the pipe. */
2928            pTHX;
2929            if (info->err)
2930                aTHX = info->err->thx;
2931            else if (info->out)
2932                aTHX = info->out->thx;
2933            else if (info->in)
2934                aTHX = info->in->thx;
2935 #endif
2936            if (!info->useFILE
2937 #if defined(USE_ITHREADS)
2938              && my_perl
2939 #endif
2940 #ifdef USE_PERLIO
2941              && PL_perlio_fd_refcnt
2942 #endif
2943               )
2944                PerlIO_flush(info->fp);
2945            else
2946                fflush((FILE *)info->fp);
2947         }
2948         info = info->next;
2949     }
2950
2951     /*
2952      next we try sending an EOF...ignore if doesn't work, make sure we
2953      don't hang
2954     */
2955     did_stuff = 0;
2956     info = open_pipes;
2957
2958     while (info) {
2959       _ckvmssts_noperl(sys$setast(0));
2960       if (info->in && !info->in->shut_on_empty) {
2961         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2962                                  0, 0, 0, 0, 0, 0));
2963         info->waiting = 1;
2964         did_stuff = 1;
2965       }
2966       _ckvmssts_noperl(sys$setast(1));
2967       info = info->next;
2968     }
2969
2970     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2971
2972     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2973         int nwait = 0;
2974
2975         info = open_pipes;
2976         while (info) {
2977           _ckvmssts_noperl(sys$setast(0));
2978           if (info->waiting && info->done)
2979                 info->waiting = 0;
2980           nwait += info->waiting;
2981           _ckvmssts_noperl(sys$setast(1));
2982           info = info->next;
2983         }
2984         if (!nwait) break;
2985         sleep(1);
2986     }
2987
2988     did_stuff = 0;
2989     info = open_pipes;
2990     while (info) {
2991       _ckvmssts_noperl(sys$setast(0));
2992       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2993         sts = sys$forcex(&info->pid,0,&abort);
2994         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2995         did_stuff = 1;
2996       }
2997       _ckvmssts_noperl(sys$setast(1));
2998       info = info->next;
2999     }
3000
3001     /* again, wait for effect */
3002
3003     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3004         int nwait = 0;
3005
3006         info = open_pipes;
3007         while (info) {
3008           _ckvmssts_noperl(sys$setast(0));
3009           if (info->waiting && info->done)
3010                 info->waiting = 0;
3011           nwait += info->waiting;
3012           _ckvmssts_noperl(sys$setast(1));
3013           info = info->next;
3014         }
3015         if (!nwait) break;
3016         sleep(1);
3017     }
3018
3019     info = open_pipes;
3020     while (info) {
3021       _ckvmssts_noperl(sys$setast(0));
3022       if (!info->done) {  /* We tried to be nice . . . */
3023         sts = sys$delprc(&info->pid,0);
3024         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3025         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3026       }
3027       _ckvmssts_noperl(sys$setast(1));
3028       info = info->next;
3029     }
3030
3031     while(open_pipes) {
3032
3033 #if defined(PERL_IMPLICIT_CONTEXT)
3034       /* We need to use the Perl context of the thread that created */
3035       /* the pipe. */
3036       pTHX;
3037       if (open_pipes->err)
3038           aTHX = open_pipes->err->thx;
3039       else if (open_pipes->out)
3040           aTHX = open_pipes->out->thx;
3041       else if (open_pipes->in)
3042           aTHX = open_pipes->in->thx;
3043 #endif
3044       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3045       else if (!(sts & 1)) retsts = sts;
3046     }
3047     return retsts;
3048 }
3049
3050 static struct exit_control_block pipe_exitblock =
3051        {(struct exit_control_block *) 0,
3052         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3053
3054 static void pipe_mbxtofd_ast(pPipe p);
3055 static void pipe_tochild1_ast(pPipe p);
3056 static void pipe_tochild2_ast(pPipe p);
3057
3058 static void
3059 popen_completion_ast(pInfo info)
3060 {
3061   pInfo i = open_pipes;
3062   int iss;
3063
3064   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3065   closed_list[closed_index].pid = info->pid;
3066   closed_list[closed_index].completion = info->completion;
3067   closed_index++;
3068   if (closed_index == NKEEPCLOSED)
3069     closed_index = 0;
3070   closed_num++;
3071
3072   while (i) {
3073     if (i == info) break;
3074     i = i->next;
3075   }
3076   if (!i) return;       /* unlinked, probably freed too */
3077
3078   info->done = TRUE;
3079
3080 /*
3081     Writing to subprocess ...
3082             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3083
3084             chan_out may be waiting for "done" flag, or hung waiting
3085             for i/o completion to child...cancel the i/o.  This will
3086             put it into "snarf mode" (done but no EOF yet) that discards
3087             input.
3088
3089     Output from subprocess (stdout, stderr) needs to be flushed and
3090     shut down.   We try sending an EOF, but if the mbx is full the pipe
3091     routine should still catch the "shut_on_empty" flag, telling it to
3092     use immediate-style reads so that "mbx empty" -> EOF.
3093
3094
3095 */
3096   if (info->in && !info->in_done) {               /* only for mode=w */
3097         if (info->in->shut_on_empty && info->in->need_wake) {
3098             info->in->need_wake = FALSE;
3099             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3100         } else {
3101             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3102         }
3103   }
3104
3105   if (info->out && !info->out_done) {             /* were we also piping output? */
3106       info->out->shut_on_empty = TRUE;
3107       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3108       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3109       _ckvmssts_noperl(iss);
3110   }
3111
3112   if (info->err && !info->err_done) {        /* we were piping stderr */
3113         info->err->shut_on_empty = TRUE;
3114         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3115         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3116         _ckvmssts_noperl(iss);
3117   }
3118   _ckvmssts_noperl(sys$setef(pipe_ef));
3119
3120 }
3121
3122 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3123 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3124 static void pipe_infromchild_ast(pPipe p);
3125
3126 /*
3127     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3128     inside an AST routine without worrying about reentrancy and which Perl
3129     memory allocator is being used.
3130
3131     We read data and queue up the buffers, then spit them out one at a
3132     time to the output mailbox when the output mailbox is ready for one.
3133
3134 */
3135 #define INITIAL_TOCHILDQUEUE  2
3136
3137 static pPipe
3138 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3139 {
3140     pPipe p;
3141     pCBuf b;
3142     char mbx1[64], mbx2[64];
3143     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3144                                       DSC$K_CLASS_S, mbx1},
3145                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3146                                       DSC$K_CLASS_S, mbx2};
3147     unsigned int dviitm = DVI$_DEVBUFSIZ;
3148     int j, n;
3149
3150     n = sizeof(Pipe);
3151     _ckvmssts_noperl(lib$get_vm(&n, &p));
3152
3153     create_mbx(&p->chan_in , &d_mbx1);
3154     create_mbx(&p->chan_out, &d_mbx2);
3155     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3156
3157     p->buf           = 0;
3158     p->shut_on_empty = FALSE;
3159     p->need_wake     = FALSE;
3160     p->type          = 0;
3161     p->retry         = 0;
3162     p->iosb.status   = SS$_NORMAL;
3163     p->iosb2.status  = SS$_NORMAL;
3164     p->free          = RQE_ZERO;
3165     p->wait          = RQE_ZERO;
3166     p->curr          = 0;
3167     p->curr2         = 0;
3168     p->info          = 0;
3169 #ifdef PERL_IMPLICIT_CONTEXT
3170     p->thx           = aTHX;
3171 #endif
3172
3173     n = sizeof(CBuf) + p->bufsize;
3174
3175     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3176         _ckvmssts_noperl(lib$get_vm(&n, &b));
3177         b->buf = (char *) b + sizeof(CBuf);
3178         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3179     }
3180
3181     pipe_tochild2_ast(p);
3182     pipe_tochild1_ast(p);
3183     strcpy(wmbx, mbx1);
3184     strcpy(rmbx, mbx2);
3185     return p;
3186 }
3187
3188 /*  reads the MBX Perl is writing, and queues */
3189
3190 static void
3191 pipe_tochild1_ast(pPipe p)
3192 {
3193     pCBuf b = p->curr;
3194     int iss = p->iosb.status;
3195     int eof = (iss == SS$_ENDOFFILE);
3196     int sts;
3197 #ifdef PERL_IMPLICIT_CONTEXT
3198     pTHX = p->thx;
3199 #endif
3200
3201     if (p->retry) {
3202         if (eof) {
3203             p->shut_on_empty = TRUE;
3204             b->eof     = TRUE;
3205             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3206         } else  {
3207             _ckvmssts_noperl(iss);
3208         }
3209
3210         b->eof  = eof;
3211         b->size = p->iosb.count;
3212         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3213         if (p->need_wake) {
3214             p->need_wake = FALSE;
3215             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3216         }
3217     } else {
3218         p->retry = 1;   /* initial call */
3219     }
3220
3221     if (eof) {                  /* flush the free queue, return when done */
3222         int n = sizeof(CBuf) + p->bufsize;
3223         while (1) {
3224             iss = lib$remqti(&p->free, &b);
3225             if (iss == LIB$_QUEWASEMP) return;
3226             _ckvmssts_noperl(iss);
3227             _ckvmssts_noperl(lib$free_vm(&n, &b));
3228         }
3229     }
3230
3231     iss = lib$remqti(&p->free, &b);
3232     if (iss == LIB$_QUEWASEMP) {
3233         int n = sizeof(CBuf) + p->bufsize;
3234         _ckvmssts_noperl(lib$get_vm(&n, &b));
3235         b->buf = (char *) b + sizeof(CBuf);
3236     } else {
3237        _ckvmssts_noperl(iss);
3238     }
3239
3240     p->curr = b;
3241     iss = sys$qio(0,p->chan_in,
3242              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3243              &p->iosb,
3244              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3245     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3246     _ckvmssts_noperl(iss);
3247 }
3248
3249
3250 /* writes queued buffers to output, waits for each to complete before
3251    doing the next */
3252
3253 static void
3254 pipe_tochild2_ast(pPipe p)
3255 {
3256     pCBuf b = p->curr2;
3257     int iss = p->iosb2.status;
3258     int n = sizeof(CBuf) + p->bufsize;
3259     int done = (p->info && p->info->done) ||
3260               iss == SS$_CANCEL || iss == SS$_ABORT;
3261 #if defined(PERL_IMPLICIT_CONTEXT)
3262     pTHX = p->thx;
3263 #endif
3264
3265     do {
3266         if (p->type) {         /* type=1 has old buffer, dispose */
3267             if (p->shut_on_empty) {
3268                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3269             } else {
3270                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3271             }
3272             p->type = 0;
3273         }
3274
3275         iss = lib$remqti(&p->wait, &b);
3276         if (iss == LIB$_QUEWASEMP) {
3277             if (p->shut_on_empty) {
3278                 if (done) {
3279                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3280                     *p->pipe_done = TRUE;
3281                     _ckvmssts_noperl(sys$setef(pipe_ef));
3282                 } else {
3283                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3284                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3285                 }
3286                 return;
3287             }
3288             p->need_wake = TRUE;
3289             return;
3290         }
3291         _ckvmssts_noperl(iss);
3292         p->type = 1;
3293     } while (done);
3294
3295
3296     p->curr2 = b;
3297     if (b->eof) {
3298         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3299             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3300     } else {
3301         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3302             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3303     }
3304
3305     return;
3306
3307 }
3308
3309
3310 static pPipe
3311 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3312 {
3313     pPipe p;
3314     char mbx1[64], mbx2[64];
3315     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3316                                       DSC$K_CLASS_S, mbx1},
3317                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3318                                       DSC$K_CLASS_S, mbx2};
3319     unsigned int dviitm = DVI$_DEVBUFSIZ;
3320
3321     int n = sizeof(Pipe);
3322     _ckvmssts_noperl(lib$get_vm(&n, &p));
3323     create_mbx(&p->chan_in , &d_mbx1);
3324     create_mbx(&p->chan_out, &d_mbx2);
3325
3326     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3327     n = p->bufsize * sizeof(char);
3328     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3329     p->shut_on_empty = FALSE;
3330     p->info   = 0;
3331     p->type   = 0;
3332     p->iosb.status = SS$_NORMAL;
3333 #if defined(PERL_IMPLICIT_CONTEXT)
3334     p->thx = aTHX;
3335 #endif
3336     pipe_infromchild_ast(p);
3337
3338     strcpy(wmbx, mbx1);
3339     strcpy(rmbx, mbx2);
3340     return p;
3341 }
3342
3343 static void
3344 pipe_infromchild_ast(pPipe p)
3345 {
3346     int iss = p->iosb.status;
3347     int eof = (iss == SS$_ENDOFFILE);
3348     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3349     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3350 #if defined(PERL_IMPLICIT_CONTEXT)
3351     pTHX = p->thx;
3352 #endif
3353
3354     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3355         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3356         p->chan_out = 0;
3357     }
3358
3359     /* read completed:
3360             input shutdown if EOF from self (done or shut_on_empty)
3361             output shutdown if closing flag set (my_pclose)
3362             send data/eof from child or eof from self
3363             otherwise, re-read (snarf of data from child)
3364     */
3365
3366     if (p->type == 1) {
3367         p->type = 0;
3368         if (myeof && p->chan_in) {                  /* input shutdown */
3369             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3370             p->chan_in = 0;
3371         }
3372
3373         if (p->chan_out) {
3374             if (myeof || kideof) {      /* pass EOF to parent */
3375                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3376                                          pipe_infromchild_ast, p,
3377                                          0, 0, 0, 0, 0, 0));
3378                 return;
3379             } else if (eof) {       /* eat EOF --- fall through to read*/
3380
3381             } else {                /* transmit data */
3382                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3383                                          pipe_infromchild_ast,p,
3384                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3385                 return;
3386             }
3387         }
3388     }
3389
3390     /*  everything shut? flag as done */
3391
3392     if (!p->chan_in && !p->chan_out) {
3393         *p->pipe_done = TRUE;
3394         _ckvmssts_noperl(sys$setef(pipe_ef));
3395         return;
3396     }
3397
3398     /* write completed (or read, if snarfing from child)
3399             if still have input active,
3400                queue read...immediate mode if shut_on_empty so we get EOF if empty
3401             otherwise,
3402                check if Perl reading, generate EOFs as needed
3403     */
3404
3405     if (p->type == 0) {
3406         p->type = 1;
3407         if (p->chan_in) {
3408             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3409                           pipe_infromchild_ast,p,
3410                           p->buf, p->bufsize, 0, 0, 0, 0);
3411             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3412             _ckvmssts_noperl(iss);
3413         } else {           /* send EOFs for extra reads */
3414             p->iosb.status = SS$_ENDOFFILE;
3415             p->iosb.dvispec = 0;
3416             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3417                                      0, 0, 0,
3418                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3419         }
3420     }
3421 }
3422
3423 static pPipe
3424 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3425 {
3426     pPipe p;
3427     char mbx[64];
3428     unsigned long dviitm = DVI$_DEVBUFSIZ;
3429     struct stat s;
3430     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3431                                       DSC$K_CLASS_S, mbx};
3432     int n = sizeof(Pipe);
3433
3434     /* things like terminals and mbx's don't need this filter */
3435     if (fd && fstat(fd,&s) == 0) {
3436         unsigned long devchar;
3437         char device[65];
3438         unsigned short dev_len;
3439         struct dsc$descriptor_s d_dev;
3440         char * cptr;
3441         struct item_list_3 items[3];
3442         int status;
3443         unsigned short dvi_iosb[4];
3444
3445         cptr = getname(fd, out, 1);
3446         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3447         d_dev.dsc$a_pointer = out;
3448         d_dev.dsc$w_length = strlen(out);
3449         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3450         d_dev.dsc$b_class = DSC$K_CLASS_S;
3451
3452         items[0].len = 4;
3453         items[0].code = DVI$_DEVCHAR;
3454         items[0].bufadr = &devchar;
3455         items[0].retadr = NULL;
3456         items[1].len = 64;
3457         items[1].code = DVI$_FULLDEVNAM;
3458         items[1].bufadr = device;
3459         items[1].retadr = &dev_len;
3460         items[2].len = 0;
3461         items[2].code = 0;
3462
3463         status = sys$getdviw
3464                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3465         _ckvmssts_noperl(status);
3466         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3467             device[dev_len] = 0;
3468
3469             if (!(devchar & DEV$M_DIR)) {
3470                 strcpy(out, device);
3471                 return 0;
3472             }
3473         }
3474     }
3475
3476     _ckvmssts_noperl(lib$get_vm(&n, &p));
3477     p->fd_out = dup(fd);
3478     create_mbx(&p->chan_in, &d_mbx);
3479     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3480     n = (p->bufsize+1) * sizeof(char);
3481     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3482     p->shut_on_empty = FALSE;
3483     p->retry = 0;
3484     p->info  = 0;
3485     strcpy(out, mbx);
3486
3487     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3488                              pipe_mbxtofd_ast, p,
3489                              p->buf, p->bufsize, 0, 0, 0, 0));
3490
3491     return p;
3492 }
3493
3494 static void
3495 pipe_mbxtofd_ast(pPipe p)
3496 {
3497     int iss = p->iosb.status;
3498     int done = p->info->done;
3499     int iss2;
3500     int eof = (iss == SS$_ENDOFFILE);
3501     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3502     int err = !(iss&1) && !eof;
3503 #if defined(PERL_IMPLICIT_CONTEXT)
3504     pTHX = p->thx;
3505 #endif
3506
3507     if (done && myeof) {               /* end piping */
3508         close(p->fd_out);
3509         sys$dassgn(p->chan_in);
3510         *p->pipe_done = TRUE;
3511         _ckvmssts_noperl(sys$setef(pipe_ef));
3512         return;
3513     }
3514
3515     if (!err && !eof) {             /* good data to send to file */
3516         p->buf[p->iosb.count] = '\n';
3517         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3518         if (iss2 < 0) {
3519             p->retry++;
3520             if (p->retry < MAX_RETRY) {
3521                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3522                 return;
3523             }
3524         }
3525         p->retry = 0;
3526     } else if (err) {
3527         _ckvmssts_noperl(iss);
3528     }
3529
3530
3531     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3532           pipe_mbxtofd_ast, p,
3533           p->buf, p->bufsize, 0, 0, 0, 0);
3534     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3535     _ckvmssts_noperl(iss);
3536 }
3537
3538
3539 typedef struct _pipeloc     PLOC;
3540 typedef struct _pipeloc*   pPLOC;
3541
3542 struct _pipeloc {
3543     pPLOC   next;
3544     char    dir[NAM$C_MAXRSS+1];
3545 };
3546 static pPLOC  head_PLOC = 0;
3547
3548 void
3549 free_pipelocs(pTHX_ void *head)
3550 {
3551     pPLOC p, pnext;
3552     pPLOC *pHead = (pPLOC *)head;
3553
3554     p = *pHead;
3555     while (p) {
3556         pnext = p->next;
3557         PerlMem_free(p);
3558         p = pnext;
3559     }
3560     *pHead = 0;
3561 }
3562
3563 static void
3564 store_pipelocs(pTHX)
3565 {
3566     int    i;
3567     pPLOC  p;
3568     AV    *av = 0;
3569     SV    *dirsv;
3570     char  *dir, *x;
3571     char  *unixdir;
3572     char  temp[NAM$C_MAXRSS+1];
3573     STRLEN n_a;
3574
3575     if (head_PLOC)
3576         free_pipelocs(aTHX_ &head_PLOC);
3577
3578 /*  the . directory from @INC comes last */
3579
3580     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3581     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3582     p->next = head_PLOC;
3583     head_PLOC = p;
3584     strcpy(p->dir,"./");
3585
3586 /*  get the directory from $^X */
3587
3588     unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3589     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3590
3591 #ifdef PERL_IMPLICIT_CONTEXT
3592     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3593 #else
3594     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3595 #endif
3596         my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3597         x = strrchr(temp,']');
3598         if (x == NULL) {
3599         x = strrchr(temp,'>');
3600           if (x == NULL) {
3601             /* It could be a UNIX path */
3602             x = strrchr(temp,'/');
3603           }
3604         }
3605         if (x)
3606           x[1] = '\0';
3607         else {
3608           /* Got a bare name, so use default directory */
3609           temp[0] = '.';
3610           temp[1] = '\0';
3611         }
3612
3613         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3614             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3615             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3616             p->next = head_PLOC;
3617             head_PLOC = p;
3618             my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3619         }
3620     }
3621
3622 /*  reverse order of @INC entries, skip "." since entered above */
3623
3624 #ifdef PERL_IMPLICIT_CONTEXT
3625     if (aTHX)
3626 #endif
3627     if (PL_incgv) av = GvAVn(PL_incgv);
3628
3629     for (i = 0; av && i <= AvFILL(av); i++) {
3630         dirsv = *av_fetch(av,i,TRUE);
3631
3632         if (SvROK(dirsv)) continue;
3633         dir = SvPVx(dirsv,n_a);
3634         if (strcmp(dir,".") == 0) continue;
3635         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3636             continue;
3637
3638         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3639         p->next = head_PLOC;
3640         head_PLOC = p;
3641         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3642     }
3643
3644 /* most likely spot (ARCHLIB) put first in the list */
3645
3646 #ifdef ARCHLIB_EXP
3647     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3648         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3649         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3650         p->next = head_PLOC;
3651         head_PLOC = p;
3652         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3653     }
3654 #endif
3655     PerlMem_free(unixdir);
3656 }
3657
3658 static I32
3659 Perl_cando_by_name_int
3660    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3661 #if !defined(PERL_IMPLICIT_CONTEXT)
3662 #define cando_by_name_int               Perl_cando_by_name_int
3663 #else
3664 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3665 #endif
3666
3667 static char *
3668 find_vmspipe(pTHX)
3669 {
3670     static int   vmspipe_file_status = 0;
3671     static char  vmspipe_file[NAM$C_MAXRSS+1];
3672
3673     /* already found? Check and use ... need read+execute permission */
3674
3675     if (vmspipe_file_status == 1) {
3676         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3677          && cando_by_name_int
3678            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3679             return vmspipe_file;
3680         }
3681         vmspipe_file_status = 0;
3682     }
3683
3684     /* scan through stored @INC, $^X */
3685
3686     if (vmspipe_file_status == 0) {
3687         char file[NAM$C_MAXRSS+1];
3688         pPLOC  p = head_PLOC;
3689
3690         while (p) {
3691             char * exp_res;
3692             int dirlen;
3693             dirlen = my_strlcpy(file, p->dir, sizeof(file));
3694             my_strlcat(file, "vmspipe.com", sizeof(file));
3695             p = p->next;
3696
3697             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3698             if (!exp_res) continue;
3699
3700             if (cando_by_name_int
3701                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3702              && cando_by_name_int
3703                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3704                 vmspipe_file_status = 1;
3705                 return vmspipe_file;
3706             }
3707         }
3708         vmspipe_file_status = -1;   /* failed, use tempfiles */
3709     }
3710
3711     return 0;
3712 }
3713
3714 static FILE *
3715 vmspipe_tempfile(pTHX)
3716 {
3717     char file[NAM$C_MAXRSS+1];
3718     FILE *fp;
3719     static int index = 0;
3720     Stat_t s0, s1;
3721     int cmp_result;
3722
3723     /* create a tempfile */
3724
3725     /* we can't go from   W, shr=get to  R, shr=get without
3726        an intermediate vulnerable state, so don't bother trying...
3727
3728        and lib$spawn doesn't shr=put, so have to close the write
3729
3730        So... match up the creation date/time and the FID to
3731        make sure we're dealing with the same file
3732
3733     */
3734
3735     index++;
3736     if (!decc_filename_unix_only) {
3737       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3738       fp = fopen(file,"w");
3739       if (!fp) {
3740         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3741         fp = fopen(file,"w");
3742         if (!fp) {
3743             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3744             fp = fopen(file,"w");
3745         }
3746       }
3747      }
3748      else {
3749       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3750       fp = fopen(file,"w");
3751       if (!fp) {
3752         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3753         fp = fopen(file,"w");
3754         if (!fp) {
3755           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3756           fp = fopen(file,"w");
3757         }
3758       }
3759     }
3760     if (!fp) return 0;  /* we're hosed */
3761
3762     fprintf(fp,"$! 'f$verify(0)'\n");
3763     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3764     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3765     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3766     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3767     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3768     fprintf(fp,"$ perl_del    = \"delete\"\n");
3769     fprintf(fp,"$ pif         = \"if\"\n");
3770     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3771     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3772     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3773     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3774     fprintf(fp,"$!  --- build command line to get max possible length\n");
3775     fprintf(fp,"$c=perl_popen_cmd0\n");
3776     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3777     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3778     fprintf(fp,"$x=perl_popen_cmd3\n");
3779     fprintf(fp,"$c=c+x\n");
3780     fprintf(fp,"$ perl_on\n");
3781     fprintf(fp,"$ 'c'\n");
3782     fprintf(fp,"$ perl_status = $STATUS\n");
3783     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3784     fprintf(fp,"$ perl_exit 'perl_status'\n");
3785     fsync(fileno(fp));
3786
3787     fgetname(fp, file, 1);
3788     fstat(fileno(fp), &s0.crtl_stat);
3789     fclose(fp);
3790
3791     if (decc_filename_unix_only)
3792         int_tounixspec(file, file, NULL);
3793     fp = fopen(file,"r","shr=get");
3794     if (!fp) return 0;
3795     fstat(fileno(fp), &s1.crtl_stat);
3796
3797     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3798     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3799         fclose(fp);
3800         return 0;
3801     }
3802
3803     return fp;
3804 }
3805
3806
3807 static int vms_is_syscommand_xterm(void)
3808 {
3809     const static struct dsc$descriptor_s syscommand_dsc =
3810       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3811
3812     const static struct dsc$descriptor_s decwdisplay_dsc =
3813       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3814
3815     struct item_list_3 items[2];
3816     unsigned short dvi_iosb[4];
3817     unsigned long devchar;
3818     unsigned long devclass;
3819     int status;
3820
3821     /* Very simple check to guess if sys$command is a decterm? */
3822     /* First see if the DECW$DISPLAY: device exists */
3823     items[0].len = 4;
3824     items[0].code = DVI$_DEVCHAR;
3825     items[0].bufadr = &devchar;
3826     items[0].retadr = NULL;
3827     items[1].len = 0;
3828     items[1].code = 0;
3829
3830     status = sys$getdviw
3831         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3832
3833     if ($VMS_STATUS_SUCCESS(status)) {
3834         status = dvi_iosb[0];
3835     }
3836
3837     if (!$VMS_STATUS_SUCCESS(status)) {
3838         SETERRNO(EVMSERR, status);
3839         return -1;
3840     }
3841
3842     /* If it does, then for now assume that we are on a workstation */
3843     /* Now verify that SYS$COMMAND is a terminal */
3844     /* for creating the debugger DECTerm */
3845
3846     items[0].len = 4;
3847     items[0].code = DVI$_DEVCLASS;
3848     items[0].bufadr = &devclass;
3849     items[0].retadr = NULL;
3850     items[1].len = 0;
3851     items[1].code = 0;
3852
3853     status = sys$getdviw
3854         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3855
3856     if ($VMS_STATUS_SUCCESS(status)) {
3857         status = dvi_iosb[0];
3858     }
3859
3860     if (!$VMS_STATUS_SUCCESS(status)) {
3861         SETERRNO(EVMSERR, status);
3862         return -1;
3863     }
3864     else {
3865         if (devclass == DC$_TERM) {
3866             return 0;
3867         }
3868     }
3869     return -1;
3870 }
3871
3872 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3873 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3874 {
3875     int status;
3876     int ret_stat;
3877     char * ret_char;
3878     char device_name[65];
3879     unsigned short device_name_len;
3880     struct dsc$descriptor_s customization_dsc;
3881     struct dsc$descriptor_s device_name_dsc;
3882     const char * cptr;
3883     char customization[200];
3884     char title[40];
3885     pInfo info = NULL;
3886     char mbx1[64];
3887     unsigned short p_chan;
3888     int n;
3889     unsigned short iosb[4];
3890     const char * cust_str =
3891         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3892     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3893                                           DSC$K_CLASS_S, mbx1};
3894
3895      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3896     /*---------------------------------------*/
3897     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3898
3899
3900     /* Make sure that this is from the Perl debugger */
3901     ret_char = strstr(cmd," xterm ");
3902     if (ret_char == NULL)
3903         return NULL;
3904     cptr = ret_char + 7;
3905     ret_char = strstr(cmd,"tty");
3906     if (ret_char == NULL)
3907         return NULL;
3908     ret_char = strstr(cmd,"sleep");
3909     if (ret_char == NULL)
3910         return NULL;
3911
3912     if (decw_term_port == 0) {
3913         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3914         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3915         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3916
3917        status = lib$find_image_symbol
3918                                (&filename1_dsc,
3919                                 &decw_term_port_dsc,
3920                                 (void *)&decw_term_port,
3921                                 NULL,
3922                                 0);
3923
3924         /* Try again with the other image name */
3925         if (!$VMS_STATUS_SUCCESS(status)) {
3926
3927            status = lib$find_image_symbol
3928                                (&filename2_dsc,
3929                                 &decw_term_port_dsc,
3930                                 (void *)&decw_term_port,
3931                                 NULL,
3932                                 0);
3933
3934         }
3935
3936     }
3937
3938
3939     /* No decw$term_port, give it up */
3940     if (!$VMS_STATUS_SUCCESS(status))
3941         return NULL;
3942
3943     /* Are we on a workstation? */
3944     /* to do: capture the rows / columns and pass their properties */
3945     ret_stat = vms_is_syscommand_xterm();
3946     if (ret_stat < 0)
3947         return NULL;
3948
3949     /* Make the title: */
3950     ret_char = strstr(cptr,"-title");
3951     if (ret_char != NULL) {
3952         while ((*cptr != 0) && (*cptr != '\"')) {
3953             cptr++;
3954         }
3955         if (*cptr == '\"')
3956             cptr++;
3957         n = 0;
3958         while ((*cptr != 0) && (*cptr != '\"')) {
3959             title[n] = *cptr;
3960             n++;
3961             if (n == 39) {
3962                 title[39] = 0;
3963                 break;
3964             }
3965             cptr++;
3966         }
3967         title[n] = 0;
3968     }
3969     else {
3970             /* Default title */
3971             strcpy(title,"Perl Debug DECTerm");
3972     }
3973     sprintf(customization, cust_str, title);
3974
3975     customization_dsc.dsc$a_pointer = customization;
3976     customization_dsc.dsc$w_length = strlen(customization);
3977     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3978     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3979
3980     device_name_dsc.dsc$a_pointer = device_name;
3981     device_name_dsc.dsc$w_length = sizeof device_name -1;
3982     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3983     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3984
3985     device_name_len = 0;
3986
3987     /* Try to create the window */
3988      status = (*decw_term_port)
3989        (NULL,
3990         NULL,
3991         &customization_dsc,
3992         &device_name_dsc,
3993         &device_name_len,
3994         NULL,
3995         NULL,
3996         NULL);
3997     if (!$VMS_STATUS_SUCCESS(status)) {
3998         SETERRNO(EVMSERR, status);
3999         return NULL;
4000     }
4001
4002     device_name[device_name_len] = '\0';
4003
4004     /* Need to set this up to look like a pipe for cleanup */
4005     n = sizeof(Info);
4006     status = lib$get_vm(&n, &info);
4007     if (!$VMS_STATUS_SUCCESS(status)) {
4008         SETERRNO(ENOMEM, status);
4009         return NULL;
4010     }
4011
4012     info->mode = *mode;
4013     info->done = FALSE;
4014     info->completion = 0;
4015     info->closing    = FALSE;
4016     info->in         = 0;
4017     info->out        = 0;
4018     info->err        = 0;
4019     info->fp         = NULL;
4020     info->useFILE    = 0;
4021     info->waiting    = 0;
4022     info->in_done    = TRUE;
4023     info->out_done   = TRUE;
4024     info->err_done   = TRUE;
4025
4026     /* Assign a channel on this so that it will persist, and not login */
4027     /* We stash this channel in the info structure for reference. */
4028     /* The created xterm self destructs when the last channel is removed */
4029     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4030     /* So leave this assigned. */
4031     device_name_dsc.dsc$w_length = device_name_len;
4032     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4033     if (!$VMS_STATUS_SUCCESS(status)) {
4034         SETERRNO(EVMSERR, status);
4035         return NULL;
4036     }
4037     info->xchan_valid = 1;
4038
4039     /* Now create a mailbox to be read by the application */
4040
4041     create_mbx(&p_chan, &d_mbx1);
4042
4043     /* write the name of the created terminal to the mailbox */
4044     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4045             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4046
4047     if (!$VMS_STATUS_SUCCESS(status)) {
4048         SETERRNO(EVMSERR, status);
4049         return NULL;
4050     }
4051
4052     info->fp  = PerlIO_open(mbx1, mode);
4053
4054     /* Done with this channel */
4055     sys$dassgn(p_chan);
4056
4057     /* If any errors, then clean up */
4058     if (!info->fp) {
4059         n = sizeof(Info);
4060         _ckvmssts_noperl(lib$free_vm(&n, &info));
4061         return NULL;
4062         }
4063
4064     /* All done */
4065     return info->fp;
4066 }
4067
4068 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4069
4070 static PerlIO *
4071 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4072 {
4073     static int handler_set_up = FALSE;
4074     PerlIO * ret_fp;
4075     unsigned long int sts, flags = CLI$M_NOWAIT;
4076     /* The use of a GLOBAL table (as was done previously) rendered
4077      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4078      * environment.  Hence we've switched to LOCAL symbol table.
4079      */
4080     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4081     int j, wait = 0, n;
4082     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4083     char *in, *out, *err, mbx[512];
4084     FILE *tpipe = 0;
4085     char tfilebuf[NAM$C_MAXRSS+1];
4086     pInfo info = NULL;
4087     char cmd_sym_name[20];
4088     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4089                                       DSC$K_CLASS_S, symbol};
4090     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4091                                       DSC$K_CLASS_S, 0};
4092     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4093                                       DSC$K_CLASS_S, cmd_sym_name};
4094     struct dsc$descriptor_s *vmscmd;
4095     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4096     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4097     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4098
4099     /* Check here for Xterm create request.  This means looking for
4100      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4101      *  is possible to create an xterm.
4102      */
4103     if (*in_mode == 'r') {
4104         PerlIO * xterm_fd;
4105
4106 #if defined(PERL_IMPLICIT_CONTEXT)
4107         /* Can not fork an xterm with a NULL context */
4108         /* This probably could never happen */
4109         xterm_fd = NULL;
4110         if (aTHX != NULL)
4111 #endif
4112         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4113         if (xterm_fd != NULL)
4114             return xterm_fd;
4115     }
4116
4117     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4118
4119     /* once-per-program initialization...
4120        note that the SETAST calls and the dual test of pipe_ef
4121        makes sure that only the FIRST thread through here does
4122        the initialization...all other threads wait until it's
4123        done.
4124
4125        Yeah, uglier than a pthread call, it's got all the stuff inline
4126        rather than in a separate routine.
4127     */
4128
4129     if (!pipe_ef) {
4130         _ckvmssts_noperl(sys$setast(0));
4131         if (!pipe_ef) {
4132             unsigned long int pidcode = JPI$_PID;
4133             $DESCRIPTOR(d_delay, RETRY_DELAY);
4134             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4135             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4136             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4137         }
4138         if (!handler_set_up) {
4139           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4140           handler_set_up = TRUE;
4141         }
4142         _ckvmssts_noperl(sys$setast(1));
4143     }
4144
4145     /* see if we can find a VMSPIPE.COM */
4146
4147     tfilebuf[0] = '@';
4148     vmspipe = find_vmspipe(aTHX);
4149     if (vmspipe) {
4150         vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4151     } else {        /* uh, oh...we're in tempfile hell */
4152         tpipe = vmspipe_tempfile(aTHX);
4153         if (!tpipe) {       /* a fish popular in Boston */
4154             if (ckWARN(WARN_PIPE)) {
4155                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4156             }
4157         return NULL;
4158         }
4159         fgetname(tpipe,tfilebuf+1,1);
4160         vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4161     }
4162     vmspipedsc.dsc$a_pointer = tfilebuf;
4163
4164     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4165     if (!(sts & 1)) {
4166       switch (sts) {
4167         case RMS$_FNF:  case RMS$_DNF:
4168           set_errno(ENOENT); break;
4169         case RMS$_DIR:
4170           set_errno(ENOTDIR); break;
4171         case RMS$_DEV:
4172           set_errno(ENODEV); break;
4173         case RMS$_PRV:
4174           set_errno(EACCES); break;
4175         case RMS$_SYN:
4176           set_errno(EINVAL); break;
4177         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4178           set_errno(E2BIG); break;
4179         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4180           _ckvmssts_noperl(sts); /* fall through */
4181         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4182           set_errno(EVMSERR);
4183       }
4184       set_vaxc_errno(sts);
4185       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4186         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4187       }
4188       *psts = sts;
4189       return NULL;
4190     }
4191     n = sizeof(Info);
4192     _ckvmssts_noperl(lib$get_vm(&n, &info));
4193
4194     my_strlcpy(mode, in_mode, sizeof(mode));
4195     info->mode = *mode;
4196     info->done = FALSE;
4197     info->completion = 0;
4198     info->closing    = FALSE;
4199     info->in         = 0;
4200     info->out        = 0;
4201     info->err        = 0;
4202     info->fp         = NULL;
4203     info->useFILE    = 0;
4204     info->waiting    = 0;
4205     info->in_done    = TRUE;
4206     info->out_done   = TRUE;
4207     info->err_done   = TRUE;
4208     info->xchan      = 0;
4209     info->xchan_valid = 0;
4210
4211     in = (char *)PerlMem_malloc(VMS_MAXRSS);
4212     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4213     out = (char *)PerlMem_malloc(VMS_MAXRSS);
4214     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4215     err = (char *)PerlMem_malloc(VMS_MAXRSS);
4216     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4217
4218     in[0] = out[0] = err[0] = '\0';
4219
4220     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4221         info->useFILE = 1;
4222         strcpy(p,p+1);
4223     }
4224     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4225         wait = 1;
4226         strcpy(p,p+1);
4227     }
4228
4229     if (*mode == 'r') {             /* piping from subroutine */
4230
4231         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4232         if (info->out) {
4233             info->out->pipe_done = &info->out_done;
4234             info->out_done = FALSE;
4235             info->out->info = info;
4236         }
4237         if (!info->useFILE) {
4238             info->fp  = PerlIO_open(mbx, mode);
4239         } else {
4240             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4241             vmssetuserlnm("SYS$INPUT", mbx);
4242         }
4243
4244         if (!info->fp && info->out) {
4245             sys$cancel(info->out->chan_out);
4246
4247             while (!info->out_done) {
4248                 int done;
4249                 _ckvmssts_noperl(sys$setast(0));
4250                 done = info->out_done;
4251                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4252                 _ckvmssts_noperl(sys$setast(1));
4253                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4254             }
4255
4256             if (info->out->buf) {
4257                 n = info->out->bufsize * sizeof(char);
4258                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4259             }
4260             n = sizeof(Pipe);
4261             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4262             n = sizeof(Info);
4263             _ckvmssts_noperl(lib$free_vm(&n, &info));
4264             *psts = RMS$_FNF;
4265             return NULL;
4266         }
4267
4268         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4269         if (info->err) {
4270             info->err->pipe_done = &info->err_done;
4271             info->err_done = FALSE;
4272             info->err->info = info;
4273         }
4274
4275     } else if (*mode == 'w') {      /* piping to subroutine */
4276
4277         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4278         if (info->out) {
4279             info->out->pipe_done = &info->out_done;
4280             info->out_done = FALSE;
4281             info->out->info = info;
4282         }
4283
4284         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4285         if (info->err) {
4286             info->err->pipe_done = &info->err_done;
4287             info->err_done = FALSE;
4288             info->err->info = info;
4289         }
4290
4291         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4292         if (!info->useFILE) {
4293             info->fp  = PerlIO_open(mbx, mode);
4294         } else {
4295             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4296             vmssetuserlnm("SYS$OUTPUT", mbx);
4297         }
4298
4299         if (info->in) {
4300             info->in->pipe_done = &info->in_done;
4301             info->in_done = FALSE;
4302             info->in->info = info;
4303         }
4304
4305         /* error cleanup */
4306         if (!info->fp && info->in) {
4307             info->done = TRUE;
4308             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4309                                       0, 0, 0, 0, 0, 0, 0, 0));
4310
4311             while (!info->in_done) {
4312                 int done;
4313                 _ckvmssts_noperl(sys$setast(0));
4314                 done = info->in_done;
4315                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4316                 _ckvmssts_noperl(sys$setast(1));
4317                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4318             }
4319
4320             if (info->in->buf) {
4321                 n = info->in->bufsize * sizeof(char);
4322                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4323             }
4324             n = sizeof(Pipe);
4325             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4326             n = sizeof(Info);
4327             _ckvmssts_noperl(lib$free_vm(&n, &info));
4328             *psts = RMS$_FNF;
4329             return NULL;
4330         }
4331
4332
4333     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4334         /* Let the child inherit standard input, unless it's a directory. */
4335         Stat_t st;
4336         if (my_trnlnm("SYS$INPUT", in, 0)) {
4337             if (flex_stat(in, &st) != 0 || S_ISDIR(st.st_mode))
4338                 *in = '\0';
4339         }
4340
4341         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4342         if (info->out) {
4343             info->out->pipe_done = &info->out_done;
4344             info->out_done = FALSE;
4345             info->out->info = info;
4346         }
4347
4348         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4349         if (info->err) {
4350             info->err->pipe_done = &info->err_done;
4351             info->err_done = FALSE;
4352             info->err->info = info;
4353         }
4354     }
4355
4356     d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4357     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4358
4359     d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4360     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4361
4362     d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4363     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4364
4365     /* Done with the names for the pipes */
4366     PerlMem_free(err);
4367     PerlMem_free(out);
4368     PerlMem_free(in);
4369
4370     p = vmscmd->dsc$a_pointer;
4371     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4372     if (*p == '$') p++;                         /* remove leading $ */
4373     while (*p == ' ' || *p == '\t') p++;
4374
4375     for (j = 0; j < 4; j++) {
4376         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4377         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4378
4379     d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4380     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4381
4382         if (strlen(p) > MAX_DCL_SYMBOL) {
4383             p += MAX_DCL_SYMBOL;
4384         } else {
4385             p += strlen(p);
4386         }
4387     }
4388     _ckvmssts_noperl(sys$setast(0));
4389     info->next=open_pipes;  /* prepend to list */
4390     open_pipes=info;
4391     _ckvmssts_noperl(sys$setast(1));
4392     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4393      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4394      * have SYS$COMMAND if we need it.
4395      */
4396     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4397                       0, &info->pid, &info->completion,
4398                       0, popen_completion_ast,info,0,0,0));
4399
4400     /* if we were using a tempfile, close it now */
4401
4402     if (tpipe) fclose(tpipe);
4403
4404     /* once the subprocess is spawned, it has copied the symbols and
4405        we can get rid of ours */
4406
4407     for (j = 0; j < 4; j++) {
4408         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4409         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4410     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4411     }
4412     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4413     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4414     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4415     vms_execfree(vmscmd);
4416
4417 #ifdef PERL_IMPLICIT_CONTEXT
4418     if (aTHX)
4419 #endif
4420     PL_forkprocess = info->pid;
4421
4422     ret_fp = info->fp;
4423     if (wait) {
4424          dSAVEDERRNO;
4425          int done = 0;
4426          while (!done) {
4427              _ckvmssts_noperl(sys$setast(0));
4428              done = info->done;
4429              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4430              _ckvmssts_noperl(sys$setast(1));
4431              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4432          }
4433         *psts = info->completion;
4434 /* Caller thinks it is open and tries to close it. */
4435 /* This causes some problems, as it changes the error status */
4436 /*        my_pclose(info->fp); */
4437
4438          /* If we did not have a file pointer open, then we have to */
4439          /* clean up here or eventually we will run out of something */
4440          SAVE_ERRNO;
4441          if (info->fp == NULL) {
4442              my_pclose_pinfo(aTHX_ info);
4443          }
4444          RESTORE_ERRNO;
4445
4446     } else {
4447         *psts = info->pid;
4448     }
4449     return ret_fp;
4450 }  /* end of safe_popen */
4451
4452
4453 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4454 PerlIO *
4455 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4456 {
4457     int sts;
4458     TAINT_ENV();
4459     TAINT_PROPER("popen");
4460     PERL_FLUSHALL_FOR_CHILD;
4461     return safe_popen(aTHX_ cmd,mode,&sts);
4462 }
4463
4464 /*}}}*/
4465
4466
4467 /* Routine to close and cleanup a pipe info structure */
4468
4469 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4470
4471     unsigned long int retsts;
4472     int done, n;
4473     pInfo next, last;
4474
4475     /* If we were writing to a subprocess, insure that someone reading from
4476      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4477      * produce an EOF record in the mailbox.
4478      *
4479      *  well, at least sometimes it *does*, so we have to watch out for
4480      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4481      */
4482      if (info->fp) {
4483         if (!info->useFILE
4484 #if defined(USE_ITHREADS)
4485           && my_perl
4486 #endif
4487 #ifdef USE_PERLIO
4488           && PL_perlio_fd_refcnt
4489 #endif
4490            )
4491             PerlIO_flush(info->fp);
4492         else
4493             fflush((FILE *)info->fp);
4494     }
4495
4496     _ckvmssts(sys$setast(0));
4497      info->closing = TRUE;
4498      done = info->done && info->in_done && info->out_done && info->err_done;
4499      /* hanging on write to Perl's input? cancel it */
4500      if (info->mode == 'r' && info->out && !info->out_done) {
4501         if (info->out->chan_out) {
4502             _ckvmssts(sys$cancel(info->out->chan_out));
4503             if (!info->out->chan_in) {   /* EOF generation, need AST */
4504                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4505             }
4506         }
4507      }
4508      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4509          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4510                            0, 0, 0, 0, 0, 0));
4511     _ckvmssts(sys$setast(1));
4512     if (info->fp) {
4513      if (!info->useFILE
4514 #if defined(USE_ITHREADS)
4515          && my_perl
4516 #endif
4517 #ifdef USE_PERLIO
4518          && PL_perlio_fd_refcnt
4519 #endif
4520         )
4521         PerlIO_close(info->fp);
4522      else
4523         fclose((FILE *)info->fp);
4524     }
4525      /*
4526         we have to wait until subprocess completes, but ALSO wait until all
4527         the i/o completes...otherwise we'll be freeing the "info" structure
4528         that the i/o ASTs could still be using...
4529      */
4530
4531      while (!done) {
4532          _ckvmssts(sys$setast(0));
4533          done = info->done && info->in_done && info->out_done && info->err_done;
4534          if (!done) _ckvmssts(sys$clref(pipe_ef));
4535          _ckvmssts(sys$setast(1));
4536          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4537      }
4538      retsts = info->completion;
4539
4540     /* remove from list of open pipes */
4541     _ckvmssts(sys$setast(0));
4542     last = NULL;
4543     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4544         if (next == info)
4545             break;
4546     }
4547
4548     if (last)
4549         last->next = info->next;
4550     else
4551         open_pipes = info->next;
4552     _ckvmssts(sys$setast(1));
4553
4554     /* free buffers and structures */
4555
4556     if (info->in) {
4557         if (info->in->buf) {
4558             n = info->in->bufsize * sizeof(char);
4559             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4560         }
4561         n = sizeof(Pipe);
4562         _ckvmssts(lib$free_vm(&n, &info->in));
4563     }
4564     if (info->out) {
4565         if (info->out->buf) {
4566             n = info->out->bufsize * sizeof(char);
4567             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4568         }
4569         n = sizeof(Pipe);
4570         _ckvmssts(lib$free_vm(&n, &info->out));
4571     }
4572     if (info->err) {
4573         if (info->err->buf) {
4574             n = info->err->bufsize * sizeof(char);
4575             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4576         }
4577         n = sizeof(Pipe);
4578         _ckvmssts(lib$free_vm(&n, &info->err));
4579     }
4580     n = sizeof(Info);
4581     _ckvmssts(lib$free_vm(&n, &info));
4582
4583     return retsts;
4584 }
4585
4586
4587 /*{{{  I32 my_pclose(PerlIO *fp)*/
4588 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4589 {
4590     pInfo info, last = NULL;
4591     I32 ret_status;
4592
4593     /* Fixme - need ast and mutex protection here */
4594     for (info = open_pipes; info != NULL; last = info, info = info->next)
4595         if (info->fp == fp) break;
4596
4597     if (info == NULL) {  /* no such pipe open */
4598       set_errno(ECHILD); /* quoth POSIX */
4599       set_vaxc_errno(SS$_NONEXPR);
4600       return -1;
4601     }
4602
4603     ret_status = my_pclose_pinfo(aTHX_ info);
4604
4605     return ret_status;
4606
4607 }  /* end of my_pclose() */
4608
4609 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4610   /* Roll our own prototype because we want this regardless of whether
4611    * _VMS_WAIT is defined.
4612    */
4613
4614 #ifdef __cplusplus
4615 extern "C" {
4616 #endif
4617   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4618 #ifdef __cplusplus
4619 }
4620 #endif
4621
4622 #endif
4623 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4624    created with popen(); otherwise partially emulate waitpid() unless
4625    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4626    Also check processes not considered by the CRTL waitpid().
4627  */
4628 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4629 Pid_t
4630 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4631 {
4632     pInfo info;
4633     int done;
4634     int sts;
4635     int j;
4636
4637     if (statusp) *statusp = 0;
4638
4639     for (info = open_pipes; info != NULL; info = info->next)
4640         if (info->pid == pid) break;
4641
4642     if (info != NULL) {  /* we know about this child */
4643       while (!info->done) {
4644           _ckvmssts(sys$setast(0));
4645           done = info->done;
4646           if (!done) _ckvmssts(sys$clref(pipe_ef));
4647           _ckvmssts(sys$setast(1));
4648           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4649       }
4650
4651       if (statusp) *statusp = info->completion;
4652       return pid;
4653     }
4654
4655     /* child that already terminated? */
4656
4657     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4658         if (closed_list[j].pid == pid) {
4659             if (statusp) *statusp = closed_list[j].completion;
4660             return pid;
4661         }
4662     }
4663
4664     /* fall through if this child is not one of our own pipe children */
4665
4666 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4667
4668       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4669        * in 7.2 did we get a version that fills in the VMS completion
4670        * status as Perl has always tried to do.
4671        */
4672
4673       sts = __vms_waitpid( pid, statusp, flags );
4674
4675       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4676          return sts;
4677
4678       /* If the real waitpid tells us the child does not exist, we
4679        * fall through here to implement waiting for a child that
4680        * was created by some means other than exec() (say, spawned
4681        * from DCL) or to wait for a process that is not a subprocess
4682        * of the current process.
4683        */
4684
4685 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4686
4687     {
4688       $DESCRIPTOR(intdsc,"0 00:00:01");
4689       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4690       unsigned long int pidcode = JPI$_PID, mypid;
4691       unsigned long int interval[2];
4692       unsigned int jpi_iosb[2];
4693       struct itmlst_3 jpilist[2] = {
4694           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4695           {                      0,         0,                 0, 0}
4696       };
4697
4698       if (pid <= 0) {
4699         /* Sorry folks, we don't presently implement rooting around for
4700            the first child we can find, and we definitely don't want to
4701            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4702          */
4703         set_errno(ENOTSUP);
4704         return -1;
4705       }
4706
4707       /* Get the owner of the child so I can warn if it's not mine. If the
4708        * process doesn't exist or I don't have the privs to look at it,
4709        * I can go home early.
4710        */
4711       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4712       if (sts & 1) sts = jpi_iosb[0];
4713       if (!(sts & 1)) {
4714         switch (sts) {
4715             case SS$_NONEXPR:
4716                 set_errno(ECHILD);
4717                 break;
4718             case SS$_NOPRIV:
4719                 set_errno(EACCES);
4720                 break;
4721             default:
4722                 _ckvmssts(sts);
4723         }
4724         set_vaxc_errno(sts);
4725         return -1;
4726       }
4727
4728       if (ckWARN(WARN_EXEC)) {
4729         /* remind folks they are asking for non-standard waitpid behavior */
4730         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4731         if (ownerpid != mypid)
4732           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4733                       "waitpid: process %x is not a child of process %x",
4734                       pid,mypid);
4735       }
4736
4737       /* simply check on it once a second until it's not there anymore. */
4738
4739       _ckvmssts(sys$bintim(&intdsc,interval));
4740       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4741             _ckvmssts(sys$schdwk(0,0,interval,0));
4742             _ckvmssts(sys$hiber());
4743       }
4744       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4745
4746       _ckvmssts(sts);
4747       return pid;
4748     }
4749 }  /* end of waitpid() */
4750 /*}}}*/
4751 /*}}}*/
4752 /*}}}*/
4753
4754 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4755 char *
4756 my_gconvert(double val, int ndig, int trail, char *buf)
4757 {
4758   static char __gcvtbuf[DBL_DIG+1];
4759   char *loc;
4760
4761   loc = buf ? buf : __gcvtbuf;
4762
4763   if (val) {
4764     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4765     return gcvt(val,ndig,loc);
4766   }
4767   else {
4768     loc[0] = '0'; loc[1] = '\0';
4769     return loc;
4770   }
4771
4772 }
4773 /*}}}*/
4774
4775 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4776 static int rms_free_search_context(struct FAB * fab)
4777 {
4778 struct NAM * nam;
4779
4780     nam = fab->fab$l_nam;
4781     nam->nam$b_nop |= NAM$M_SYNCHK;
4782     nam->nam$l_rlf = NULL;
4783     fab->fab$b_dns = 0;
4784     return sys$parse(fab, NULL, NULL);
4785 }
4786
4787 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4788 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4789 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4790 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4791 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4792 #define rms_nam_esll(nam) nam.nam$b_esl
4793 #define rms_nam_esl(nam) nam.nam$b_esl
4794 #define rms_nam_name(nam) nam.nam$l_name
4795 #define rms_nam_namel(nam) nam.nam$l_name
4796 #define rms_nam_type(nam) nam.nam$l_type
4797 #define rms_nam_typel(nam) nam.nam$l_type
4798 #define rms_nam_ver(nam) nam.nam$l_ver
4799 #define rms_nam_verl(nam) nam.nam$l_ver
4800 #define rms_nam_rsll(nam) nam.nam$b_rsl
4801 #define rms_nam_rsl(nam) nam.nam$b_rsl
4802 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4803 #define rms_set_fna(fab, nam, name, size) \
4804         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4805 #define rms_get_fna(fab, nam) fab.fab$l_fna
4806 #define rms_set_dna(fab, nam, name, size) \
4807         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4808 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4809 #define rms_set_esa(nam, name, size) \
4810         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4811 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4812         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4813 #define rms_set_rsa(nam, name, size) \
4814         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4815 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4816         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4817 #define rms_nam_name_type_l_size(nam) \
4818         (nam.nam$b_name + nam.nam$b_type)
4819 #else
4820 static int rms_free_search_context(struct FAB * fab)
4821 {
4822 struct NAML * nam;
4823
4824     nam = fab->fab$l_naml;
4825     nam->naml$b_nop |= NAM$M_SYNCHK;
4826     nam->naml$l_rlf = NULL;
4827     nam->naml$l_long_defname_size = 0;
4828
4829     fab->fab$b_dns = 0;
4830     return sys$parse(fab, NULL, NULL);
4831 }
4832
4833 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4834 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4835 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4836 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4837 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4838 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4839 #define rms_nam_esl(nam) nam.naml$b_esl
4840 #define rms_nam_name(nam) nam.naml$l_name
4841 #define rms_nam_namel(nam) nam.naml$l_long_name
4842 #define rms_nam_type(nam) nam.naml$l_type
4843 #define rms_nam_typel(nam) nam.naml$l_long_type
4844 #define rms_nam_ver(nam) nam.naml$l_ver
4845 #define rms_nam_verl(nam) nam.naml$l_long_ver
4846 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4847 #define rms_nam_rsl(nam) nam.naml$b_rsl
4848 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4849 #define rms_set_fna(fab, nam, name, size) \
4850         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4851         nam.naml$l_long_filename_size = size; \
4852         nam.naml$l_long_filename = name;}
4853 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4854 #define rms_set_dna(fab, nam, name, size) \
4855         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4856         nam.naml$l_long_defname_size = size; \
4857         nam.naml$l_long_defname = name; }
4858 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4859 #define rms_set_esa(nam, name, size) \
4860         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4861         nam.naml$l_long_expand_alloc = size; \
4862         nam.naml$l_long_expand = name; }
4863 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4864         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4865         nam.naml$l_long_expand = l_name; \
4866         nam.naml$l_long_expand_alloc = l_size; }
4867 #define rms_set_rsa(nam, name, size) \
4868         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4869         nam.naml$l_long_result = name; \
4870         nam.naml$l_long_result_alloc = size; }
4871 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4872         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4873         nam.naml$l_long_result = l_name; \
4874         nam.naml$l_long_result_alloc = l_size; }
4875 #define rms_nam_name_type_l_size(nam) \
4876         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4877 #endif
4878
4879
4880 /* rms_erase
4881  * The CRTL for 8.3 and later can create symbolic links in any mode,
4882  * however in 8.3 the unlink/remove/delete routines will only properly handle
4883  * them if one of the PCP modes is active.
4884  */
4885 static int rms_erase(const char * vmsname)
4886 {
4887   int status;
4888   struct FAB myfab = cc$rms_fab;
4889   rms_setup_nam(mynam);
4890
4891   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4892   rms_bind_fab_nam(myfab, mynam);
4893
4894 #ifdef NAML$M_OPEN_SPECIAL
4895   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4896 #endif
4897
4898   status = sys$erase(&myfab, 0, 0);
4899
4900   return status;
4901 }
4902
4903
4904 static int
4905 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4906                     const struct dsc$descriptor_s * vms_dst_dsc,
4907                     unsigned long flags)
4908 {
4909     /*  VMS and UNIX handle file permissions differently and the
4910      * the same ACL trick may be needed for renaming files,
4911      * especially if they are directories.
4912      */
4913
4914    /* todo: get kill_file and rename to share common code */
4915    /* I can not find online documentation for $change_acl
4916     * it appears to be replaced by $set_security some time ago */
4917
4918 const unsigned int access_mode = 0;
4919 $DESCRIPTOR(obj_file_dsc,"FILE");
4920 char *vmsname;
4921 char *rslt;
4922 unsigned long int jpicode = JPI$_UIC;
4923 int aclsts, fndsts, rnsts = -1;
4924 unsigned int ctx = 0;
4925 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4926 struct dsc$descriptor_s * clean_dsc;
4927
4928 struct myacedef {
4929     unsigned char myace$b_length;
4930     unsigned char myace$b_type;
4931     unsigned short int myace$w_flags;
4932     unsigned long int myace$l_access;
4933     unsigned long int myace$l_ident;
4934 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4935              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4936              0},
4937              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4938
4939 struct item_list_3
4940         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4941                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4942                       {0,0,0,0}},
4943         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4944         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4945                      {0,0,0,0}};
4946
4947
4948     /* Expand the input spec using RMS, since we do not want to put
4949      * ACLs on the target of a symbolic link */
4950     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
4951     if (vmsname == NULL)
4952         return SS$_INSFMEM;
4953
4954     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4955                         vmsname,
4956                         PERL_RMSEXPAND_M_SYMLINK);
4957     if (rslt == NULL) {
4958         PerlMem_free(vmsname);
4959         return SS$_INSFMEM;
4960     }
4961
4962     /* So we get our own UIC to use as a rights identifier,
4963      * and the insert an ACE at the head of the ACL which allows us
4964      * to delete the file.
4965      */
4966     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4967
4968     fildsc.dsc$w_length = strlen(vmsname);
4969     fildsc.dsc$a_pointer = vmsname;
4970     ctx = 0;
4971     newace.myace$l_ident = oldace.myace$l_ident;
4972     rnsts = SS$_ABORT;
4973
4974     /* Grab any existing ACEs with this identifier in case we fail */
4975     clean_dsc = &fildsc;
4976     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4977                                &fildsc,
4978                                NULL,
4979                                OSS$M_WLOCK,
4980                                findlst,
4981                                &ctx,
4982                                &access_mode);
4983
4984     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4985         /* Add the new ACE . . . */
4986
4987         /* if the sys$get_security succeeded, then ctx is valid, and the
4988          * object/file descriptors will be ignored.  But otherwise they
4989          * are needed
4990          */
4991         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4992                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4993         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4994             set_errno(EVMSERR);
4995             set_vaxc_errno(aclsts);
4996             PerlMem_free(vmsname);
4997             return aclsts;
4998         }
4999
5000         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5001                                 NULL, NULL,
5002                                 &flags,
5003                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5004
5005         if ($VMS_STATUS_SUCCESS(rnsts)) {
5006             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5007         }
5008
5009         /* Put things back the way they were. */
5010         ctx = 0;
5011         aclsts = sys$get_security(&obj_file_dsc,
5012                                   clean_dsc,
5013                                   NULL,
5014                                   OSS$M_WLOCK,
5015                                   findlst,
5016                                   &ctx,
5017                                   &access_mode);
5018
5019         if ($VMS_STATUS_SUCCESS(aclsts)) {
5020         int sec_flags;
5021
5022             sec_flags = 0;
5023             if (!$VMS_STATUS_SUCCESS(fndsts))
5024                 sec_flags = OSS$M_RELCTX;
5025
5026             /* Get rid of the new ACE */
5027             aclsts = sys$set_security(NULL, NULL, NULL,
5028                                   sec_flags, dellst, &ctx, &access_mode);
5029
5030             /* If there was an old ACE, put it back */
5031             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5032                 addlst[0].bufadr = &oldace;
5033                 aclsts = sys$set_security(NULL, NULL, NULL,
5034                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5035                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5036                     set_errno(EVMSERR);
5037                     set_vaxc_errno(aclsts);
5038                     rnsts = aclsts;
5039                 }
5040             } else {
5041             int aclsts2;
5042
5043                 /* Try to clear the lock on the ACL list */
5044                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5045                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5046
5047                 /* Rename errors are most important */
5048                 if (!$VMS_STATUS_SUCCESS(rnsts))
5049                     aclsts = rnsts;
5050                 set_errno(EVMSERR);
5051                 set_vaxc_errno(aclsts);
5052                 rnsts = aclsts;
5053             }
5054         }
5055         else {
5056             if (aclsts != SS$_ACLEMPTY)
5057                 rnsts = aclsts;
5058         }
5059     }
5060     else
5061         rnsts = fndsts;
5062
5063     PerlMem_free(vmsname);
5064     return rnsts;
5065 }
5066
5067
5068 /*{{{int rename(const char *, const char * */
5069 /* Not exactly what X/Open says to do, but doing it absolutely right
5070  * and efficiently would require a lot more work.  This should be close
5071  * enough to pass all but the most strict X/Open compliance test.
5072  */
5073 int
5074 Perl_rename(pTHX_ const char *src, const char * dst)
5075 {
5076 int retval;
5077 int pre_delete = 0;
5078 int src_sts;
5079 int dst_sts;
5080 Stat_t src_st;
5081 Stat_t dst_st;
5082
5083     /* Validate the source file */
5084     src_sts = flex_lstat(src, &src_st);
5085     if (src_sts != 0) {
5086
5087         /* No source file or other problem */
5088         return src_sts;
5089     }
5090     if (src_st.st_devnam[0] == 0)  {
5091         /* This may be possible so fail if it is seen. */
5092         errno = EIO;
5093         return -1;
5094     }
5095
5096     dst_sts = flex_lstat(dst, &dst_st);
5097     if (dst_sts == 0) {
5098
5099         if (dst_st.st_dev != src_st.st_dev) {
5100             /* Must be on the same device */
5101             errno = EXDEV;
5102             return -1;
5103         }
5104
5105         /* VMS_INO_T_COMPARE is true if the inodes are different
5106          * to match the output of memcmp
5107          */
5108
5109         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5110             /* That was easy, the files are the same! */
5111             return 0;
5112         }
5113
5114         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5115             /* If source is a directory, so must be dest */
5116                 errno = EISDIR;
5117                 return -1;
5118         }
5119
5120     }
5121
5122
5123     if ((dst_sts == 0) &&
5124         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5125
5126         /* We have issues here if vms_unlink_all_versions is set
5127          * If the destination exists, and is not a directory, then
5128          * we must delete in advance.
5129          *
5130          * If the src is a directory, then we must always pre-delete
5131          * the destination.
5132          *
5133          * If we successfully delete the dst in advance, and the rename fails
5134          * X/Open requires that errno be EIO.
5135          *
5136          */
5137
5138         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5139             int d_sts;
5140             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5141                                      S_ISDIR(dst_st.st_mode));
5142
5143            /* Need to delete all versions ? */
5144            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5145                 int i = 0;
5146
5147                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5148                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5149                     if (d_sts != 0)
5150                         break;
5151                     i++;
5152
5153                     /* Make sure that we do not loop forever */
5154                     if (i > 32767) {
5155                         errno = EIO;
5156                         d_sts = -1;
5157                         break;
5158                     }
5159                 }
5160            }
5161
5162             if (d_sts != 0)
5163                 return d_sts;
5164
5165             /* We killed the destination, so only errno now is EIO */
5166             pre_delete = 1;
5167         }
5168     }
5169
5170     /* Originally the idea was to call the CRTL rename() and only
5171      * try the lib$rename_file if it failed.
5172      * It turns out that there are too many variants in what the
5173      * the CRTL rename might do, so only use lib$rename_file
5174      */
5175     retval = -1;
5176
5177     {
5178         /* Is the source and dest both in VMS format */
5179         /* if the source is a directory, then need to fileify */
5180         /*  and dest must be a directory or non-existent. */
5181
5182         char * vms_dst;
5183         int sts;
5184         char * ret_str;
5185         unsigned long flags;
5186         struct dsc$descriptor_s old_file_dsc;
5187         struct dsc$descriptor_s new_file_dsc;
5188
5189         /* We need to modify the src and dst depending
5190          * on if one or more of them are directories.
5191          */
5192
5193         vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
5194         if (vms_dst == NULL)
5195             _ckvmssts_noperl(SS$_INSFMEM);
5196
5197         if (S_ISDIR(src_st.st_mode)) {
5198         char * ret_str;
5199         char * vms_dir_file;
5200
5201             vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
5202             if (vms_dir_file == NULL)
5203                 _ckvmssts_noperl(SS$_INSFMEM);
5204
5205             /* If the dest is a directory, we must remove it */
5206             if (dst_sts == 0) {
5207                 int d_sts;
5208                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5209                 if (d_sts != 0) {
5210                     PerlMem_free(vms_dst);
5211                     errno = EIO;
5212                     return d_sts;
5213                 }
5214
5215                 pre_delete = 1;
5216             }
5217
5218            /* The dest must be a VMS file specification */
5219            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5220            if (ret_str == NULL) {
5221                 PerlMem_free(vms_dst);
5222                 errno = EIO;
5223                 return -1;
5224            }
5225
5226             /* The source must be a file specification */
5227             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5228             if (ret_str == NULL) {
5229                 PerlMem_free(vms_dst);
5230                 PerlMem_free(vms_dir_file);
5231                 errno = EIO;
5232                 return -1;
5233             }
5234             PerlMem_free(vms_dst);
5235             vms_dst = vms_dir_file;
5236
5237         } else {
5238             /* File to file or file to new dir */
5239
5240             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5241                 /* VMS pathify a dir target */
5242                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5243                 if (ret_str == NULL) {
5244                     PerlMem_free(vms_dst);
5245                     errno = EIO;
5246                     return -1;
5247                 }
5248             } else {
5249                 char * v_spec, * r_spec, * d_spec, * n_spec;
5250                 char * e_spec, * vs_spec;
5251                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5252
5253                 /* fileify a target VMS file specification */
5254                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5255                 if (ret_str == NULL) {
5256                     PerlMem_free(vms_dst);
5257                     errno = EIO;
5258                     return -1;
5259                 }
5260
5261                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5262                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5263                              &e_len, &vs_spec, &vs_len);
5264                 if (sts == 0) {
5265                      if (e_len == 0) {
5266                          /* Get rid of the version */
5267                          if (vs_len != 0) {
5268                              *vs_spec = '\0';
5269                          }
5270                          /* Need to specify a '.' so that the extension */
5271                          /* is not inherited */
5272                          strcat(vms_dst,".");
5273                      }
5274                 }
5275             }
5276         }
5277
5278         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5279         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5280         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5281         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5282
5283         new_file_dsc.dsc$a_pointer = vms_dst;
5284         new_file_dsc.dsc$w_length = strlen(vms_dst);
5285         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5286         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5287
5288         flags = 0;
5289 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5290         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5291 #endif
5292
5293         sts = lib$rename_file(&old_file_dsc,
5294                               &new_file_dsc,
5295                               NULL, NULL,
5296                               &flags,
5297                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5298         if (!$VMS_STATUS_SUCCESS(sts)) {
5299
5300            /* We could have failed because VMS style permissions do not
5301             * permit renames that UNIX will allow.  Just like the hack
5302             * in for kill_file.
5303             */
5304            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5305         }
5306
5307         PerlMem_free(vms_dst);
5308         if (!$VMS_STATUS_SUCCESS(sts)) {
5309             errno = EIO;
5310             return -1;
5311         }
5312         retval = 0;
5313     }
5314
5315     if (vms_unlink_all_versions) {
5316         /* Now get rid of any previous versions of the source file that
5317          * might still exist
5318          */
5319         int i = 0;
5320         dSAVEDERRNO;
5321         SAVE_ERRNO;
5322         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5323                                    S_ISDIR(src_st.st_mode));
5324         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5325              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5326                                        S_ISDIR(src_st.st_mode));
5327              if (src_sts != 0)
5328                  break;
5329              i++;
5330
5331              /* Make sure that we do not loop forever */
5332              if (i > 32767) {
5333                  src_sts = -1;
5334                  break;
5335              }
5336         }
5337         RESTORE_ERRNO;
5338     }
5339
5340     /* We deleted the destination, so must force the error to be EIO */
5341     if ((retval != 0) && (pre_delete != 0))
5342         errno = EIO;
5343
5344     return retval;
5345 }
5346 /*}}}*/
5347
5348
5349 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5350 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5351  * to expand file specification.  Allows for a single default file
5352  * specification and a simple mask of options.  If outbuf is non-NULL,
5353  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5354  * the resultant file specification is placed.  If outbuf is NULL, the
5355  * resultant file specification is placed into a static buffer.
5356  * The third argument, if non-NULL, is taken to be a default file
5357  * specification string.  The fourth argument is unused at present.
5358  * rmesexpand() returns the address of the resultant string if
5359  * successful, and NULL on error.
5360  *
5361  * New functionality for previously unused opts value:
5362  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5363  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5364  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5365  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5366  */
5367 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5368
5369 static char *
5370 int_rmsexpand
5371    (const char *filespec,
5372     char *outbuf,
5373     const char *defspec,
5374     unsigned opts,
5375     int * fs_utf8,
5376     int * dfs_utf8)
5377 {
5378   char * ret_spec;
5379   const char * in_spec;
5380   char * spec_buf;
5381   const char * def_spec;
5382   char * vmsfspec, *vmsdefspec;
5383   char * esa;
5384   char * esal = NULL;
5385   char * outbufl;
5386   struct FAB myfab = cc$rms_fab;
5387   rms_setup_nam(mynam);
5388   STRLEN speclen;
5389   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5390   int sts;
5391
5392   /* temp hack until UTF8 is actually implemented */
5393   if (fs_utf8 != NULL)
5394     *fs_utf8 = 0;
5395
5396   if (!filespec || !*filespec) {
5397     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5398     return NULL;
5399   }
5400
5401   vmsfspec = NULL;
5402   vmsdefspec = NULL;
5403   outbufl = NULL;
5404
5405   in_spec = filespec;
5406   isunix = 0;
5407   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5408       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5409       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5410
5411       /* If this is a UNIX file spec, convert it to VMS */
5412       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5413                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5414                            &e_len, &vs_spec, &vs_len);
5415       if (sts != 0) {
5416           isunix = 1;
5417           char * ret_spec;
5418
5419           vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5420           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5421           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5422           if (ret_spec == NULL) {
5423               PerlMem_free(vmsfspec);
5424               return NULL;
5425           }
5426           in_spec = (const char *)vmsfspec;
5427
5428           /* Unless we are forcing to VMS format, a UNIX input means
5429            * UNIX output, and that requires long names to be used
5430            */
5431           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5432 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5433               opts |= PERL_RMSEXPAND_M_LONG;
5434 #else
5435               NOOP;
5436 #endif
5437           else
5438               isunix = 0;
5439       }
5440
5441   }
5442
5443   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5444   rms_bind_fab_nam(myfab, mynam);
5445
5446   /* Process the default file specification if present */
5447   def_spec = defspec;
5448   if (defspec && *defspec) {
5449     int t_isunix;
5450     t_isunix = is_unix_filespec(defspec);
5451     if (t_isunix) {
5452       vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5453       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5454       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5455
5456       if (ret_spec == NULL) {
5457           /* Clean up and bail */
5458           PerlMem_free(vmsdefspec);
5459           if (vmsfspec != NULL)
5460               PerlMem_free(vmsfspec);
5461               return NULL;
5462           }
5463           def_spec = (const char *)vmsdefspec;
5464       }
5465       rms_set_dna(myfab, mynam,
5466                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5467   }
5468
5469   /* Now we need the expansion buffers */
5470   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
5471   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5472 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5473   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
5474   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5475 #endif
5476   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5477
5478   /* If a NAML block is used RMS always writes to the long and short
5479    * addresses unless you suppress the short name.
5480    */
5481 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5482   outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
5483   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5484 #endif
5485    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5486
5487 #ifdef NAM$M_NO_SHORT_UPCASE
5488   if (decc_efs_case_preserve)
5489     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5490 #endif
5491
5492    /* We may not want to follow symbolic links */
5493 #ifdef NAML$M_OPEN_SPECIAL
5494   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5495     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5496 #endif
5497
5498   /* First attempt to parse as an existing file */
5499   retsts = sys$parse(&myfab,0,0);
5500   if (!(retsts & STS$K_SUCCESS)) {
5501
5502     /* Could not find the file, try as syntax only if error is not fatal */
5503     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5504     if (retsts == RMS$_DNF ||
5505         retsts == RMS$_DIR ||
5506         retsts == RMS$_DEV ||
5507         retsts == RMS$_PRV) {
5508       retsts = sys$parse(&myfab,0,0);
5509       if (retsts & STS$K_SUCCESS) goto int_expanded;
5510     }
5511
5512      /* Still could not parse the file specification */
5513     /*----------------------------------------------*/
5514     sts = rms_free_search_context(&myfab); /* Free search context */
5515     if (vmsdefspec != NULL)
5516         PerlMem_free(vmsdefspec);
5517     if (vmsfspec != NULL)
5518         PerlMem_free(vmsfspec);
5519     if (outbufl != NULL)
5520         PerlMem_free(outbufl);
5521     PerlMem_free(esa);
5522     if (esal != NULL)
5523         PerlMem_free(esal);
5524     set_vaxc_errno(retsts);
5525     if      (retsts == RMS$_PRV) set_errno(EACCES);
5526     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5527     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5528     else                         set_errno(EVMSERR);
5529     return NULL;
5530   }
5531   retsts = sys$search(&myfab,0,0);
5532   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5533     sts = rms_free_search_context(&myfab); /* Free search context */
5534     if (vmsdefspec != NULL)
5535         PerlMem_free(vmsdefspec);
5536     if (vmsfspec != NULL)
5537         PerlMem_free(vmsfspec);
5538     if (outbufl != NULL)
5539         PerlMem_free(outbufl);
5540     PerlMem_free(esa);
5541     if (esal != NULL)
5542         PerlMem_free(esal);
5543     set_vaxc_errno(retsts);
5544     if      (retsts == RMS$_PRV) set_errno(EACCES);
5545     else                         set_errno(EVMSERR);
5546     return NULL;
5547   }
5548
5549   /* If the input filespec contained any lowercase characters,
5550    * downcase the result for compatibility with Unix-minded code. */
5551 int_expanded:
5552   if (!decc_efs_case_preserve) {
5553     char * tbuf;
5554     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5555       if (islower(*tbuf)) { haslower = 1; break; }
5556   }
5557
5558    /* Is a long or a short name expected */
5559   /*------------------------------------*/
5560   spec_buf = NULL;
5561 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5562   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5563     if (rms_nam_rsll(mynam)) {
5564         spec_buf = outbufl;
5565         speclen = rms_nam_rsll(mynam);
5566     }
5567     else {
5568         spec_buf = esal; /* Not esa */
5569         speclen = rms_nam_esll(mynam);
5570     }
5571   }
5572   else {
5573 #endif
5574     if (rms_nam_rsl(mynam)) {
5575         spec_buf = outbuf;
5576         speclen = rms_nam_rsl(mynam);
5577     }
5578     else {
5579         spec_buf = esa; /* Not esal */
5580         speclen = rms_nam_esl(mynam);
5581     }
5582 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5583   }
5584 #endif
5585   spec_buf[speclen] = '\0';
5586
5587   /* Trim off null fields added by $PARSE
5588    * If type > 1 char, must have been specified in original or default spec
5589    * (not true for version; $SEARCH may have added version of existing file).
5590    */
5591   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5592   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5593     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5594              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5595   }
5596   else {
5597     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5598              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5599   }
5600   if (trimver || trimtype) {
5601     if (defspec && *defspec) {
5602       char *defesal = NULL;
5603       char *defesa = NULL;
5604       defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5605       if (defesa != NULL) {
5606         struct FAB deffab = cc$rms_fab;
5607 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5608         defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5609         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5610 #endif
5611         rms_setup_nam(defnam);
5612
5613         rms_bind_fab_nam(deffab, defnam);
5614
5615         /* Cast ok */
5616         rms_set_fna
5617             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5618
5619         /* RMS needs the esa/esal as a work area if wildcards are involved */
5620         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5621
5622         rms_clear_nam_nop(defnam);
5623         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5624 #ifdef NAM$M_NO_SHORT_UPCASE
5625         if (decc_efs_case_preserve)
5626           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5627 #endif
5628 #ifdef NAML$M_OPEN_SPECIAL
5629         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5630           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5631 #endif
5632         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5633           if (trimver) {
5634              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5635           }
5636           if (trimtype) {
5637             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5638           }
5639         }
5640         if (defesal != NULL)
5641             PerlMem_free(defesal);
5642         PerlMem_free(defesa);
5643       } else {
5644           _ckvmssts_noperl(SS$_INSFMEM);
5645       }
5646     }
5647     if (trimver) {
5648       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5649         if (*(rms_nam_verl(mynam)) != '\"')
5650           speclen = rms_nam_verl(mynam) - spec_buf;
5651       }
5652       else {
5653         if (*(rms_nam_ver(mynam)) != '\"')
5654           speclen = rms_nam_ver(mynam) - spec_buf;
5655       }
5656     }
5657     if (trimtype) {
5658       /* If we didn't already trim version, copy down */
5659       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5660         if (speclen > rms_nam_verl(mynam) - spec_buf)
5661           memmove
5662            (rms_nam_typel(mynam),
5663             rms_nam_verl(mynam),
5664             speclen - (rms_nam_verl(mynam) - spec_buf));
5665           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5666       }
5667       else {
5668         if (speclen > rms_nam_ver(mynam) - spec_buf)
5669           memmove
5670            (rms_nam_type(mynam),
5671             rms_nam_ver(mynam),
5672             speclen - (rms_nam_ver(mynam) - spec_buf));
5673           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5674       }
5675     }
5676   }
5677
5678    /* Done with these copies of the input files */
5679   /*-------------------------------------------*/
5680   if (vmsfspec != NULL)
5681         PerlMem_free(vmsfspec);
5682   if (vmsdefspec != NULL)
5683         PerlMem_free(vmsdefspec);
5684
5685   /* If we just had a directory spec on input, $PARSE "helpfully"
5686    * adds an empty name and type for us */
5687 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5688   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5689     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5690         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5691         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5692       speclen = rms_nam_namel(mynam) - spec_buf;
5693   }
5694   else
5695 #endif
5696   {
5697     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5698         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5699         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5700       speclen = rms_nam_name(mynam) - spec_buf;
5701   }
5702
5703   /* Posix format specifications must have matching quotes */
5704   if (speclen < (VMS_MAXRSS - 1)) {
5705     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5706       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5707         spec_buf[speclen] = '\"';
5708         speclen++;
5709       }
5710     }
5711   }
5712   spec_buf[speclen] = '\0';
5713   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5714
5715   /* Have we been working with an expanded, but not resultant, spec? */
5716   /* Also, convert back to Unix syntax if necessary. */
5717   {
5718   int rsl;
5719
5720 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5721     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5722       rsl = rms_nam_rsll(mynam);
5723     } else
5724 #endif
5725     {
5726       rsl = rms_nam_rsl(mynam);
5727     }
5728     if (!rsl) {
5729       /* rsl is not present, it means that spec_buf is either */
5730       /* esa or esal, and needs to be copied to outbuf */
5731       /* convert to Unix if desired */
5732       if (isunix) {
5733         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5734       } else {
5735         /* VMS file specs are not in UTF-8 */
5736         if (fs_utf8 != NULL)
5737             *fs_utf8 = 0;
5738         my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5739         ret_spec = outbuf;
5740       }
5741     }
5742     else {
5743       /* Now spec_buf is either outbuf or outbufl */
5744       /* We need the result into outbuf */
5745       if (isunix) {
5746            /* If we need this in UNIX, then we need another buffer */
5747            /* to keep things in order */
5748            char * src;
5749            char * new_src = NULL;
5750            if (spec_buf == outbuf) {
5751                new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
5752                my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5753            } else {
5754                src = spec_buf;
5755            }
5756            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5757            if (new_src) {
5758                PerlMem_free(new_src);
5759            }
5760       } else {
5761            /* VMS file specs are not in UTF-8 */
5762            if (fs_utf8 != NULL)
5763                *fs_utf8 = 0;
5764
5765            /* Copy the buffer if needed */
5766            if (outbuf != spec_buf)
5767                my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5768            ret_spec = outbuf;
5769       }
5770     }
5771   }
5772
5773   /* Need to clean up the search context */
5774   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5775   sts = rms_free_search_context(&myfab); /* Free search context */
5776
5777   /* Clean up the extra buffers */
5778   if (esal != NULL)
5779       PerlMem_free(esal);
5780   PerlMem_free(esa);
5781   if (outbufl != NULL)
5782      PerlMem_free(outbufl);
5783
5784   /* Return the result */
5785   return ret_spec;
5786 }
5787
5788 /* Common simple case - Expand an already VMS spec */
5789 static char *
5790 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5791     opts |= PERL_RMSEXPAND_M_VMS_IN;
5792     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5793 }
5794
5795 /* Common simple case - Expand to a VMS spec */
5796 static char *
5797 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5798     opts |= PERL_RMSEXPAND_M_VMS;
5799     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5800 }
5801
5802
5803 /* Entry point used by perl routines */
5804 static char *
5805 mp_do_rmsexpand
5806    (pTHX_ const char *filespec,
5807     char *outbuf,
5808     int ts,
5809     const char *defspec,
5810     unsigned opts,
5811     int * fs_utf8,
5812     int * dfs_utf8)
5813 {
5814     static char __rmsexpand_retbuf[VMS_MAXRSS];
5815     char * expanded, *ret_spec, *ret_buf;
5816
5817     expanded = NULL;
5818     ret_buf = outbuf;
5819     if (ret_buf == NULL) {
5820         if (ts) {
5821             Newx(expanded, VMS_MAXRSS, char);
5822             if (expanded == NULL)
5823                 _ckvmssts(SS$_INSFMEM);
5824             ret_buf = expanded;
5825         } else {
5826             ret_buf = __rmsexpand_retbuf;
5827         }
5828     }
5829
5830
5831     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5832                              opts, fs_utf8,  dfs_utf8);
5833
5834     if (ret_spec == NULL) {
5835        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5836        if (expanded)
5837            Safefree(expanded);
5838     }
5839
5840     return ret_spec;
5841 }
5842 /*}}}*/
5843 /* External entry points */
5844 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5845 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5846 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5847 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5848 char *Perl_rmsexpand_utf8
5849   (pTHX_ const char *spec, char *buf, const char *def,
5850    unsigned opt, int * fs_utf8, int * dfs_utf8)
5851 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5852 char *Perl_rmsexpand_utf8_ts
5853   (pTHX_ const char *spec, char *buf, const char *def,
5854    unsigned opt, int * fs_utf8, int * dfs_utf8)
5855 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5856
5857
5858 /*
5859 ** The following routines are provided to make life easier when
5860 ** converting among VMS-style and Unix-style directory specifications.
5861 ** All will take input specifications in either VMS or Unix syntax. On
5862 ** failure, all return NULL.  If successful, the routines listed below
5863 ** return a pointer to a buffer containing the appropriately
5864 ** reformatted spec (and, therefore, subsequent calls to that routine
5865 ** will clobber the result), while the routines of the same names with
5866 ** a _ts suffix appended will return a pointer to a mallocd string
5867 ** containing the appropriately reformatted spec.
5868 ** In all cases, only explicit syntax is altered; no check is made that
5869 ** the resulting string is valid or that the directory in question
5870 ** actually exists.
5871 **
5872 **   fileify_dirspec() - convert a directory spec into the name of the
5873 **     directory file (i.e. what you can stat() to see if it's a dir).
5874 **     The style (VMS or Unix) of the result is the same as the style
5875 **     of the parameter passed in.
5876 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5877 **     what you prepend to a filename to indicate what directory it's in).
5878 **     The style (VMS or Unix) of the result is the same as the style
5879 **     of the parameter passed in.
5880 **   tounixpath() - convert a directory spec into a Unix-style path.
5881 **   tovmspath() - convert a directory spec into a VMS-style path.
5882 **   tounixspec() - convert any file spec into a Unix-style file spec.
5883 **   tovmsspec() - convert any file spec into a VMS-style spec.
5884 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5885 **
5886 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5887 ** Permission is given to distribute this code as part of the Perl
5888 ** standard distribution under the terms of the GNU General Public
5889 ** License or the Perl Artistic License.  Copies of each may be
5890 ** found in the Perl standard distribution.
5891  */
5892
5893 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5894 static char *
5895 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5896 {
5897     unsigned long int dirlen, retlen, hasfilename = 0;
5898     char *cp1, *cp2, *lastdir;
5899     char *trndir, *vmsdir;
5900     unsigned short int trnlnm_iter_count;
5901     int sts;
5902     if (utf8_fl != NULL)
5903         *utf8_fl = 0;
5904
5905     if (!dir || !*dir) {
5906       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5907     }
5908     dirlen = strlen(dir);
5909     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5910     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5911       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5912         dir = "/sys$disk";
5913         dirlen = 9;
5914       }
5915       else
5916         dirlen = 1;
5917     }
5918     if (dirlen > (VMS_MAXRSS - 1)) {
5919       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5920       return NULL;
5921     }
5922     trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5923     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5924     if (!strpbrk(dir+1,"/]>:")  &&
5925         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5926       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5927       trnlnm_iter_count = 0;
5928       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
5929         trnlnm_iter_count++;
5930         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5931       }
5932       dirlen = strlen(trndir);
5933     }
5934     else {
5935       memcpy(trndir, dir, dirlen);
5936       trndir[dirlen] = '\0';
5937     }
5938
5939     /* At this point we are done with *dir and use *trndir which is a
5940      * copy that can be modified.  *dir must not be modified.
5941      */
5942
5943     /* If we were handed a rooted logical name or spec, treat it like a
5944      * simple directory, so that
5945      *    $ Define myroot dev:[dir.]
5946      *    ... do_fileify_dirspec("myroot",buf,1) ...
5947      * does something useful.
5948      */
5949     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5950       trndir[--dirlen] = '\0';
5951       trndir[dirlen-1] = ']';
5952     }
5953     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5954       trndir[--dirlen] = '\0';
5955       trndir[dirlen-1] = '>';
5956     }
5957
5958     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5959       /* If we've got an explicit filename, we can just shuffle the string. */
5960       if (*(cp1+1)) hasfilename = 1;
5961       /* Similarly, we can just back up a level if we've got multiple levels
5962          of explicit directories in a VMS spec which ends with directories. */
5963       else {
5964         for (cp2 = cp1; cp2 > trndir; cp2--) {
5965           if (*cp2 == '.') {
5966             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5967 /* fix-me, can not scan EFS file specs backward like this */
5968               *cp2 = *cp1; *cp1 = '\0';
5969               hasfilename = 1;
5970               break;
5971             }
5972           }
5973           if (*cp2 == '[' || *cp2 == '<') break;
5974         }
5975       }
5976     }
5977
5978     vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5979     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5980     cp1 = strpbrk(trndir,"]:>");
5981     if (cp1 && *(cp1+1) == ':')   /* DECNet node spec with :: */
5982         cp1 = strpbrk(cp1+2,"]:>");
5983
5984     if (hasfilename || !cp1) { /* filename present or not VMS */
5985
5986       if (trndir[0] == '.') {
5987         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5988           PerlMem_free(trndir);
5989           PerlMem_free(vmsdir);
5990           return int_fileify_dirspec("[]", buf, NULL);
5991         }
5992         else if (trndir[1] == '.' &&
5993                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5994           PerlMem_free(trndir);
5995           PerlMem_free(vmsdir);
5996           return int_fileify_dirspec("[-]", buf, NULL);
5997         }
5998       }
5999       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6000         dirlen -= 1;                 /* to last element */
6001         lastdir = strrchr(trndir,'/');
6002       }
6003       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6004         /* If we have "/." or "/..", VMSify it and let the VMS code
6005          * below expand it, rather than repeating the code to handle
6006          * relative components of a filespec here */
6007         do {
6008           if (*(cp1+2) == '.') cp1++;
6009           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6010             char * ret_chr;
6011             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6012                 PerlMem_free(trndir);
6013                 PerlMem_free(vmsdir);
6014                 return NULL;
6015             }
6016             if (strchr(vmsdir,'/') != NULL) {
6017               /* If int_tovmsspec() returned it, it must have VMS syntax
6018                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6019                * the time to check this here only so we avoid a recursion
6020                * loop; otherwise, gigo.
6021                */
6022               PerlMem_free(trndir);
6023               PerlMem_free(vmsdir);
6024               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6025               return NULL;
6026             }
6027             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6028                 PerlMem_free(trndir);
6029                 PerlMem_free(vmsdir);
6030                 return NULL;
6031             }
6032             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6033             PerlMem_free(trndir);
6034             PerlMem_free(vmsdir);
6035             return ret_chr;
6036           }
6037           cp1++;
6038         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6039         lastdir = strrchr(trndir,'/');
6040       }
6041       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6042         char * ret_chr;
6043         /* Ditto for specs that end in an MFD -- let the VMS code
6044          * figure out whether it's a real device or a rooted logical. */
6045
6046         /* This should not happen any more.  Allowing the fake /000000
6047          * in a UNIX pathname causes all sorts of problems when trying
6048          * to run in UNIX emulation.  So the VMS to UNIX conversions
6049          * now remove the fake /000000 directories.
6050          */
6051
6052         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6053         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6054             PerlMem_free(trndir);
6055             PerlMem_free(vmsdir);
6056             return NULL;
6057         }
6058         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6059             PerlMem_free(trndir);
6060             PerlMem_free(vmsdir);
6061             return NULL;
6062         }
6063         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6064         PerlMem_free(trndir);
6065         PerlMem_free(vmsdir);
6066         return ret_chr;
6067       }
6068       else {
6069
6070         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6071              !(lastdir = cp1 = strrchr(trndir,']')) &&
6072              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6073
6074         cp2 = strrchr(cp1,'.');
6075         if (cp2) {
6076             int e_len, vs_len = 0;
6077             int is_dir = 0;
6078             char * cp3;
6079             cp3 = strchr(cp2,';');
6080             e_len = strlen(cp2);
6081             if (cp3) {
6082                 vs_len = strlen(cp3);
6083                 e_len = e_len - vs_len;
6084             }
6085             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6086             if (!is_dir) {
6087                 if (!decc_efs_charset) {
6088                     /* If this is not EFS, then not a directory */
6089                     PerlMem_free(trndir);
6090                     PerlMem_free(vmsdir);
6091                     set_errno(ENOTDIR);
6092                     set_vaxc_errno(RMS$_DIR);
6093                     return NULL;
6094                 }
6095             } else {
6096                 /* Ok, here we have an issue, technically if a .dir shows */
6097                 /* from inside a directory, then we should treat it as */
6098                 /* xxx^.dir.dir.  But we do not have that context at this */
6099                 /* point unless this is totally restructured, so we remove */
6100                 /* The .dir for now, and fix this better later */
6101                 dirlen = cp2 - trndir;
6102             }
6103             if (decc_efs_charset && !strchr(trndir,'/')) {
6104                 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6105                 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6106
6107                 for (; cp4 > cp1; cp4--) {
6108                     if (*cp4 == '.') {
6109                         if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6110                             memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6111                             *cp4 = '^';
6112                             dirlen++;
6113                         }
6114                     }
6115                 }
6116             }
6117         }
6118
6119       }
6120
6121       retlen = dirlen + 6;
6122       memcpy(buf, trndir, dirlen);
6123       buf[dirlen] = '\0';
6124
6125       /* We've picked up everything up to the directory file name.
6126          Now just add the type and version, and we're set. */
6127       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6128           strcat(buf,".dir");
6129       else
6130           strcat(buf,".DIR");
6131       if (!decc_filename_unix_no_version)
6132           strcat(buf,";1");
6133       PerlMem_free(trndir);
6134       PerlMem_free(vmsdir);
6135       return buf;
6136     }
6137     else {  /* VMS-style directory spec */
6138
6139       char *esa, *esal, term, *cp;
6140       char *my_esa;
6141       int my_esa_len;
6142       unsigned long int cmplen, haslower = 0;
6143       struct FAB dirfab = cc$rms_fab;
6144       rms_setup_nam(savnam);
6145       rms_setup_nam(dirnam);
6146
6147       esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
6148       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6149       esal = NULL;
6150 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6151       esal = (char *)PerlMem_malloc(VMS_MAXRSS);
6152       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6153 #endif
6154       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6155       rms_bind_fab_nam(dirfab, dirnam);
6156       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6157       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6158 #ifdef NAM$M_NO_SHORT_UPCASE
6159       if (decc_efs_case_preserve)
6160         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6161 #endif
6162
6163       for (cp = trndir; *cp; cp++)
6164         if (islower(*cp)) { haslower = 1; break; }
6165       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6166         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6167             (dirfab.fab$l_sts == RMS$_DNF) ||
6168             (dirfab.fab$l_sts == RMS$_PRV)) {
6169             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6170             sts = sys$parse(&dirfab);
6171         }
6172         if (!sts) {
6173           PerlMem_free(esa);
6174           if (esal != NULL)
6175               PerlMem_free(esal);
6176           PerlMem_free(trndir);
6177           PerlMem_free(vmsdir);
6178           set_errno(EVMSERR);
6179           set_vaxc_errno(dirfab.fab$l_sts);
6180           return NULL;
6181         }
6182       }
6183       else {
6184         savnam = dirnam;
6185         /* Does the file really exist? */
6186         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6187           /* Yes; fake the fnb bits so we'll check type below */
6188           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6189         }
6190         else { /* No; just work with potential name */
6191           if (dirfab.fab$l_sts    == RMS$_FNF
6192               || dirfab.fab$l_sts == RMS$_DNF
6193               || dirfab.fab$l_sts == RMS$_FND)
6194                 dirnam = savnam;
6195           else {
6196             int fab_sts;
6197             fab_sts = dirfab.fab$l_sts;
6198             sts = rms_free_search_context(&dirfab);
6199             PerlMem_free(esa);
6200             if (esal != NULL)
6201                 PerlMem_free(esal);
6202             PerlMem_free(trndir);
6203             PerlMem_free(vmsdir);
6204             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6205             return NULL;
6206           }
6207         }
6208       }
6209
6210       /* Make sure we are using the right buffer */
6211 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6212       if (esal != NULL) {
6213         my_esa = esal;
6214         my_esa_len = rms_nam_esll(dirnam);
6215       } else {
6216 #endif
6217         my_esa = esa;
6218         my_esa_len = rms_nam_esl(dirnam);
6219 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6220       }
6221 #endif
6222       my_esa[my_esa_len] = '\0';
6223       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6224         cp1 = strchr(my_esa,']');
6225         if (!cp1) cp1 = strchr(my_esa,'>');
6226         if (cp1) {  /* Should always be true */
6227           my_esa_len -= cp1 - my_esa - 1;
6228           memmove(my_esa, cp1 + 1, my_esa_len);
6229         }
6230       }
6231       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6232         /* Yep; check version while we're at it, if it's there. */
6233         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6234         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6235           /* Something other than .DIR[;1].  Bzzt. */
6236           sts = rms_free_search_context(&dirfab);
6237           PerlMem_free(esa);
6238           if (esal != NULL)
6239              PerlMem_free(esal);
6240           PerlMem_free(trndir);
6241           PerlMem_free(vmsdir);
6242           set_errno(ENOTDIR);
6243           set_vaxc_errno(RMS$_DIR);
6244           return NULL;
6245         }
6246       }
6247
6248       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6249         /* They provided at least the name; we added the type, if necessary, */
6250         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6251         sts = rms_free_search_context(&dirfab);
6252         PerlMem_free(trndir);
6253         PerlMem_free(esa);
6254         if (esal != NULL)
6255             PerlMem_free(esal);
6256         PerlMem_free(vmsdir);
6257         return buf;
6258       }
6259       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6260         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6261         *cp1 = '\0';
6262         my_esa_len -= 9;
6263       }
6264       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6265       if (cp1 == NULL) { /* should never happen */
6266         sts = rms_free_search_context(&dirfab);
6267         PerlMem_free(trndir);
6268         PerlMem_free(esa);
6269         if (esal != NULL)
6270             PerlMem_free(esal);
6271         PerlMem_free(vmsdir);
6272         return NULL;
6273       }
6274       term = *cp1;
6275       *cp1 = '\0';
6276       retlen = strlen(my_esa);
6277       cp1 = strrchr(my_esa,'.');
6278       /* ODS-5 directory specifications can have extra "." in them. */
6279       /* Fix-me, can not scan EFS file specifications backwards */
6280       while (cp1 != NULL) {
6281         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6282           break;
6283         else {
6284            cp1--;
6285            while ((cp1 > my_esa) && (*cp1 != '.'))
6286              cp1--;
6287         }
6288         if (cp1 == my_esa)
6289           cp1 = NULL;
6290       }
6291
6292       if ((cp1) != NULL) {
6293         /* There's more than one directory in the path.  Just roll back. */
6294         *cp1 = term;
6295         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6296       }
6297       else {
6298         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6299           /* Go back and expand rooted logical name */
6300           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6301 #ifdef NAM$M_NO_SHORT_UPCASE
6302           if (decc_efs_case_preserve)
6303             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6304 #endif
6305           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6306             sts = rms_free_search_context(&dirfab);
6307             PerlMem_free(esa);
6308             if (esal != NULL)
6309                 PerlMem_free(esal);
6310             PerlMem_free(trndir);
6311             PerlMem_free(vmsdir);
6312             set_errno(EVMSERR);
6313             set_vaxc_errno(dirfab.fab$l_sts);
6314             return NULL;
6315           }
6316
6317           /* This changes the length of the string of course */
6318           if (esal != NULL) {
6319               my_esa_len = rms_nam_esll(dirnam);
6320           } else {
6321               my_esa_len = rms_nam_esl(dirnam);
6322           }
6323
6324           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6325           cp1 = strstr(my_esa,"][");
6326           if (!cp1) cp1 = strstr(my_esa,"]<");
6327           dirlen = cp1 - my_esa;
6328           memcpy(buf, my_esa, dirlen);
6329           if (!strncmp(cp1+2,"000000]",7)) {
6330             buf[dirlen-1] = '\0';
6331             /* fix-me Not full ODS-5, just extra dots in directories for now */
6332             cp1 = buf + dirlen - 1;
6333             while (cp1 > buf)
6334             {
6335               if (*cp1 == '[')
6336                 break;
6337               if (*cp1 == '.') {
6338                 if (*(cp1-1) != '^')
6339                   break;
6340               }
6341               cp1--;
6342             }
6343             if (*cp1 == '.') *cp1 = ']';
6344             else {
6345               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6346               memmove(cp1+1,"000000]",7);
6347             }
6348           }
6349           else {
6350             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6351             buf[retlen] = '\0';
6352             /* Convert last '.' to ']' */
6353             cp1 = buf+retlen-1;
6354             while (*cp != '[') {
6355               cp1--;
6356               if (*cp1 == '.') {
6357                 /* Do not trip on extra dots in ODS-5 directories */
6358                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6359                 break;
6360               }
6361             }
6362             if (*cp1 == '.') *cp1 = ']';
6363             else {
6364               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6365               memmove(cp1+1,"000000]",7);
6366             }
6367           }
6368         }
6369         else {  /* This is a top-level dir.  Add the MFD to the path. */
6370           cp1 = strrchr(my_esa, ':');
6371           assert(cp1);
6372           memmove(buf, my_esa, cp1 - my_esa + 1);
6373           memmove(buf + (cp1 - my_esa) + 1, "[000000]", 8);
6374           memmove(buf + (cp1 - my_esa) + 9, cp1 + 2, retlen - (cp1 - my_esa + 2));
6375           buf[retlen + 7] = '\0';  /* We've inserted '000000]' */
6376         }
6377       }
6378       sts = rms_free_search_context(&dirfab);
6379       /* We've set up the string up through the filename.  Add the
6380          type and version, and we're done. */
6381       strcat(buf,".DIR;1");
6382
6383       /* $PARSE may have upcased filespec, so convert output to lower
6384        * case if input contained any lowercase characters. */
6385       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6386       PerlMem_free(trndir);
6387       PerlMem_free(esa);
6388       if (esal != NULL)
6389         PerlMem_free(esal);
6390       PerlMem_free(vmsdir);
6391       return buf;
6392     }
6393 }  /* end of int_fileify_dirspec() */
6394
6395
6396 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6397 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6398 {
6399     static char __fileify_retbuf[VMS_MAXRSS];
6400     char * fileified, *ret_spec, *ret_buf;
6401
6402     fileified = NULL;
6403     ret_buf = buf;
6404     if (ret_buf == NULL) {
6405         if (ts) {
6406             Newx(fileified, VMS_MAXRSS, char);
6407             if (fileified == NULL)
6408                 _ckvmssts(SS$_INSFMEM);
6409             ret_buf = fileified;
6410         } else {
6411             ret_buf = __fileify_retbuf;
6412         }
6413     }
6414
6415     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6416
6417     if (ret_spec == NULL) {
6418        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6419        if (fileified)
6420            Safefree(fileified);
6421     }
6422
6423     return ret_spec;
6424 }  /* end of do_fileify_dirspec() */
6425 /*}}}*/
6426
6427 /* External entry points */
6428 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6429 { return do_fileify_dirspec(dir,buf,0,NULL); }
6430 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6431 { return do_fileify_dirspec(dir,buf,1,NULL); }
6432 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6433 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6434 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6435 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6436
6437 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6438     char * v_spec, int v_len, char * r_spec, int r_len,
6439     char * d_spec, int d_len, char * n_spec, int n_len,
6440     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6441
6442     /* VMS specification - Try to do this the simple way */
6443     if ((v_len + r_len > 0) || (d_len > 0)) {
6444         int is_dir;
6445
6446         /* No name or extension component, already a directory */
6447         if ((n_len + e_len + vs_len) == 0) {
6448             strcpy(buf, dir);
6449             return buf;
6450         }
6451
6452         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6453         /* This results from catfile() being used instead of catdir() */
6454         /* So even though it should not work, we need to allow it */
6455
6456         /* If this is .DIR;1 then do a simple conversion */
6457         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6458         if (is_dir || (e_len == 0) && (d_len > 0)) {
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              buf[len] = dclose;
6468              buf[len + 1] = '\0';
6469              return buf;
6470         }
6471
6472 #ifdef HAS_SYMLINK
6473         else if (d_len > 0) {
6474             /* In the olden days, a directory needed to have a .DIR */
6475             /* extension to be a valid directory, but now it could  */
6476             /* be a symbolic link */
6477             int len;
6478             len = v_len + r_len + d_len - 1;
6479             char dclose = d_spec[d_len - 1];
6480             memcpy(buf, dir, len);
6481             buf[len] = '.';
6482             len++;
6483             memcpy(&buf[len], n_spec, n_len);
6484             len += n_len;
6485             if (e_len > 0) {
6486                 if (decc_efs_charset) {
6487                     if (e_len == 4
6488                         && (toupper(e_spec[1]) == 'D')
6489                         && (toupper(e_spec[2]) == 'I')
6490                         && (toupper(e_spec[3]) == 'R')) {
6491
6492                         /* Corner case: directory spec with invalid version.
6493                          * Valid would have followed is_dir path above.
6494                          */
6495                         SETERRNO(ENOTDIR, RMS$_DIR);
6496                         return NULL;
6497                     }
6498                     else {
6499                         buf[len] = '^';
6500                         len++;
6501                         memcpy(&buf[len], e_spec, e_len);
6502                         len += e_len;
6503                     }
6504                 }
6505                 else {
6506                     SETERRNO(ENOTDIR, RMS$_DIR);
6507                     return NULL;
6508                 }
6509             }
6510             buf[len] = dclose;
6511             buf[len + 1] = '\0';
6512             return buf;
6513         }
6514 #else
6515         else {
6516             set_vaxc_errno(RMS$_DIR);
6517             set_errno(ENOTDIR);
6518             return NULL;
6519         }
6520 #endif
6521     }
6522     set_vaxc_errno(RMS$_DIR);
6523     set_errno(ENOTDIR);
6524     return NULL;
6525 }
6526
6527
6528 /* Internal routine to make sure or convert a directory to be in a */
6529 /* path specification.  No utf8 flag because it is not changed or used */
6530 static char *int_pathify_dirspec(const char *dir, char *buf)
6531 {
6532     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6533     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6534     char * exp_spec, *ret_spec;
6535     char * trndir;
6536     unsigned short int trnlnm_iter_count;
6537     STRLEN trnlen;
6538     int need_to_lower;
6539
6540     if (vms_debug_fileify) {
6541         if (dir == NULL)
6542             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6543         else
6544             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6545     }
6546
6547     /* We may need to lower case the result if we translated  */
6548     /* a logical name or got the current working directory */
6549     need_to_lower = 0;
6550
6551     if (!dir || !*dir) {
6552       set_errno(EINVAL);
6553       set_vaxc_errno(SS$_BADPARAM);
6554       return NULL;
6555     }
6556
6557     trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
6558     if (trndir == NULL)
6559         _ckvmssts_noperl(SS$_INSFMEM);
6560
6561     /* If no directory specified use the current default */
6562     if (*dir)
6563         my_strlcpy(trndir, dir, VMS_MAXRSS);
6564     else {
6565         getcwd(trndir, VMS_MAXRSS - 1);
6566         need_to_lower = 1;
6567     }
6568
6569     /* now deal with bare names that could be logical names */
6570     trnlnm_iter_count = 0;
6571     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6572            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6573         trnlnm_iter_count++;
6574         need_to_lower = 1;
6575         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6576             break;
6577         trnlen = strlen(trndir);
6578
6579         /* Trap simple rooted lnms, and return lnm:[000000] */
6580         if (!strcmp(trndir+trnlen-2,".]")) {
6581             my_strlcpy(buf, dir, VMS_MAXRSS);
6582             strcat(buf, ":[000000]");
6583             PerlMem_free(trndir);
6584
6585             if (vms_debug_fileify) {
6586                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6587             }
6588             return buf;
6589         }
6590     }
6591
6592     /* At this point we do not work with *dir, but the copy in  *trndir */
6593
6594     if (need_to_lower && !decc_efs_case_preserve) {
6595         /* Legacy mode, lower case the returned value */
6596         __mystrtolower(trndir);
6597     }
6598
6599
6600     /* Some special cases, '..', '.' */
6601     sts = 0;
6602     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6603        /* Force UNIX filespec */
6604        sts = 1;
6605
6606     } else {
6607         /* Is this Unix or VMS format? */
6608         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6609                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6610                              &e_len, &vs_spec, &vs_len);
6611         if (sts == 0) {
6612
6613             /* Just a filename? */
6614             if ((v_len + r_len + d_len) == 0) {
6615
6616                 /* Now we have a problem, this could be Unix or VMS */
6617                 /* We have to guess.  .DIR usually means VMS */
6618
6619                 /* In UNIX report mode, the .DIR extension is removed */
6620                 /* if one shows up, it is for a non-directory or a directory */
6621                 /* in EFS charset mode */
6622
6623                 /* So if we are in Unix report mode, assume that this */
6624                 /* is a relative Unix directory specification */
6625
6626                 sts = 1;
6627                 if (!decc_filename_unix_report && decc_efs_charset) {
6628                     int is_dir;
6629                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6630
6631                     if (is_dir) {
6632                         /* Traditional mode, assume .DIR is directory */
6633                         buf[0] = '[';
6634                         buf[1] = '.';
6635                         memcpy(&buf[2], n_spec, n_len);
6636                         buf[n_len + 2] = ']';
6637                         buf[n_len + 3] = '\0';
6638                         PerlMem_free(trndir);
6639                         if (vms_debug_fileify) {
6640                             fprintf(stderr,
6641                                     "int_pathify_dirspec: buf = %s\n",
6642                                     buf);
6643                         }
6644                         return buf;
6645                     }
6646                 }
6647             }
6648         }
6649     }
6650     if (sts == 0) {
6651         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6652             v_spec, v_len, r_spec, r_len,
6653             d_spec, d_len, n_spec, n_len,
6654             e_spec, e_len, vs_spec, vs_len);
6655
6656         if (ret_spec != NULL) {
6657             PerlMem_free(trndir);
6658             if (vms_debug_fileify) {
6659                 fprintf(stderr,
6660                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6661             }
6662             return ret_spec;
6663         }
6664
6665         /* Simple way did not work, which means that a logical name */
6666         /* was present for the directory specification.             */
6667         /* Need to use an rmsexpand variant to decode it completely */
6668         exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
6669         if (exp_spec == NULL)
6670             _ckvmssts_noperl(SS$_INSFMEM);
6671
6672         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6673         if (ret_spec != NULL) {
6674             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6675                                  &r_spec, &r_len, &d_spec, &d_len,
6676                                  &n_spec, &n_len, &e_spec,
6677                                  &e_len, &vs_spec, &vs_len);
6678             if (sts == 0) {
6679                 ret_spec = int_pathify_dirspec_simple(
6680                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6681                     d_spec, d_len, n_spec, n_len,
6682                     e_spec, e_len, vs_spec, vs_len);
6683
6684                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6685                     /* Legacy mode, lower case the returned value */
6686                     __mystrtolower(ret_spec);
6687                 }
6688             } else {
6689                 set_vaxc_errno(RMS$_DIR);
6690                 set_errno(ENOTDIR);
6691                 ret_spec = NULL;
6692             }
6693         }
6694         PerlMem_free(exp_spec);
6695         PerlMem_free(trndir);
6696         if (vms_debug_fileify) {
6697             if (ret_spec == NULL)
6698                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6699             else
6700                 fprintf(stderr,
6701                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6702         }
6703         return ret_spec;
6704
6705     } else {
6706         /* Unix specification, Could be trivial conversion, */
6707         /* but have to deal with trailing '.dir' or extra '.' */
6708
6709         char * lastdot;
6710         char * lastslash;
6711         int is_dir;
6712         STRLEN dir_len = strlen(trndir);
6713
6714         lastslash = strrchr(trndir, '/');
6715         if (lastslash == NULL)
6716             lastslash = trndir;
6717         else
6718             lastslash++;
6719
6720         lastdot = NULL;
6721
6722         /* '..' or '.' are valid directory components */
6723         is_dir = 0;
6724         if (lastslash[0] == '.') {
6725             if (lastslash[1] == '\0') {
6726                is_dir = 1;
6727             } else if (lastslash[1] == '.') {
6728                 if (lastslash[2] == '\0') {
6729                     is_dir = 1;
6730                 } else {
6731                     /* And finally allow '...' */
6732                     if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6733                         is_dir = 1;
6734                     }
6735                 }
6736             }
6737         }
6738
6739         if (!is_dir) {
6740            lastdot = strrchr(lastslash, '.');
6741         }
6742         if (lastdot != NULL) {
6743             STRLEN e_len;
6744              /* '.dir' is discarded, and any other '.' is invalid */
6745             e_len = strlen(lastdot);
6746
6747             is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6748
6749             if (is_dir) {
6750                 dir_len = dir_len - 4;
6751             }
6752         }
6753
6754         my_strlcpy(buf, trndir, VMS_MAXRSS);
6755         if (buf[dir_len - 1] != '/') {
6756             buf[dir_len] = '/';
6757             buf[dir_len + 1] = '\0';
6758         }
6759
6760         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6761         if (!decc_efs_charset) {
6762              int dir_start = 0;
6763              char * str = buf;
6764              if (str[0] == '.') {
6765                  char * dots = str;
6766                  int cnt = 1;
6767                  while ((dots[cnt] == '.') && (cnt < 3))
6768                      cnt++;
6769                  if (cnt <= 3) {
6770                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6771                          dir_start = 1;
6772                          str += cnt;
6773                      }
6774                  }
6775              }
6776              for (; *str; ++str) {
6777                  while (*str == '/') {
6778                      dir_start = 1;
6779                      *str++;
6780                  }
6781                  if (dir_start) {
6782
6783                      /* Have to skip up to three dots which could be */
6784                      /* directories, 3 dots being a VMS extension for Perl */
6785                      char * dots = str;
6786                      int cnt = 0;
6787                      while ((dots[cnt] == '.') && (cnt < 3)) {
6788                          cnt++;
6789                      }
6790                      if (dots[cnt] == '\0')
6791                          break;
6792                      if ((cnt > 1) && (dots[cnt] != '/')) {
6793                          dir_start = 0;
6794                      } else {
6795                          str += cnt;
6796                      }
6797
6798                      /* too many dots? */
6799                      if ((cnt == 0) || (cnt > 3)) {
6800                          dir_start = 0;
6801                      }
6802                  }
6803                  if (!dir_start && (*str == '.')) {
6804                      *str = '_';
6805                  }
6806              }
6807         }
6808         PerlMem_free(trndir);
6809         ret_spec = buf;
6810         if (vms_debug_fileify) {
6811             if (ret_spec == NULL)
6812                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6813             else
6814                 fprintf(stderr,
6815                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6816         }
6817         return ret_spec;
6818     }
6819 }
6820
6821 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6822 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6823 {
6824     static char __pathify_retbuf[VMS_MAXRSS];
6825     char * pathified, *ret_spec, *ret_buf;
6826
6827     pathified = NULL;
6828     ret_buf = buf;
6829     if (ret_buf == NULL) {
6830         if (ts) {
6831             Newx(pathified, VMS_MAXRSS, char);
6832             if (pathified == NULL)
6833                 _ckvmssts(SS$_INSFMEM);
6834             ret_buf = pathified;
6835         } else {
6836             ret_buf = __pathify_retbuf;
6837         }
6838     }
6839
6840     ret_spec = int_pathify_dirspec(dir, ret_buf);
6841
6842     if (ret_spec == NULL) {
6843        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6844        if (pathified)
6845            Safefree(pathified);
6846     }
6847
6848     return ret_spec;
6849
6850 }  /* end of do_pathify_dirspec() */
6851
6852
6853 /* External entry points */
6854 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6855 { return do_pathify_dirspec(dir,buf,0,NULL); }
6856 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6857 { return do_pathify_dirspec(dir,buf,1,NULL); }
6858 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6859 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6860 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6861 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6862
6863 /* Internal tounixspec routine that does not use a thread context */
6864 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6865 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6866 {
6867   char *dirend, *cp1, *cp3, *tmp;
6868   const char *cp2;
6869   int dirlen;
6870   unsigned short int trnlnm_iter_count;
6871   int cmp_rslt, outchars_added;
6872   if (utf8_fl != NULL)
6873     *utf8_fl = 0;
6874
6875   if (vms_debug_fileify) {
6876       if (spec == NULL)
6877           fprintf(stderr, "int_tounixspec: spec = NULL\n");
6878       else
6879           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6880   }
6881
6882
6883   if (spec == NULL) {
6884       set_errno(EINVAL);
6885       set_vaxc_errno(SS$_BADPARAM);
6886       return NULL;
6887   }
6888   if (strlen(spec) > (VMS_MAXRSS-1)) {
6889       set_errno(E2BIG);
6890       set_vaxc_errno(SS$_BUFFEROVF);
6891       return NULL;
6892   }
6893
6894   /* New VMS specific format needs translation
6895    * glob passes filenames with trailing '\n' and expects this preserved.
6896    */
6897   if (decc_posix_compliant_pathnames) {
6898     if (strncmp(spec, "\"^UP^", 5) == 0) {
6899       char * uspec;
6900       char *tunix;
6901       int tunix_len;
6902       int nl_flag;
6903
6904       tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
6905       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6906       tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
6907       nl_flag = 0;
6908       if (tunix[tunix_len - 1] == '\n') {
6909         tunix[tunix_len - 1] = '\"';
6910         tunix[tunix_len] = '\0';
6911         tunix_len--;
6912         nl_flag = 1;
6913       }
6914       uspec = decc$translate_vms(tunix);
6915       PerlMem_free(tunix);
6916       if ((int)uspec > 0) {
6917         my_strlcpy(rslt, uspec, VMS_MAXRSS);
6918         if (nl_flag) {
6919           strcat(rslt,"\n");
6920         }
6921         else {
6922           /* If we can not translate it, makemaker wants as-is */
6923           my_strlcpy(rslt, spec, VMS_MAXRSS);
6924         }
6925         return rslt;
6926       }
6927     }
6928   }
6929
6930   cmp_rslt = 0; /* Presume VMS */
6931   cp1 = strchr(spec, '/');
6932   if (cp1 == NULL)
6933     cmp_rslt = 0;
6934
6935     /* Look for EFS ^/ */
6936     if (decc_efs_charset) {
6937       while (cp1 != NULL) {
6938         cp2 = cp1 - 1;
6939         if (*cp2 != '^') {
6940           /* Found illegal VMS, assume UNIX */
6941           cmp_rslt = 1;
6942           break;
6943         }
6944       cp1++;
6945       cp1 = strchr(cp1, '/');
6946     }
6947   }
6948
6949   /* Look for "." and ".." */
6950   if (decc_filename_unix_report) {
6951     if (spec[0] == '.') {
6952       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6953         cmp_rslt = 1;
6954       }
6955       else {
6956         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6957           cmp_rslt = 1;
6958         }
6959       }
6960     }
6961   }
6962
6963   cp1 = rslt;
6964   cp2 = spec;
6965
6966   /* This is already UNIX or at least nothing VMS understands,
6967    * so all we can reasonably do is unescape extended chars.
6968    */
6969   if (cmp_rslt) {
6970     while (*cp2) {
6971         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
6972         cp1 += outchars_added;
6973     }
6974     *cp1 = '\0';
6975     if (vms_debug_fileify) {
6976         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6977     }
6978     return rslt;
6979   }
6980
6981   dirend = strrchr(spec,']');
6982   if (dirend == NULL) dirend = strrchr(spec,'>');
6983   if (dirend == NULL) dirend = strchr(spec,':');
6984   if (dirend == NULL) {
6985     while (*cp2) {
6986         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
6987         cp1 += outchars_added;
6988     }
6989     *cp1 = '\0';
6990     if (vms_debug_fileify) {
6991         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6992     }
6993     return rslt;
6994   }
6995
6996   /* Special case 1 - sys$posix_root = / */
6997   if (!decc_disable_posix_root) {
6998     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6999       *cp1 = '/';
7000       cp1++;
7001       cp2 = cp2 + 15;
7002       }
7003   }
7004
7005   /* Special case 2 - Convert NLA0: to /dev/null */
7006   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7007   if (cmp_rslt == 0) {
7008     strcpy(rslt, "/dev/null");
7009     cp1 = cp1 + 9;
7010     cp2 = cp2 + 5;
7011     if (spec[6] != '\0') {
7012       cp1[9] = '/';
7013       cp1++;
7014       cp2++;
7015     }
7016   }
7017
7018    /* Also handle special case "SYS$SCRATCH:" */
7019   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7020   tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
7021   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7022   if (cmp_rslt == 0) {
7023   int islnm;
7024
7025     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7026     if (!islnm) {
7027       strcpy(rslt, "/tmp");
7028       cp1 = cp1 + 4;
7029       cp2 = cp2 + 12;
7030       if (spec[12] != '\0') {
7031         cp1[4] = '/';
7032         cp1++;
7033         cp2++;
7034       }
7035     }
7036   }
7037
7038   if (*cp2 != '[' && *cp2 != '<') {
7039     *(cp1++) = '/';
7040   }
7041   else {  /* the VMS spec begins with directories */
7042     cp2++;
7043     if (*cp2 == ']' || *cp2 == '>') {
7044       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7045       PerlMem_free(tmp);
7046       return rslt;
7047     }
7048     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7049       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7050         PerlMem_free(tmp);
7051         if (vms_debug_fileify) {
7052             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7053         }
7054         return NULL;
7055       }
7056       trnlnm_iter_count = 0;
7057       do {
7058         cp3 = tmp;
7059         while (*cp3 != ':' && *cp3) cp3++;
7060         *(cp3++) = '\0';
7061         if (strchr(cp3,']') != NULL) break;
7062         trnlnm_iter_count++;
7063         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7064       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7065       cp1 = rslt;
7066       cp3 = tmp;
7067       *(cp1++) = '/';
7068       while (*cp3) {
7069         *(cp1++) = *(cp3++);
7070         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7071             PerlMem_free(tmp);
7072             set_errno(ENAMETOOLONG);
7073             set_vaxc_errno(SS$_BUFFEROVF);
7074             if (vms_debug_fileify) {
7075                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7076             }
7077             return NULL; /* No room */
7078         }
7079       }
7080       *(cp1++) = '/';
7081     }
7082     if ((*cp2 == '^')) {
7083         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7084         cp1 += outchars_added;
7085     }
7086     else if ( *cp2 == '.') {
7087       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7088         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7089         cp2 += 3;
7090       }
7091       else cp2++;
7092     }
7093   }
7094   PerlMem_free(tmp);
7095   for (; cp2 <= dirend; cp2++) {
7096     if ((*cp2 == '^')) {
7097         /* EFS file escape, pass the next character as is */
7098         /* Fix me: HEX encoding for Unicode not implemented */
7099         *(cp1++) = *(++cp2);
7100         /* An escaped dot stays as is -- don't convert to slash */
7101         if (*cp2 == '.') cp2++;
7102     }
7103     if (*cp2 == ':') {
7104       *(cp1++) = '/';
7105       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7106     }
7107     else if (*cp2 == ']' || *cp2 == '>') {
7108       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7109     }
7110     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7111       *(cp1++) = '/';
7112       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7113         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7114                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7115         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7116             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7117       }
7118       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7119         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7120         cp2 += 2;
7121       }
7122     }
7123     else if (*cp2 == '-') {
7124       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7125         while (*cp2 == '-') {
7126           cp2++;
7127           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7128         }
7129         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7130                                                          /* filespecs like */
7131           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7132           if (vms_debug_fileify) {
7133               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7134           }
7135           return NULL;
7136         }
7137       }
7138       else *(cp1++) = *cp2;
7139     }
7140     else *(cp1++) = *cp2;
7141   }
7142   /* Translate the rest of the filename. */
7143   while (*cp2) {
7144       int dot_seen = 0;
7145       switch(*cp2) {
7146       /* Fixme - for compatibility with the CRTL we should be removing */
7147       /* spaces from the file specifications, but this may show that */
7148       /* some tests that were appearing to pass are not really passing */
7149       case '%':
7150           cp2++;
7151           *(cp1++) = '?';
7152           break;
7153       case '^':
7154           cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7155           cp1 += outchars_added;
7156           break;
7157       case ';':
7158           if (decc_filename_unix_no_version) {
7159               /* Easy, drop the version */
7160               while (*cp2)
7161                   cp2++;
7162               break;
7163           } else {
7164               /* Punt - passing the version as a dot will probably */
7165               /* break perl in weird ways, but so did passing */
7166               /* through the ; as a version.  Follow the CRTL and */
7167               /* hope for the best. */
7168               cp2++;
7169               *(cp1++) = '.';
7170           }
7171           break;
7172       case '.':
7173           if (dot_seen) {
7174               /* We will need to fix this properly later */
7175               /* As Perl may be installed on an ODS-5 volume, but not */
7176               /* have the EFS_CHARSET enabled, it still may encounter */
7177               /* filenames with extra dots in them, and a precedent got */
7178               /* set which allowed them to work, that we will uphold here */
7179               /* If extra dots are present in a name and no ^ is on them */
7180               /* VMS assumes that the first one is the extension delimiter */
7181               /* the rest have an implied ^. */
7182
7183               /* this is also a conflict as the . is also a version */
7184               /* delimiter in VMS, */
7185
7186               *(cp1++) = *(cp2++);
7187               break;
7188           }
7189           dot_seen = 1;
7190           /* This is an extension */
7191           if (decc_readdir_dropdotnotype) {
7192               cp2++;
7193               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7194                   /* Drop the dot for the extension */
7195                   break;
7196               } else {
7197                   *(cp1++) = '.';
7198               }
7199               break;
7200           }
7201       default:
7202           *(cp1++) = *(cp2++);
7203       }
7204   }
7205   *cp1 = '\0';
7206
7207   /* This still leaves /000000/ when working with a
7208    * VMS device root or concealed root.
7209    */
7210   {
7211   int ulen;
7212   char * zeros;
7213
7214       ulen = strlen(rslt);
7215
7216       /* Get rid of "000000/ in rooted filespecs */
7217       if (ulen > 7) {
7218         zeros = strstr(rslt, "/000000/");
7219         if (zeros != NULL) {
7220           int mlen;
7221           mlen = ulen - (zeros - rslt) - 7;
7222           memmove(zeros, &zeros[7], mlen);
7223           ulen = ulen - 7;
7224           rslt[ulen] = '\0';
7225         }
7226       }
7227   }
7228
7229   if (vms_debug_fileify) {
7230       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7231   }
7232   return rslt;
7233
7234 }  /* end of int_tounixspec() */
7235
7236
7237 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7238 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7239 {
7240     static char __tounixspec_retbuf[VMS_MAXRSS];
7241     char * unixspec, *ret_spec, *ret_buf;
7242
7243     unixspec = NULL;
7244     ret_buf = buf;
7245     if (ret_buf == NULL) {
7246         if (ts) {
7247             Newx(unixspec, VMS_MAXRSS, char);
7248             if (unixspec == NULL)
7249                 _ckvmssts(SS$_INSFMEM);
7250             ret_buf = unixspec;
7251         } else {
7252             ret_buf = __tounixspec_retbuf;
7253         }
7254     }
7255
7256     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7257
7258     if (ret_spec == NULL) {
7259        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7260        if (unixspec)
7261            Safefree(unixspec);
7262     }
7263
7264     return ret_spec;
7265
7266 }  /* end of do_tounixspec() */
7267 /*}}}*/
7268 /* External entry points */
7269 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7270   { return do_tounixspec(spec,buf,0, NULL); }
7271 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7272   { return do_tounixspec(spec,buf,1, NULL); }
7273 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7274   { return do_tounixspec(spec,buf,0, utf8_fl); }
7275 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7276   { return do_tounixspec(spec,buf,1, utf8_fl); }
7277
7278 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7279
7280 /*
7281  This procedure is used to identify if a path is based in either
7282  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7283  it returns the OpenVMS format directory for it.
7284
7285  It is expecting specifications of only '/' or '/xxxx/'
7286
7287  If a posix root does not exist, or 'xxxx' is not a directory
7288  in the posix root, it returns a failure.
7289
7290  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7291
7292  It is used only internally by posix_to_vmsspec_hardway().
7293  */
7294
7295 static int posix_root_to_vms
7296   (char *vmspath, int vmspath_len,
7297    const char *unixpath,
7298    const int * utf8_fl)
7299 {
7300 int sts;
7301 struct FAB myfab = cc$rms_fab;
7302 rms_setup_nam(mynam);
7303 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7304 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7305 char * esa, * esal, * rsa, * rsal;
7306 int dir_flag;
7307 int unixlen;
7308
7309     dir_flag = 0;
7310     vmspath[0] = '\0';
7311     unixlen = strlen(unixpath);
7312     if (unixlen == 0) {
7313       return RMS$_FNF;
7314     }
7315
7316 #if __CRTL_VER >= 80200000
7317   /* If not a posix spec already, convert it */
7318   if (decc_posix_compliant_pathnames) {
7319     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7320       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7321     }
7322     else {
7323       /* This is already a VMS specification, no conversion */
7324       unixlen--;
7325       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7326     }
7327   }
7328   else
7329 #endif
7330   {
7331   int path_len;
7332   int i,j;
7333
7334      /* Check to see if this is under the POSIX root */
7335      if (decc_disable_posix_root) {
7336         return RMS$_FNF;
7337      }
7338
7339      /* Skip leading / */
7340      if (unixpath[0] == '/') {
7341         unixpath++;
7342         unixlen--;
7343      }
7344
7345
7346      strcpy(vmspath,"SYS$POSIX_ROOT:");
7347
7348      /* If this is only the / , or blank, then... */
7349      if (unixpath[0] == '\0') {
7350         /* by definition, this is the answer */
7351         return SS$_NORMAL;
7352      }
7353
7354      /* Need to look up a directory */
7355      vmspath[15] = '[';
7356      vmspath[16] = '\0';
7357
7358      /* Copy and add '^' escape characters as needed */
7359      j = 16;
7360      i = 0;
7361      while (unixpath[i] != 0) {
7362      int k;
7363
7364         j += copy_expand_unix_filename_escape
7365             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7366         i += k;
7367      }
7368
7369      path_len = strlen(vmspath);
7370      if (vmspath[path_len - 1] == '/')
7371         path_len--;
7372      vmspath[path_len] = ']';
7373      path_len++;
7374      vmspath[path_len] = '\0';
7375
7376   }
7377   vmspath[vmspath_len] = 0;
7378   if (unixpath[unixlen - 1] == '/')
7379   dir_flag = 1;
7380   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7381   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7382   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7383   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7384   rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7385   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7386   rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7387   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7388   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7389   rms_bind_fab_nam(myfab, mynam);
7390   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7391   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7392   if (decc_efs_case_preserve)
7393     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7394 #ifdef NAML$M_OPEN_SPECIAL
7395   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7396 #endif
7397
7398   /* Set up the remaining naml fields */
7399   sts = sys$parse(&myfab);
7400
7401   /* It failed! Try again as a UNIX filespec */
7402   if (!(sts & 1)) {
7403     PerlMem_free(esal);
7404     PerlMem_free(esa);
7405     PerlMem_free(rsal);
7406     PerlMem_free(rsa);
7407     return sts;
7408   }
7409
7410    /* get the Device ID and the FID */
7411    sts = sys$search(&myfab);
7412
7413    /* These are no longer needed */
7414    PerlMem_free(esa);
7415    PerlMem_free(rsal);
7416    PerlMem_free(rsa);
7417
7418    /* on any failure, returned the POSIX ^UP^ filespec */
7419    if (!(sts & 1)) {
7420       PerlMem_free(esal);
7421       return sts;
7422    }
7423    specdsc.dsc$a_pointer = vmspath;
7424    specdsc.dsc$w_length = vmspath_len;
7425
7426    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7427    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7428    sts = lib$fid_to_name
7429       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7430
7431   /* on any failure, returned the POSIX ^UP^ filespec */
7432   if (!(sts & 1)) {
7433      /* This can happen if user does not have permission to read directories */
7434      if (strncmp(unixpath,"\"^UP^",5) != 0)
7435        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7436      else
7437        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7438   }
7439   else {
7440     vmspath[specdsc.dsc$w_length] = 0;
7441
7442     /* Are we expecting a directory? */
7443     if (dir_flag != 0) {
7444     int i;
7445     char *eptr;
7446
7447       eptr = NULL;
7448
7449       i = specdsc.dsc$w_length - 1;
7450       while (i > 0) {
7451       int zercnt;
7452         zercnt = 0;
7453         /* Version must be '1' */
7454         if (vmspath[i--] != '1')
7455           break;
7456         /* Version delimiter is one of ".;" */
7457         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7458           break;
7459         i--;
7460         if (vmspath[i--] != 'R')
7461           break;
7462         if (vmspath[i--] != 'I')
7463           break;
7464         if (vmspath[i--] != 'D')
7465           break;
7466         if (vmspath[i--] != '.')
7467           break;
7468         eptr = &vmspath[i+1];
7469         while (i > 0) {
7470           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7471             if (vmspath[i-1] != '^') {
7472               if (zercnt != 6) {
7473                 *eptr = vmspath[i];
7474                 eptr[1] = '\0';
7475                 vmspath[i] = '.';
7476                 break;
7477               }
7478               else {
7479                 /* Get rid of 6 imaginary zero directory filename */
7480                 vmspath[i+1] = '\0';
7481               }
7482             }
7483           }
7484           if (vmspath[i] == '0')
7485             zercnt++;
7486           else
7487             zercnt = 10;
7488           i--;
7489         }
7490         break;
7491       }
7492     }
7493   }
7494   PerlMem_free(esal);
7495   return sts;
7496 }
7497
7498 /* /dev/mumble needs to be handled special.
7499    /dev/null becomes NLA0:, And there is the potential for other stuff
7500    like /dev/tty which may need to be mapped to something.
7501 */
7502
7503 static int
7504 slash_dev_special_to_vms
7505    (const char * unixptr,
7506     char * vmspath,
7507     int vmspath_len)
7508 {
7509 char * nextslash;
7510 int len;
7511 int cmp;
7512
7513     unixptr += 4;
7514     nextslash = strchr(unixptr, '/');
7515     len = strlen(unixptr);
7516     if (nextslash != NULL)
7517         len = nextslash - unixptr;
7518     cmp = strncmp("null", unixptr, 5);
7519     if (cmp == 0) {
7520         if (vmspath_len >= 6) {
7521             strcpy(vmspath, "_NLA0:");
7522             return SS$_NORMAL;
7523         }
7524     }
7525     return 0;
7526 }
7527
7528
7529 /* The built in routines do not understand perl's special needs, so
7530     doing a manual conversion from UNIX to VMS
7531
7532     If the utf8_fl is not null and points to a non-zero value, then
7533     treat 8 bit characters as UTF-8.
7534
7535     The sequence starting with '$(' and ending with ')' will be passed
7536     through with out interpretation instead of being escaped.
7537
7538   */
7539 static int posix_to_vmsspec_hardway
7540   (char *vmspath, int vmspath_len,
7541    const char *unixpath,
7542    int dir_flag,
7543    int * utf8_fl) {
7544
7545 char *esa;
7546 const char *unixptr;
7547 const char *unixend;
7548 char *vmsptr;
7549 const char *lastslash;
7550 const char *lastdot;
7551 int unixlen;
7552 int vmslen;
7553 int dir_start;
7554 int dir_dot;
7555 int quoted;
7556 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7557 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7558
7559   if (utf8_fl != NULL)
7560     *utf8_fl = 0;
7561
7562   unixptr = unixpath;
7563   dir_dot = 0;
7564
7565   /* Ignore leading "/" characters */
7566   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7567     unixptr++;
7568   }
7569   unixlen = strlen(unixptr);
7570
7571   /* Do nothing with blank paths */
7572   if (unixlen == 0) {
7573     vmspath[0] = '\0';
7574     return SS$_NORMAL;
7575   }
7576
7577   quoted = 0;
7578   /* This could have a "^UP^ on the front */
7579   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7580     quoted = 1;
7581     unixptr+= 5;
7582     unixlen-= 5;
7583   }
7584
7585   lastslash = strrchr(unixptr,'/');
7586   lastdot = strrchr(unixptr,'.');
7587   unixend = strrchr(unixptr,'\"');
7588   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7589     unixend = unixptr + unixlen;
7590   }
7591
7592   /* last dot is last dot or past end of string */
7593   if (lastdot == NULL)
7594     lastdot = unixptr + unixlen;
7595
7596   /* if no directories, set last slash to beginning of string */
7597   if (lastslash == NULL) {
7598     lastslash = unixptr;
7599   }
7600   else {
7601     /* Watch out for trailing "." after last slash, still a directory */
7602     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7603       lastslash = unixptr + unixlen;
7604     }
7605
7606     /* Watch out for trailing ".." after last slash, still a directory */
7607     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7608       lastslash = unixptr + unixlen;
7609     }
7610
7611     /* dots in directories are aways escaped */
7612     if (lastdot < lastslash)
7613       lastdot = unixptr + unixlen;
7614   }
7615
7616   /* if (unixptr < lastslash) then we are in a directory */
7617
7618   dir_start = 0;
7619
7620   vmsptr = vmspath;
7621   vmslen = 0;
7622
7623   /* Start with the UNIX path */
7624   if (*unixptr != '/') {
7625     /* relative paths */
7626
7627     /* If allowing logical names on relative pathnames, then handle here */
7628     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7629         !decc_posix_compliant_pathnames) {
7630     char * nextslash;
7631     int seg_len;
7632     char * trn;
7633     int islnm;
7634
7635         /* Find the next slash */
7636         nextslash = strchr(unixptr,'/');
7637
7638         esa = (char *)PerlMem_malloc(vmspath_len);
7639         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7640
7641         trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7642         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7643
7644         if (nextslash != NULL) {
7645
7646             seg_len = nextslash - unixptr;
7647             memcpy(esa, unixptr, seg_len);
7648             esa[seg_len] = 0;
7649         }
7650         else {
7651             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7652         }
7653         /* trnlnm(section) */
7654         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7655
7656         if (islnm) {
7657             /* Now fix up the directory */
7658
7659             /* Split up the path to find the components */
7660             sts = vms_split_path
7661                   (trn,
7662                    &v_spec,
7663                    &v_len,
7664                    &r_spec,
7665                    &r_len,
7666                    &d_spec,
7667                    &d_len,
7668                    &n_spec,
7669                    &n_len,
7670                    &e_spec,
7671                    &e_len,
7672                    &vs_spec,
7673                    &vs_len);
7674
7675             while (sts == 0) {
7676             int cmp;
7677
7678                 /* A logical name must be a directory  or the full
7679                    specification.  It is only a full specification if
7680                    it is the only component */
7681                 if ((unixptr[seg_len] == '\0') ||
7682                     (unixptr[seg_len+1] == '\0')) {
7683
7684                     /* Is a directory being required? */
7685                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7686                         /* Not a logical name */
7687                         break;
7688                     }
7689
7690
7691                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7692                         /* This must be a directory */
7693                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7694                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7695                             vmsptr[vmslen] = ':';
7696                             vmslen++;
7697                             vmsptr[vmslen] = '\0';
7698                             return SS$_NORMAL;
7699                         }
7700                     }
7701
7702                 }
7703
7704
7705                 /* must be dev/directory - ignore version */
7706                 if ((n_len + e_len) != 0)
7707                     break;
7708
7709                 /* transfer the volume */
7710                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7711                     memcpy(vmsptr, v_spec, v_len);
7712                     vmsptr += v_len;
7713                     vmsptr[0] = '\0';
7714                     vmslen += v_len;
7715                 }
7716
7717                 /* unroot the rooted directory */
7718                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7719                     r_spec[0] = '[';
7720                     r_spec[r_len - 1] = ']';
7721
7722                     /* This should not be there, but nothing is perfect */
7723                     if (r_len > 9) {
7724                         cmp = strcmp(&r_spec[1], "000000.");
7725                         if (cmp == 0) {
7726                             r_spec += 7;
7727                             r_spec[7] = '[';
7728                             r_len -= 7;
7729                             if (r_len == 2)
7730                                 r_len = 0;
7731                         }
7732                     }
7733                     if (r_len > 0) {
7734                         memcpy(vmsptr, r_spec, r_len);
7735                         vmsptr += r_len;
7736                         vmslen += r_len;
7737                         vmsptr[0] = '\0';
7738                     }
7739                 }
7740                 /* Bring over the directory. */
7741                 if ((d_len > 0) &&
7742                     ((d_len + vmslen) < vmspath_len)) {
7743                     d_spec[0] = '[';
7744                     d_spec[d_len - 1] = ']';
7745                     if (d_len > 9) {
7746                         cmp = strcmp(&d_spec[1], "000000.");
7747                         if (cmp == 0) {
7748                             d_spec += 7;
7749                             d_spec[7] = '[';
7750                             d_len -= 7;
7751                             if (d_len == 2)
7752                                 d_len = 0;
7753                         }
7754                     }
7755
7756                     if (r_len > 0) {
7757                         /* Remove the redundant root */
7758                         if (r_len > 0) {
7759                             /* remove the ][ */
7760                             vmsptr--;
7761                             vmslen--;
7762                             d_spec++;
7763                             d_len--;
7764                         }
7765                         memcpy(vmsptr, d_spec, d_len);
7766                             vmsptr += d_len;
7767                             vmslen += d_len;
7768                             vmsptr[0] = '\0';
7769                     }
7770                 }
7771                 break;
7772             }
7773         }
7774
7775         PerlMem_free(esa);
7776         PerlMem_free(trn);
7777     }
7778
7779     if (lastslash > unixptr) {
7780     int dotdir_seen;
7781
7782       /* skip leading ./ */
7783       dotdir_seen = 0;
7784       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7785         dotdir_seen = 1;
7786         unixptr++;
7787         unixptr++;
7788       }
7789
7790       /* Are we still in a directory? */
7791       if (unixptr <= lastslash) {
7792         *vmsptr++ = '[';
7793         vmslen = 1;
7794         dir_start = 1;
7795
7796         /* if not backing up, then it is relative forward. */
7797         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7798               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7799           *vmsptr++ = '.';
7800           vmslen++;
7801           dir_dot = 1;
7802           }
7803        }
7804        else {
7805          if (dotdir_seen) {
7806            /* Perl wants an empty directory here to tell the difference
7807             * between a DCL command and a filename
7808             */
7809           *vmsptr++ = '[';
7810           *vmsptr++ = ']';
7811           vmslen = 2;
7812         }
7813       }
7814     }
7815     else {
7816       /* Handle two special files . and .. */
7817       if (unixptr[0] == '.') {
7818         if (&unixptr[1] == unixend) {
7819           *vmsptr++ = '[';
7820           *vmsptr++ = ']';
7821           vmslen += 2;
7822           *vmsptr++ = '\0';
7823           return SS$_NORMAL;
7824         }
7825         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7826           *vmsptr++ = '[';
7827           *vmsptr++ = '-';
7828           *vmsptr++ = ']';
7829           vmslen += 3;
7830           *vmsptr++ = '\0';
7831           return SS$_NORMAL;
7832         }
7833       }
7834     }
7835   }
7836   else {        /* Absolute PATH handling */
7837   int sts;
7838   char * nextslash;
7839   int seg_len;
7840     /* Need to find out where root is */
7841
7842     /* In theory, this procedure should never get an absolute POSIX pathname
7843      * that can not be found on the POSIX root.
7844      * In practice, that can not be relied on, and things will show up
7845      * here that are a VMS device name or concealed logical name instead.
7846      * So to make things work, this procedure must be tolerant.
7847      */
7848     esa = (char *)PerlMem_malloc(vmspath_len);
7849     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7850
7851     sts = SS$_NORMAL;
7852     nextslash = strchr(&unixptr[1],'/');
7853     seg_len = 0;
7854     if (nextslash != NULL) {
7855       int cmp;
7856       seg_len = nextslash - &unixptr[1];
7857       my_strlcpy(vmspath, unixptr, seg_len + 2);
7858       cmp = 1;
7859       if (seg_len == 3) {
7860         cmp = strncmp(vmspath, "dev", 4);
7861         if (cmp == 0) {
7862             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7863             if (sts == SS$_NORMAL)
7864                 return SS$_NORMAL;
7865         }
7866       }
7867       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7868     }
7869
7870     if ($VMS_STATUS_SUCCESS(sts)) {
7871       /* This is verified to be a real path */
7872
7873       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7874       if ($VMS_STATUS_SUCCESS(sts)) {
7875         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
7876         vmsptr = vmspath + vmslen;
7877         unixptr++;
7878         if (unixptr < lastslash) {
7879         char * rptr;
7880           vmsptr--;
7881           *vmsptr++ = '.';
7882           dir_start = 1;
7883           dir_dot = 1;
7884           if (vmslen > 7) {
7885           int cmp;
7886             rptr = vmsptr - 7;
7887             cmp = strcmp(rptr,"000000.");
7888             if (cmp == 0) {
7889               vmslen -= 7;
7890               vmsptr -= 7;
7891               vmsptr[1] = '\0';
7892             } /* removing 6 zeros */
7893           } /* vmslen < 7, no 6 zeros possible */
7894         } /* Not in a directory */
7895       } /* Posix root found */
7896       else {
7897         /* No posix root, fall back to default directory */
7898         strcpy(vmspath, "SYS$DISK:[");
7899         vmsptr = &vmspath[10];
7900         vmslen = 10;
7901         if (unixptr > lastslash) {
7902            *vmsptr = ']';
7903            vmsptr++;
7904            vmslen++;
7905         }
7906         else {
7907            dir_start = 1;
7908         }
7909       }
7910     } /* end of verified real path handling */
7911     else {
7912     int add_6zero;
7913     int islnm;
7914
7915       /* Ok, we have a device or a concealed root that is not in POSIX
7916        * or we have garbage.  Make the best of it.
7917        */
7918
7919       /* Posix to VMS destroyed this, so copy it again */
7920       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
7921       vmslen = strlen(vmspath); /* We know we're truncating. */
7922       vmsptr = &vmsptr[vmslen];
7923       islnm = 0;
7924
7925       /* Now do we need to add the fake 6 zero directory to it? */
7926       add_6zero = 1;
7927       if ((*lastslash == '/') && (nextslash < lastslash)) {
7928         /* No there is another directory */
7929         add_6zero = 0;
7930       }
7931       else {
7932       int trnend;
7933       int cmp;
7934
7935         /* now we have foo:bar or foo:[000000]bar to decide from */
7936         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7937
7938         if (!islnm && !decc_posix_compliant_pathnames) {
7939
7940             cmp = strncmp("bin", vmspath, 4);
7941             if (cmp == 0) {
7942                 /* bin => SYS$SYSTEM: */
7943                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7944             }
7945             else {
7946                 /* tmp => SYS$SCRATCH: */
7947                 cmp = strncmp("tmp", vmspath, 4);
7948                 if (cmp == 0) {
7949                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7950                 }
7951             }
7952         }
7953
7954         trnend = islnm ? islnm - 1 : 0;
7955
7956         /* if this was a logical name, ']' or '>' must be present */
7957         /* if not a logical name, then assume a device and hope. */
7958         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7959
7960         /* if log name and trailing '.' then rooted - treat as device */
7961         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7962
7963         /* Fix me, if not a logical name, a device lookup should be
7964          * done to see if the device is file structured.  If the device
7965          * is not file structured, the 6 zeros should not be put on.
7966          *
7967          * As it is, perl is occasionally looking for dev:[000000]tty.
7968          * which looks a little strange.
7969          *
7970          * Not that easy to detect as "/dev" may be file structured with
7971          * special device files.
7972          */
7973
7974         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
7975             (&nextslash[1] == unixend)) {
7976           /* No real directory present */
7977           add_6zero = 1;
7978         }
7979       }
7980
7981       /* Put the device delimiter on */
7982       *vmsptr++ = ':';
7983       vmslen++;
7984       unixptr = nextslash;
7985       unixptr++;
7986
7987       /* Start directory if needed */
7988       if (!islnm || add_6zero) {
7989         *vmsptr++ = '[';
7990         vmslen++;
7991         dir_start = 1;
7992       }
7993
7994       /* add fake 000000] if needed */
7995       if (add_6zero) {
7996         *vmsptr++ = '0';
7997         *vmsptr++ = '0';
7998         *vmsptr++ = '0';
7999         *vmsptr++ = '0';
8000         *vmsptr++ = '0';
8001         *vmsptr++ = '0';
8002         *vmsptr++ = ']';
8003         vmslen += 7;
8004         dir_start = 0;
8005       }
8006
8007     } /* non-POSIX translation */
8008     PerlMem_free(esa);
8009   } /* End of relative/absolute path handling */
8010
8011   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8012   int dash_flag;
8013   int in_cnt;
8014   int out_cnt;
8015
8016     dash_flag = 0;
8017
8018     if (dir_start != 0) {
8019
8020       /* First characters in a directory are handled special */
8021       while ((*unixptr == '/') ||
8022              ((*unixptr == '.') &&
8023               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8024                 (&unixptr[1]==unixend)))) {
8025       int loop_flag;
8026
8027         loop_flag = 0;
8028
8029         /* Skip redundant / in specification */
8030         while ((*unixptr == '/') && (dir_start != 0)) {
8031           loop_flag = 1;
8032           unixptr++;
8033           if (unixptr == lastslash)
8034             break;
8035         }
8036         if (unixptr == lastslash)
8037           break;
8038
8039         /* Skip redundant ./ characters */
8040         while ((*unixptr == '.') &&
8041                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8042           loop_flag = 1;
8043           unixptr++;
8044           if (unixptr == lastslash)
8045             break;
8046           if (*unixptr == '/')
8047             unixptr++;
8048         }
8049         if (unixptr == lastslash)
8050           break;
8051
8052         /* Skip redundant ../ characters */
8053         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8054              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8055           /* Set the backing up flag */
8056           loop_flag = 1;
8057           dir_dot = 0;
8058           dash_flag = 1;
8059           *vmsptr++ = '-';
8060           vmslen++;
8061           unixptr++; /* first . */
8062           unixptr++; /* second . */
8063           if (unixptr == lastslash)
8064             break;
8065           if (*unixptr == '/') /* The slash */
8066             unixptr++;
8067         }
8068         if (unixptr == lastslash)
8069           break;
8070
8071         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8072         /* Not needed when VMS is pretending to be UNIX. */
8073
8074         /* Is this loop stuck because of too many dots? */
8075         if (loop_flag == 0) {
8076           /* Exit the loop and pass the rest through */
8077           break;
8078         }
8079       }
8080
8081       /* Are we done with directories yet? */
8082       if (unixptr >= lastslash) {
8083
8084         /* Watch out for trailing dots */
8085         if (dir_dot != 0) {
8086             vmslen --;
8087             vmsptr--;
8088         }
8089         *vmsptr++ = ']';
8090         vmslen++;
8091         dash_flag = 0;
8092         dir_start = 0;
8093         if (*unixptr == '/')
8094           unixptr++;
8095       }
8096       else {
8097         /* Have we stopped backing up? */
8098         if (dash_flag) {
8099           *vmsptr++ = '.';
8100           vmslen++;
8101           dash_flag = 0;
8102           /* dir_start continues to be = 1 */
8103         }
8104         if (*unixptr == '-') {
8105           *vmsptr++ = '^';
8106           *vmsptr++ = *unixptr++;
8107           vmslen += 2;
8108           dir_start = 0;
8109
8110           /* Now are we done with directories yet? */
8111           if (unixptr >= lastslash) {
8112
8113             /* Watch out for trailing dots */
8114             if (dir_dot != 0) {
8115               vmslen --;
8116               vmsptr--;
8117             }
8118
8119             *vmsptr++ = ']';
8120             vmslen++;
8121             dash_flag = 0;
8122             dir_start = 0;
8123           }
8124         }
8125       }
8126     }
8127
8128     /* All done? */
8129     if (unixptr >= unixend)
8130       break;
8131
8132     /* Normal characters - More EFS work probably needed */
8133     dir_start = 0;
8134     dir_dot = 0;
8135
8136     switch(*unixptr) {
8137     case '/':
8138         /* remove multiple / */
8139         while (unixptr[1] == '/') {
8140            unixptr++;
8141         }
8142         if (unixptr == lastslash) {
8143           /* Watch out for trailing dots */
8144           if (dir_dot != 0) {
8145             vmslen --;
8146             vmsptr--;
8147           }
8148           *vmsptr++ = ']';
8149         }
8150         else {
8151           dir_start = 1;
8152           *vmsptr++ = '.';
8153           dir_dot = 1;
8154
8155           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8156           /* Not needed when VMS is pretending to be UNIX. */
8157
8158         }
8159         dash_flag = 0;
8160         if (unixptr != unixend)
8161           unixptr++;
8162         vmslen++;
8163         break;
8164     case '.':
8165         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8166             (&unixptr[1] == unixend)) {
8167           *vmsptr++ = '^';
8168           *vmsptr++ = '.';
8169           vmslen += 2;
8170           unixptr++;
8171
8172           /* trailing dot ==> '^..' on VMS */
8173           if (unixptr == unixend) {
8174             *vmsptr++ = '.';
8175             vmslen++;
8176             unixptr++;
8177           }
8178           break;
8179         }
8180
8181         *vmsptr++ = *unixptr++;
8182         vmslen ++;
8183         break;
8184     case '"':
8185         if (quoted && (&unixptr[1] == unixend)) {
8186             unixptr++;
8187             break;
8188         }
8189         in_cnt = copy_expand_unix_filename_escape
8190                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8191         vmsptr += out_cnt;
8192         unixptr += in_cnt;
8193         break;
8194     case '~':
8195     case ';':
8196     case '\\':
8197     case '?':
8198     case ' ':
8199     default:
8200         in_cnt = copy_expand_unix_filename_escape
8201                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8202         vmsptr += out_cnt;
8203         unixptr += in_cnt;
8204         break;
8205     }
8206   }
8207
8208   /* Make sure directory is closed */
8209   if (unixptr == lastslash) {
8210     char *vmsptr2;
8211     vmsptr2 = vmsptr - 1;
8212
8213     if (*vmsptr2 != ']') {
8214       *vmsptr2--;
8215
8216       /* directories do not end in a dot bracket */
8217       if (*vmsptr2 == '.') {
8218         vmsptr2--;
8219
8220         /* ^. is allowed */
8221         if (*vmsptr2 != '^') {
8222           vmsptr--; /* back up over the dot */
8223         }
8224       }
8225       *vmsptr++ = ']';
8226     }
8227   }
8228   else {
8229     char *vmsptr2;
8230     /* Add a trailing dot if a file with no extension */
8231     vmsptr2 = vmsptr - 1;
8232     if ((vmslen > 1) &&
8233         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8234         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8235         *vmsptr++ = '.';
8236         vmslen++;
8237     }
8238   }
8239
8240   *vmsptr = '\0';
8241   return SS$_NORMAL;
8242 }
8243 #endif
8244
8245  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8246 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8247 {
8248 char * result;
8249 int utf8_flag;
8250
8251    /* If a UTF8 flag is being passed, honor it */
8252    utf8_flag = 0;
8253    if (utf8_fl != NULL) {
8254      utf8_flag = *utf8_fl;
8255     *utf8_fl = 0;
8256    }
8257
8258    if (utf8_flag) {
8259      /* If there is a possibility of UTF8, then if any UTF8 characters
8260         are present, then they must be converted to VTF-7
8261       */
8262      result = strcpy(rslt, path); /* FIX-ME */
8263    }
8264    else
8265      result = strcpy(rslt, path);
8266
8267    return result;
8268 }
8269
8270 /* A convenience macro for copying dots in filenames and escaping
8271  * them when they haven't already been escaped, with guards to
8272  * avoid checking before the start of the buffer or advancing
8273  * beyond the end of it (allowing room for the NUL terminator).
8274  */
8275 #define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
8276     if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8277           || ((vmsefsdot) == (vmsefsbuf))) \
8278          && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
8279        ) { \
8280         *((vmsefsdot)++) = '^'; \
8281     } \
8282     if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8283         *((vmsefsdot)++) = '.'; \
8284 } STMT_END
8285
8286 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8287 static char *int_tovmsspec
8288    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8289   char *dirend;
8290   char *lastdot;
8291   char *cp1;
8292   const char *cp2;
8293   unsigned long int infront = 0, hasdir = 1;
8294   int rslt_len;
8295   int no_type_seen;
8296   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8297   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8298
8299   if (vms_debug_fileify) {
8300       if (path == NULL)
8301           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8302       else
8303           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8304   }
8305
8306   if (path == NULL) {
8307       /* If we fail, we should be setting errno */
8308       set_errno(EINVAL);
8309       set_vaxc_errno(SS$_BADPARAM);
8310       return NULL;
8311   }
8312   rslt_len = VMS_MAXRSS-1;
8313
8314   /* '.' and '..' are "[]" and "[-]" for a quick check */
8315   if (path[0] == '.') {
8316     if (path[1] == '\0') {
8317       strcpy(rslt,"[]");
8318       if (utf8_flag != NULL)
8319         *utf8_flag = 0;
8320       return rslt;
8321     }
8322     else {
8323       if (path[1] == '.' && path[2] == '\0') {
8324         strcpy(rslt,"[-]");
8325         if (utf8_flag != NULL)
8326            *utf8_flag = 0;
8327         return rslt;
8328       }
8329     }
8330   }
8331
8332    /* Posix specifications are now a native VMS format */
8333   /*--------------------------------------------------*/
8334 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8335   if (decc_posix_compliant_pathnames) {
8336     if (strncmp(path,"\"^UP^",5) == 0) {
8337       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8338       return rslt;
8339     }
8340   }
8341 #endif
8342
8343   /* This is really the only way to see if this is already in VMS format */
8344   sts = vms_split_path
8345        (path,
8346         &v_spec,
8347         &v_len,
8348         &r_spec,
8349         &r_len,
8350         &d_spec,
8351         &d_len,
8352         &n_spec,
8353         &n_len,
8354         &e_spec,
8355         &e_len,
8356         &vs_spec,
8357         &vs_len);
8358   if (sts == 0) {
8359     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8360        replacement, because the above parse just took care of most of
8361        what is needed to do vmspath when the specification is already
8362        in VMS format.
8363
8364        And if it is not already, it is easier to do the conversion as
8365        part of this routine than to call this routine and then work on
8366        the result.
8367      */
8368
8369     /* If VMS punctuation was found, it is already VMS format */
8370     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8371       if (utf8_flag != NULL)
8372         *utf8_flag = 0;
8373       my_strlcpy(rslt, path, VMS_MAXRSS);
8374       if (vms_debug_fileify) {
8375           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8376       }
8377       return rslt;
8378     }
8379     /* Now, what to do with trailing "." cases where there is no
8380        extension?  If this is a UNIX specification, and EFS characters
8381        are enabled, then the trailing "." should be converted to a "^.".
8382        But if this was already a VMS specification, then it should be
8383        left alone.
8384
8385        So in the case of ambiguity, leave the specification alone.
8386      */
8387
8388
8389     /* If there is a possibility of UTF8, then if any UTF8 characters
8390         are present, then they must be converted to VTF-7
8391      */
8392     if (utf8_flag != NULL)
8393       *utf8_flag = 0;
8394     my_strlcpy(rslt, path, VMS_MAXRSS);
8395     if (vms_debug_fileify) {
8396         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8397     }
8398     return rslt;
8399   }
8400
8401   dirend = strrchr(path,'/');
8402
8403   if (dirend == NULL) {
8404      /* If we get here with no Unix directory delimiters, then this is an
8405       * ambiguous file specification, such as a Unix glob specification, a
8406       * shell or make macro, or a filespec that would be valid except for
8407       * unescaped extended characters.  The safest thing if it's a macro
8408       * is to pass it through as-is.
8409       */
8410       if (strstr(path, "$(")) {
8411           my_strlcpy(rslt, path, VMS_MAXRSS);
8412           if (vms_debug_fileify) {
8413               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8414           }
8415           return rslt;
8416       }
8417       hasdir = 0;
8418   }
8419   else if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8420     if (!*(dirend+2)) dirend +=2;
8421     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8422     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8423   }
8424
8425   cp1 = rslt;
8426   cp2 = path;
8427   lastdot = strrchr(cp2,'.');
8428   if (*cp2 == '/') {
8429     char *trndev;
8430     int islnm, rooted;
8431     STRLEN trnend;
8432
8433     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8434     if (!*(cp2+1)) {
8435       if (decc_disable_posix_root) {
8436         strcpy(rslt,"sys$disk:[000000]");
8437       }
8438       else {
8439         strcpy(rslt,"sys$posix_root:[000000]");
8440       }
8441       if (utf8_flag != NULL)
8442         *utf8_flag = 0;
8443       if (vms_debug_fileify) {
8444           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8445       }
8446       return rslt;
8447     }
8448     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8449     *cp1 = '\0';
8450     trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8451     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8452     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8453
8454      /* DECC special handling */
8455     if (!islnm) {
8456       if (strcmp(rslt,"bin") == 0) {
8457         strcpy(rslt,"sys$system");
8458         cp1 = rslt + 10;
8459         *cp1 = 0;
8460         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8461       }
8462       else if (strcmp(rslt,"tmp") == 0) {
8463         strcpy(rslt,"sys$scratch");
8464         cp1 = rslt + 11;
8465         *cp1 = 0;
8466         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8467       }
8468       else if (!decc_disable_posix_root) {
8469         strcpy(rslt, "sys$posix_root");
8470         cp1 = rslt + 14;
8471         *cp1 = 0;
8472         cp2 = path;
8473         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8474         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8475       }
8476       else if (strcmp(rslt,"dev") == 0) {
8477         if (strncmp(cp2,"/null", 5) == 0) {
8478           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8479             strcpy(rslt,"NLA0");
8480             cp1 = rslt + 4;
8481             *cp1 = 0;
8482             cp2 = cp2 + 5;
8483             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8484           }
8485         }
8486       }
8487     }
8488
8489     trnend = islnm ? strlen(trndev) - 1 : 0;
8490     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8491     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8492     /* If the first element of the path is a logical name, determine
8493      * whether it has to be translated so we can add more directories. */
8494     if (!islnm || rooted) {
8495       *(cp1++) = ':';
8496       *(cp1++) = '[';
8497       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8498       else cp2++;
8499     }
8500     else {
8501       if (cp2 != dirend) {
8502         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8503         cp1 = rslt + trnend;
8504         if (*cp2 != 0) {
8505           *(cp1++) = '.';
8506           cp2++;
8507         }
8508       }
8509       else {
8510         if (decc_disable_posix_root) {
8511           *(cp1++) = ':';
8512           hasdir = 0;
8513         }
8514       }
8515     }
8516     PerlMem_free(trndev);
8517   }
8518   else if (hasdir) {
8519     *(cp1++) = '[';
8520     if (*cp2 == '.') {
8521       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8522         cp2 += 2;         /* skip over "./" - it's redundant */
8523         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8524       }
8525       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8526         *(cp1++) = '-';                                 /* "../" --> "-" */
8527         cp2 += 3;
8528       }
8529       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8530                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8531         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8532         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8533         cp2 += 4;
8534       }
8535       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8536         /* Escape the extra dots in EFS file specifications */
8537         *(cp1++) = '^';
8538       }
8539       if (cp2 > dirend) cp2 = dirend;
8540     }
8541     else *(cp1++) = '.';
8542   }
8543   for (; cp2 < dirend; cp2++) {
8544     if (*cp2 == '/') {
8545       if (*(cp2-1) == '/') continue;
8546       if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
8547       infront = 0;
8548     }
8549     else if (!infront && *cp2 == '.') {
8550       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8551       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8552       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8553         if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
8554         else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
8555         else {
8556           *(cp1++) = '-';
8557         }
8558         cp2 += 2;
8559         if (cp2 == dirend) break;
8560       }
8561       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8562                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8563         if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8564         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8565         if (!*(cp2+3)) {
8566           *(cp1++) = '.';  /* Simulate trailing '/' */
8567           cp2 += 2;  /* for loop will incr this to == dirend */
8568         }
8569         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8570       }
8571       else {
8572         if (decc_efs_charset == 0) {
8573           if (cp1 > rslt && *(cp1-1) == '^')
8574             cp1--;         /* remove the escape, if any */
8575           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8576         }
8577         else {
8578           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8579         }
8580       }
8581     }
8582     else {
8583       if (!infront && cp1 > rslt && *(cp1-1) == '-')  *(cp1++) = '.';
8584       if (*cp2 == '.') {
8585         if (decc_efs_charset == 0) {
8586           if (cp1 > rslt && *(cp1-1) == '^')
8587             cp1--;         /* remove the escape, if any */
8588           *(cp1++) = '_';
8589         }
8590         else {
8591           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8592         }
8593       }
8594       else                  *(cp1++) =  *cp2;
8595       infront = 1;
8596     }
8597   }
8598   if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8599   if (hasdir) *(cp1++) = ']';
8600   if (*cp2 && *cp2 == '/') cp2++;  /* check in case we ended with trailing '/' */
8601   no_type_seen = 0;
8602   if (cp2 > lastdot)
8603     no_type_seen = 1;
8604   while (*cp2) {
8605     switch(*cp2) {
8606     case '?':
8607         if (decc_efs_charset == 0)
8608           *(cp1++) = '%';
8609         else
8610           *(cp1++) = '?';
8611         cp2++;
8612     case ' ':
8613         if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
8614             *(cp1)++ = '^';
8615         *(cp1)++ = '_';
8616         cp2++;
8617         break;
8618     case '.':
8619         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8620             decc_readdir_dropdotnotype) {
8621           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8622           cp2++;
8623
8624           /* trailing dot ==> '^..' on VMS */
8625           if (*cp2 == '\0') {
8626             *(cp1++) = '.';
8627             no_type_seen = 0;
8628           }
8629         }
8630         else {
8631           *(cp1++) = *(cp2++);
8632           no_type_seen = 0;
8633         }
8634         break;
8635     case '$':
8636          /* This could be a macro to be passed through */
8637         *(cp1++) = *(cp2++);
8638         if (*cp2 == '(') {
8639         const char * save_cp2;
8640         char * save_cp1;
8641         int is_macro;
8642
8643             /* paranoid check */
8644             save_cp2 = cp2;
8645             save_cp1 = cp1;
8646             is_macro = 0;
8647
8648             /* Test through */
8649             *(cp1++) = *(cp2++);
8650             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8651                 *(cp1++) = *(cp2++);
8652                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8653                     *(cp1++) = *(cp2++);
8654                 }
8655                 if (*cp2 == ')') {
8656                     *(cp1++) = *(cp2++);
8657                     is_macro = 1;
8658                 }
8659             }
8660             if (is_macro == 0) {
8661                 /* Not really a macro - never mind */
8662                 cp2 = save_cp2;
8663                 cp1 = save_cp1;
8664             }
8665         }
8666         break;
8667     case '\"':
8668     case '~':
8669     case '`':
8670     case '!':
8671     case '#':
8672     case '%':
8673     case '^':
8674         /* Don't escape again if following character is
8675          * already something we escape.
8676          */
8677         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8678             *(cp1++) = *(cp2++);
8679             break;
8680         }
8681         /* But otherwise fall through and escape it. */
8682     case '&':
8683     case '(':
8684     case ')':
8685     case '=':
8686     case '+':
8687     case '\'':
8688     case '@':
8689     case '[':
8690     case ']':
8691     case '{':
8692     case '}':
8693     case ':':
8694     case '\\':
8695     case '|':
8696     case '<':
8697     case '>':
8698         if (cp2 > path && *(cp2-1) != '^') /* not previously escaped */
8699             *(cp1++) = '^';
8700         *(cp1++) = *(cp2++);
8701         break;
8702     case ';':
8703         /* If it doesn't look like the beginning of a version number,
8704          * or we've been promised there are no version numbers, then
8705          * escape it.
8706          */
8707         if (decc_filename_unix_no_version) {
8708           *(cp1++) = '^';
8709         }
8710         else {
8711           size_t all_nums = strspn(cp2+1, "0123456789");
8712           if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0')
8713             *(cp1++) = '^';
8714         }
8715         *(cp1++) = *(cp2++);
8716         break;
8717     default:
8718         *(cp1++) = *(cp2++);
8719     }
8720   }
8721   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8722   char *lcp1;
8723     lcp1 = cp1;
8724     lcp1--;
8725      /* Fix me for "^]", but that requires making sure that you do
8726       * not back up past the start of the filename
8727       */
8728     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8729       *cp1++ = '.';
8730   }
8731   *cp1 = '\0';
8732
8733   if (utf8_flag != NULL)
8734     *utf8_flag = 0;
8735   if (vms_debug_fileify) {
8736       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8737   }
8738   return rslt;
8739
8740 }  /* end of int_tovmsspec() */
8741
8742
8743 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8744 static char *mp_do_tovmsspec
8745    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8746   static char __tovmsspec_retbuf[VMS_MAXRSS];
8747     char * vmsspec, *ret_spec, *ret_buf;
8748
8749     vmsspec = NULL;
8750     ret_buf = buf;
8751     if (ret_buf == NULL) {
8752         if (ts) {
8753             Newx(vmsspec, VMS_MAXRSS, char);
8754             if (vmsspec == NULL)
8755                 _ckvmssts(SS$_INSFMEM);
8756             ret_buf = vmsspec;
8757         } else {
8758             ret_buf = __tovmsspec_retbuf;
8759         }
8760     }
8761
8762     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8763
8764     if (ret_spec == NULL) {
8765        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8766        if (vmsspec)
8767            Safefree(vmsspec);
8768     }
8769
8770     return ret_spec;
8771
8772 }  /* end of mp_do_tovmsspec() */
8773 /*}}}*/
8774 /* External entry points */
8775 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8776   { return do_tovmsspec(path,buf,0,NULL); }
8777 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8778   { return do_tovmsspec(path,buf,1,NULL); }
8779 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8780   { return do_tovmsspec(path,buf,0,utf8_fl); }
8781 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8782   { return do_tovmsspec(path,buf,1,utf8_fl); }
8783
8784 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8785 /* Internal routine for use with out an explicit context present */
8786 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
8787
8788     char * ret_spec, *pathified;
8789
8790     if (path == NULL)
8791         return NULL;
8792
8793     pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8794     if (pathified == NULL)
8795         _ckvmssts_noperl(SS$_INSFMEM);
8796
8797     ret_spec = int_pathify_dirspec(path, pathified);
8798
8799     if (ret_spec == NULL) {
8800         PerlMem_free(pathified);
8801         return NULL;
8802     }
8803
8804     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8805
8806     PerlMem_free(pathified);
8807     return ret_spec;
8808
8809 }
8810
8811 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8812 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8813   static char __tovmspath_retbuf[VMS_MAXRSS];
8814   int vmslen;
8815   char *pathified, *vmsified, *cp;
8816
8817   if (path == NULL) return NULL;
8818   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8819   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8820   if (int_pathify_dirspec(path, pathified) == NULL) {
8821     PerlMem_free(pathified);
8822     return NULL;
8823   }
8824
8825   vmsified = NULL;
8826   if (buf == NULL)
8827      Newx(vmsified, VMS_MAXRSS, char);
8828   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8829     PerlMem_free(pathified);
8830     if (vmsified) Safefree(vmsified);
8831     return NULL;
8832   }
8833   PerlMem_free(pathified);
8834   if (buf) {
8835     return buf;
8836   }
8837   else if (ts) {
8838     vmslen = strlen(vmsified);
8839     Newx(cp,vmslen+1,char);
8840     memcpy(cp,vmsified,vmslen);
8841     cp[vmslen] = '\0';
8842     Safefree(vmsified);
8843     return cp;
8844   }
8845   else {
8846     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8847     Safefree(vmsified);
8848     return __tovmspath_retbuf;
8849   }
8850
8851 }  /* end of do_tovmspath() */
8852 /*}}}*/
8853 /* External entry points */
8854 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8855   { return do_tovmspath(path,buf,0, NULL); }
8856 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8857   { return do_tovmspath(path,buf,1, NULL); }
8858 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8859   { return do_tovmspath(path,buf,0,utf8_fl); }
8860 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8861   { return do_tovmspath(path,buf,1,utf8_fl); }
8862
8863
8864 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8865 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8866   static char __tounixpath_retbuf[VMS_MAXRSS];
8867   int unixlen;
8868   char *pathified, *unixified, *cp;
8869
8870   if (path == NULL) return NULL;
8871   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8872   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8873   if (int_pathify_dirspec(path, pathified) == NULL) {
8874     PerlMem_free(pathified);
8875     return NULL;
8876   }
8877
8878   unixified = NULL;
8879   if (buf == NULL) {
8880       Newx(unixified, VMS_MAXRSS, char);
8881   }
8882   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8883     PerlMem_free(pathified);
8884     if (unixified) Safefree(unixified);
8885     return NULL;
8886   }
8887   PerlMem_free(pathified);
8888   if (buf) {
8889     return buf;
8890   }
8891   else if (ts) {
8892     unixlen = strlen(unixified);
8893     Newx(cp,unixlen+1,char);
8894     memcpy(cp,unixified,unixlen);
8895     cp[unixlen] = '\0';
8896     Safefree(unixified);
8897     return cp;
8898   }
8899   else {
8900     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
8901     Safefree(unixified);
8902     return __tounixpath_retbuf;
8903   }
8904
8905 }  /* end of do_tounixpath() */
8906 /*}}}*/
8907 /* External entry points */
8908 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8909   { return do_tounixpath(path,buf,0,NULL); }
8910 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8911   { return do_tounixpath(path,buf,1,NULL); }
8912 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8913   { return do_tounixpath(path,buf,0,utf8_fl); }
8914 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8915   { return do_tounixpath(path,buf,1,utf8_fl); }
8916
8917 /*
8918  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8919  *
8920  *****************************************************************************
8921  *                                                                           *
8922  *  Copyright (C) 1989-1994, 2007 by                                         *
8923  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8924  *                                                                           *
8925  *  Permission is hereby granted for the reproduction of this software       *
8926  *  on condition that this copyright notice is included in source            *
8927  *  distributions of the software.  The code may be modified and             *
8928  *  distributed under the same terms as Perl itself.                         *
8929  *                                                                           *
8930  *  27-Aug-1994 Modified for inclusion in perl5                              *
8931  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8932  *****************************************************************************
8933  */
8934
8935 /*
8936  * getredirection() is intended to aid in porting C programs
8937  * to VMS (Vax-11 C).  The native VMS environment does not support
8938  * '>' and '<' I/O redirection, or command line wild card expansion,
8939  * or a command line pipe mechanism using the '|' AND background
8940  * command execution '&'.  All of these capabilities are provided to any
8941  * C program which calls this procedure as the first thing in the
8942  * main program.
8943  * The piping mechanism will probably work with almost any 'filter' type
8944  * of program.  With suitable modification, it may useful for other
8945  * portability problems as well.
8946  *
8947  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8948  */
8949 struct list_item
8950     {
8951     struct list_item *next;
8952     char *value;
8953     };
8954
8955 static void add_item(struct list_item **head,
8956                      struct list_item **tail,
8957                      char *value,
8958                      int *count);
8959
8960 static void mp_expand_wild_cards(pTHX_ char *item,
8961                                 struct list_item **head,
8962                                 struct list_item **tail,
8963                                 int *count);
8964
8965 static int background_process(pTHX_ int argc, char **argv);
8966
8967 static void pipe_and_fork(pTHX_ char **cmargv);
8968
8969 /*{{{ void getredirection(int *ac, char ***av)*/
8970 static void
8971 mp_getredirection(pTHX_ int *ac, char ***av)
8972 /*
8973  * Process vms redirection arg's.  Exit if any error is seen.
8974  * If getredirection() processes an argument, it is erased
8975  * from the vector.  getredirection() returns a new argc and argv value.
8976  * In the event that a background command is requested (by a trailing "&"),
8977  * this routine creates a background subprocess, and simply exits the program.
8978  *
8979  * Warning: do not try to simplify the code for vms.  The code
8980  * presupposes that getredirection() is called before any data is
8981  * read from stdin or written to stdout.
8982  *
8983  * Normal usage is as follows:
8984  *
8985  *      main(argc, argv)
8986  *      int             argc;
8987  *      char            *argv[];
8988  *      {
8989  *              getredirection(&argc, &argv);
8990  *      }
8991  */
8992 {
8993     int                 argc = *ac;     /* Argument Count         */
8994     char                **argv = *av;   /* Argument Vector        */
8995     char                *ap;            /* Argument pointer       */
8996     int                 j;              /* argv[] index           */
8997     int                 item_count = 0; /* Count of Items in List */
8998     struct list_item    *list_head = 0; /* First Item in List       */
8999     struct list_item    *list_tail;     /* Last Item in List        */
9000     char                *in = NULL;     /* Input File Name          */
9001     char                *out = NULL;    /* Output File Name         */
9002     char                *outmode = "w"; /* Mode to Open Output File */
9003     char                *err = NULL;    /* Error File Name          */
9004     char                *errmode = "w"; /* Mode to Open Error File  */
9005     int                 cmargc = 0;     /* Piped Command Arg Count  */
9006     char                **cmargv = NULL;/* Piped Command Arg Vector */
9007
9008     /*
9009      * First handle the case where the last thing on the line ends with
9010      * a '&'.  This indicates the desire for the command to be run in a
9011      * subprocess, so we satisfy that desire.
9012      */
9013     ap = argv[argc-1];
9014     if (0 == strcmp("&", ap))
9015        exit(background_process(aTHX_ --argc, argv));
9016     if (*ap && '&' == ap[strlen(ap)-1])
9017         {
9018         ap[strlen(ap)-1] = '\0';
9019        exit(background_process(aTHX_ argc, argv));
9020         }
9021     /*
9022      * Now we handle the general redirection cases that involve '>', '>>',
9023      * '<', and pipes '|'.
9024      */
9025     for (j = 0; j < argc; ++j)
9026         {
9027         if (0 == strcmp("<", argv[j]))
9028             {
9029             if (j+1 >= argc)
9030                 {
9031                 fprintf(stderr,"No input file after < on command line");
9032                 exit(LIB$_WRONUMARG);
9033                 }
9034             in = argv[++j];
9035             continue;
9036             }
9037         if ('<' == *(ap = argv[j]))
9038             {
9039             in = 1 + ap;
9040             continue;
9041             }
9042         if (0 == strcmp(">", ap))
9043             {
9044             if (j+1 >= argc)
9045                 {
9046                 fprintf(stderr,"No output file after > on command line");
9047                 exit(LIB$_WRONUMARG);
9048                 }
9049             out = argv[++j];
9050             continue;
9051             }
9052         if ('>' == *ap)
9053             {
9054             if ('>' == ap[1])
9055                 {
9056                 outmode = "a";
9057                 if ('\0' == ap[2])
9058                     out = argv[++j];
9059                 else
9060                     out = 2 + ap;
9061                 }
9062             else
9063                 out = 1 + ap;
9064             if (j >= argc)
9065                 {
9066                 fprintf(stderr,"No output file after > or >> on command line");
9067                 exit(LIB$_WRONUMARG);
9068                 }
9069             continue;
9070             }
9071         if (('2' == *ap) && ('>' == ap[1]))
9072             {
9073             if ('>' == ap[2])
9074                 {
9075                 errmode = "a";
9076                 if ('\0' == ap[3])
9077                     err = argv[++j];
9078                 else
9079                     err = 3 + ap;
9080                 }
9081             else
9082                 if ('\0' == ap[2])
9083                     err = argv[++j];
9084                 else
9085                     err = 2 + ap;
9086             if (j >= argc)
9087                 {
9088                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9089                 exit(LIB$_WRONUMARG);
9090                 }
9091             continue;
9092             }
9093         if (0 == strcmp("|", argv[j]))
9094             {
9095             if (j+1 >= argc)
9096                 {
9097                 fprintf(stderr,"No command into which to pipe on command line");
9098                 exit(LIB$_WRONUMARG);
9099                 }
9100             cmargc = argc-(j+1);
9101             cmargv = &argv[j+1];
9102             argc = j;
9103             continue;
9104             }
9105         if ('|' == *(ap = argv[j]))
9106             {
9107             ++argv[j];
9108             cmargc = argc-j;
9109             cmargv = &argv[j];
9110             argc = j;
9111             continue;
9112             }
9113         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9114         }
9115     /*
9116      * Allocate and fill in the new argument vector, Some Unix's terminate
9117      * the list with an extra null pointer.
9118      */
9119     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9120     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9121     *av = argv;
9122     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9123         argv[j] = list_head->value;
9124     *ac = item_count;
9125     if (cmargv != NULL)
9126         {
9127         if (out != NULL)
9128             {
9129             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9130             exit(LIB$_INVARGORD);
9131             }
9132         pipe_and_fork(aTHX_ cmargv);
9133         }
9134
9135     /* Check for input from a pipe (mailbox) */
9136
9137     if (in == NULL && 1 == isapipe(0))
9138         {
9139         char mbxname[L_tmpnam];
9140         long int bufsize;
9141         long int dvi_item = DVI$_DEVBUFSIZ;
9142         $DESCRIPTOR(mbxnam, "");
9143         $DESCRIPTOR(mbxdevnam, "");
9144
9145         /* Input from a pipe, reopen it in binary mode to disable       */
9146         /* carriage control processing.                                 */
9147
9148         fgetname(stdin, mbxname, 1);
9149         mbxnam.dsc$a_pointer = mbxname;
9150         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9151         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9152         mbxdevnam.dsc$a_pointer = mbxname;
9153         mbxdevnam.dsc$w_length = sizeof(mbxname);
9154         dvi_item = DVI$_DEVNAM;
9155         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9156         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9157         set_errno(0);
9158         set_vaxc_errno(1);
9159         freopen(mbxname, "rb", stdin);
9160         if (errno != 0)
9161             {
9162             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9163             exit(vaxc$errno);
9164             }
9165         }
9166     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9167         {
9168         fprintf(stderr,"Can't open input file %s as stdin",in);
9169         exit(vaxc$errno);
9170         }
9171     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9172         {
9173         fprintf(stderr,"Can't open output file %s as stdout",out);
9174         exit(vaxc$errno);
9175         }
9176         if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
9177
9178     if (err != NULL) {
9179         if (strcmp(err,"&1") == 0) {
9180             dup2(fileno(stdout), fileno(stderr));
9181             vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
9182         } else {
9183         FILE *tmperr;
9184         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9185             {
9186             fprintf(stderr,"Can't open error file %s as stderr",err);
9187             exit(vaxc$errno);
9188             }
9189             fclose(tmperr);
9190            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9191                 {
9192                 exit(vaxc$errno);
9193                 }
9194             vmssetuserlnm("SYS$ERROR", err);
9195         }
9196         }
9197 #ifdef ARGPROC_DEBUG
9198     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9199     for (j = 0; j < *ac;  ++j)
9200         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9201 #endif
9202    /* Clear errors we may have hit expanding wildcards, so they don't
9203       show up in Perl's $! later */
9204    set_errno(0); set_vaxc_errno(1);
9205 }  /* end of getredirection() */
9206 /*}}}*/
9207
9208 static void add_item(struct list_item **head,
9209                      struct list_item **tail,
9210                      char *value,
9211                      int *count)
9212 {
9213     if (*head == 0)
9214         {
9215         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9216         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9217         *tail = *head;
9218         }
9219     else {
9220         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9221         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9222         *tail = (*tail)->next;
9223         }
9224     (*tail)->value = value;
9225     ++(*count);
9226 }
9227
9228 static void mp_expand_wild_cards(pTHX_ char *item,
9229                               struct list_item **head,
9230                               struct list_item **tail,
9231                               int *count)
9232 {
9233 int expcount = 0;
9234 unsigned long int context = 0;
9235 int isunix = 0;
9236 int item_len = 0;
9237 char *had_version;
9238 char *had_device;
9239 int had_directory;
9240 char *devdir,*cp;
9241 char *vmsspec;
9242 $DESCRIPTOR(filespec, "");
9243 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9244 $DESCRIPTOR(resultspec, "");
9245 unsigned long int lff_flags = 0;
9246 int sts;
9247 int rms_sts;
9248
9249 #ifdef VMS_LONGNAME_SUPPORT
9250     lff_flags = LIB$M_FIL_LONG_NAMES;
9251 #endif
9252
9253     for (cp = item; *cp; cp++) {
9254         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9255         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9256     }
9257     if (!*cp || isspace(*cp))
9258         {
9259         add_item(head, tail, item, count);
9260         return;
9261         }
9262     else
9263         {
9264      /* "double quoted" wild card expressions pass as is */
9265      /* From DCL that means using e.g.:                  */
9266      /* perl program """perl.*"""                        */
9267      item_len = strlen(item);
9268      if ( '"' == *item && '"' == item[item_len-1] )
9269        {
9270        item++;
9271        item[item_len-2] = '\0';
9272        add_item(head, tail, item, count);
9273        return;
9274        }
9275      }
9276     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9277     resultspec.dsc$b_class = DSC$K_CLASS_D;
9278     resultspec.dsc$a_pointer = NULL;
9279     vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9280     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9281     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9282       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9283     if (!isunix || !filespec.dsc$a_pointer)
9284       filespec.dsc$a_pointer = item;
9285     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9286     /*
9287      * Only return version specs, if the caller specified a version
9288      */
9289     had_version = strchr(item, ';');
9290     /*
9291      * Only return device and directory specs, if the caller specified either.
9292      */
9293     had_device = strchr(item, ':');
9294     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9295
9296     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9297                                  (&filespec, &resultspec, &context,
9298                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9299         {
9300         char *string;
9301         char *c;
9302
9303         string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9304         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9305         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9306         if (NULL == had_version)
9307             *(strrchr(string, ';')) = '\0';
9308         if ((!had_directory) && (had_device == NULL))
9309             {
9310             if (NULL == (devdir = strrchr(string, ']')))
9311                 devdir = strrchr(string, '>');
9312             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9313             }
9314         /*
9315          * Be consistent with what the C RTL has already done to the rest of
9316          * the argv items and lowercase all of these names.
9317          */
9318         if (!decc_efs_case_preserve) {
9319             for (c = string; *c; ++c)
9320             if (isupper(*c))
9321                 *c = tolower(*c);
9322         }
9323         if (isunix) trim_unixpath(string,item,1);
9324         add_item(head, tail, string, count);
9325         ++expcount;
9326     }
9327     PerlMem_free(vmsspec);
9328     if (sts != RMS$_NMF)
9329         {
9330         set_vaxc_errno(sts);
9331         switch (sts)
9332             {
9333             case RMS$_FNF: case RMS$_DNF:
9334                 set_errno(ENOENT); break;
9335             case RMS$_DIR:
9336                 set_errno(ENOTDIR); break;
9337             case RMS$_DEV:
9338                 set_errno(ENODEV); break;
9339             case RMS$_FNM: case RMS$_SYN:
9340                 set_errno(EINVAL); break;
9341             case RMS$_PRV:
9342                 set_errno(EACCES); break;
9343             default:
9344                 _ckvmssts_noperl(sts);
9345             }
9346         }
9347     if (expcount == 0)
9348         add_item(head, tail, item, count);
9349     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9350     _ckvmssts_noperl(lib$find_file_end(&context));
9351 }
9352
9353 static int child_st[2];/* Event Flag set when child process completes   */
9354
9355 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9356
9357 static unsigned long int exit_handler(void)
9358 {
9359 short iosb[4];
9360
9361     if (0 == child_st[0])
9362         {
9363 #ifdef ARGPROC_DEBUG
9364         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9365 #endif
9366         fflush(stdout);     /* Have to flush pipe for binary data to    */
9367                             /* terminate properly -- <tp@mccall.com>    */
9368         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9369         sys$dassgn(child_chan);
9370         fclose(stdout);
9371         sys$synch(0, child_st);
9372         }
9373     return(1);
9374 }
9375
9376 static void sig_child(int chan)
9377 {
9378 #ifdef ARGPROC_DEBUG
9379     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9380 #endif
9381     if (child_st[0] == 0)
9382         child_st[0] = 1;
9383 }
9384
9385 static struct exit_control_block exit_block =
9386     {
9387     0,
9388     exit_handler,
9389     1,
9390     &exit_block.exit_status,
9391     0
9392     };
9393
9394 static void
9395 pipe_and_fork(pTHX_ char **cmargv)
9396 {
9397     PerlIO *fp;
9398     struct dsc$descriptor_s *vmscmd;
9399     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9400     int sts, j, l, ismcr, quote, tquote = 0;
9401
9402     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9403     vms_execfree(vmscmd);
9404
9405     j = l = 0;
9406     p = subcmd;
9407     q = cmargv[0];
9408     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9409               && toupper(*(q+2)) == 'R' && !*(q+3);
9410
9411     while (q && l < MAX_DCL_LINE_LENGTH) {
9412         if (!*q) {
9413             if (j > 0 && quote) {
9414                 *p++ = '"';
9415                 l++;
9416             }
9417             q = cmargv[++j];
9418             if (q) {
9419                 if (ismcr && j > 1) quote = 1;
9420                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9421                 *p++ = ' ';
9422                 l++;
9423                 if (quote || tquote) {
9424                     *p++ = '"';
9425                     l++;
9426                 }
9427             }
9428         } else {
9429             if ((quote||tquote) && *q == '"') {
9430                 *p++ = '"';
9431                 l++;
9432             }
9433             *p++ = *q++;
9434             l++;
9435         }
9436     }
9437     *p = '\0';
9438
9439     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9440     if (fp == NULL) {
9441         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9442     }
9443 }
9444
9445 static int background_process(pTHX_ int argc, char **argv)
9446 {
9447 char command[MAX_DCL_SYMBOL + 1] = "$";
9448 $DESCRIPTOR(value, "");
9449 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9450 static $DESCRIPTOR(null, "NLA0:");
9451 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9452 char pidstring[80];
9453 $DESCRIPTOR(pidstr, "");
9454 int pid;
9455 unsigned long int flags = 17, one = 1, retsts;
9456 int len;
9457
9458     len = my_strlcat(command, argv[0], sizeof(command));
9459     while (--argc && (len < MAX_DCL_SYMBOL))
9460         {
9461         my_strlcat(command, " \"", sizeof(command));
9462         my_strlcat(command, *(++argv), sizeof(command));
9463         len = my_strlcat(command, "\"", sizeof(command));
9464         }
9465     value.dsc$a_pointer = command;
9466     value.dsc$w_length = strlen(value.dsc$a_pointer);
9467     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9468     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9469     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9470         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9471     }
9472     else {
9473         _ckvmssts_noperl(retsts);
9474     }
9475 #ifdef ARGPROC_DEBUG
9476     PerlIO_printf(Perl_debug_log, "%s\n", command);
9477 #endif
9478     sprintf(pidstring, "%08X", pid);
9479     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9480     pidstr.dsc$a_pointer = pidstring;
9481     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9482     lib$set_symbol(&pidsymbol, &pidstr);
9483     return(SS$_NORMAL);
9484 }
9485 /*}}}*/
9486 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9487
9488
9489 /* OS-specific initialization at image activation (not thread startup) */
9490 /* Older VAXC header files lack these constants */
9491 #ifndef JPI$_RIGHTS_SIZE
9492 #  define JPI$_RIGHTS_SIZE 817
9493 #endif
9494 #ifndef KGB$M_SUBSYSTEM
9495 #  define KGB$M_SUBSYSTEM 0x8
9496 #endif
9497
9498 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9499
9500 /*{{{void vms_image_init(int *, char ***)*/
9501 void
9502 vms_image_init(int *argcp, char ***argvp)
9503 {
9504   int status;
9505   char eqv[LNM$C_NAMLENGTH+1] = "";
9506   unsigned int len, tabct = 8, tabidx = 0;
9507   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9508   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9509   unsigned short int dummy, rlen;
9510   struct dsc$descriptor_s **tabvec;
9511 #if defined(PERL_IMPLICIT_CONTEXT)
9512   pTHX = NULL;
9513 #endif
9514   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9515                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9516                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9517                                  {          0,                0,    0,      0} };
9518
9519 #ifdef KILL_BY_SIGPRC
9520     Perl_csighandler_init();
9521 #endif
9522
9523 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9524     /* This was moved from the pre-image init handler because on threaded */
9525     /* Perl it was always returning 0 for the default value. */
9526     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9527     if (status > 0) {
9528         int s;
9529         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9530         if (s > 0) {
9531             int initial;
9532             initial = decc$feature_get_value(s, 4);
9533             if (initial > 0) {
9534                 /* initial is: 0 if nothing has set the feature */
9535                 /*            -1 if initialized to default */
9536                 /*             1 if set by logical name */
9537                 /*             2 if set by decc$feature_set_value */
9538                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9539
9540                 /* If the value is not valid, force the feature off */
9541                 if (decc_disable_posix_root < 0) {
9542                     decc$feature_set_value(s, 1, 1);
9543                     decc_disable_posix_root = 1;
9544                 }
9545             }
9546             else {
9547                 /* Nothing has asked for it explicitly, so use our own default. */
9548                 decc_disable_posix_root = 1;
9549                 decc$feature_set_value(s, 1, 1);
9550             }
9551         }
9552     }
9553 #endif
9554
9555   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9556   _ckvmssts_noperl(iosb[0]);
9557   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9558     if (iprv[i]) {           /* Running image installed with privs? */
9559       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9560       will_taint = TRUE;
9561       break;
9562     }
9563   }
9564   /* Rights identifiers might trigger tainting as well. */
9565   if (!will_taint && (rlen || rsz)) {
9566     while (rlen < rsz) {
9567       /* We didn't get all the identifiers on the first pass.  Allocate a
9568        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9569        * were needed to hold all identifiers at time of last call; we'll
9570        * allocate that many unsigned long ints), and go back and get 'em.
9571        * If it gave us less than it wanted to despite ample buffer space,
9572        * something's broken.  Is your system missing a system identifier?
9573        */
9574       if (rsz <= jpilist[1].buflen) {
9575          /* Perl_croak accvios when used this early in startup. */
9576          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9577                          rsz, (unsigned long) jpilist[1].buflen,
9578                          "Check your rights database for corruption.\n");
9579          exit(SS$_ABORT);
9580       }
9581       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9582       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9583       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9584       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9585       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9586       _ckvmssts_noperl(iosb[0]);
9587     }
9588     mask = (unsigned long int *)jpilist[1].bufadr;
9589     /* Check attribute flags for each identifier (2nd longword); protected
9590      * subsystem identifiers trigger tainting.
9591      */
9592     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9593       if (mask[i] & KGB$M_SUBSYSTEM) {
9594         will_taint = TRUE;
9595         break;
9596       }
9597     }
9598     if (mask != rlst) PerlMem_free(mask);
9599   }
9600
9601   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9602    * logical, some versions of the CRTL will add a phanthom /000000/
9603    * directory.  This needs to be removed.
9604    */
9605   if (decc_filename_unix_report) {
9606   char * zeros;
9607   int ulen;
9608     ulen = strlen(argvp[0][0]);
9609     if (ulen > 7) {
9610       zeros = strstr(argvp[0][0], "/000000/");
9611       if (zeros != NULL) {
9612         int mlen;
9613         mlen = ulen - (zeros - argvp[0][0]) - 7;
9614         memmove(zeros, &zeros[7], mlen);
9615         ulen = ulen - 7;
9616         argvp[0][0][ulen] = '\0';
9617       }
9618     }
9619     /* It also may have a trailing dot that needs to be removed otherwise
9620      * it will be converted to VMS mode incorrectly.
9621      */
9622     ulen--;
9623     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9624       argvp[0][0][ulen] = '\0';
9625   }
9626
9627   /* We need to use this hack to tell Perl it should run with tainting,
9628    * since its tainting flag may be part of the PL_curinterp struct, which
9629    * hasn't been allocated when vms_image_init() is called.
9630    */
9631   if (will_taint) {
9632     char **newargv, **oldargv;
9633     oldargv = *argvp;
9634     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9635     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9636     newargv[0] = oldargv[0];
9637     newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9638     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9639     strcpy(newargv[1], "-T");
9640     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9641     (*argcp)++;
9642     newargv[*argcp] = NULL;
9643     /* We orphan the old argv, since we don't know where it's come from,
9644      * so we don't know how to free it.
9645      */
9646     *argvp = newargv;
9647   }
9648   else {  /* Did user explicitly request tainting? */
9649     int i;
9650     char *cp, **av = *argvp;
9651     for (i = 1; i < *argcp; i++) {
9652       if (*av[i] != '-') break;
9653       for (cp = av[i]+1; *cp; cp++) {
9654         if (*cp == 'T') { will_taint = 1; break; }
9655         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9656                   strchr("DFIiMmx",*cp)) break;
9657       }
9658       if (will_taint) break;
9659     }
9660   }
9661
9662   for (tabidx = 0;
9663        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9664        tabidx++) {
9665     if (!tabidx) {
9666       tabvec = (struct dsc$descriptor_s **)
9667             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9668       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9669     }
9670     else if (tabidx >= tabct) {
9671       tabct += 8;
9672       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9673       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9674     }
9675     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9676     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9677     tabvec[tabidx]->dsc$w_length  = len;
9678     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9679     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_S;
9680     tabvec[tabidx]->dsc$a_pointer = (char *)PerlMem_malloc(len + 1);
9681     if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9682     my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
9683   }
9684   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9685
9686   getredirection(argcp,argvp);
9687 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9688   {
9689 # include <reentrancy.h>
9690   decc$set_reentrancy(C$C_MULTITHREAD);
9691   }
9692 #endif
9693   return;
9694 }
9695 /*}}}*/
9696
9697
9698 /* trim_unixpath()
9699  * Trim Unix-style prefix off filespec, so it looks like what a shell
9700  * glob expansion would return (i.e. from specified prefix on, not
9701  * full path).  Note that returned filespec is Unix-style, regardless
9702  * of whether input filespec was VMS-style or Unix-style.
9703  *
9704  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9705  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9706  * vector of options; at present, only bit 0 is used, and if set tells
9707  * trim unixpath to try the current default directory as a prefix when
9708  * presented with a possibly ambiguous ... wildcard.
9709  *
9710  * Returns !=0 on success, with trimmed filespec replacing contents of
9711  * fspec, and 0 on failure, with contents of fpsec unchanged.
9712  */
9713 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9714 int
9715 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9716 {
9717   char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9718   int tmplen, reslen = 0, dirs = 0;
9719
9720   if (!wildspec || !fspec) return 0;
9721
9722   unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9723   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9724   tplate = unixwild;
9725   if (strpbrk(wildspec,"]>:") != NULL) {
9726     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9727         PerlMem_free(unixwild);
9728         return 0;
9729     }
9730   }
9731   else {
9732     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9733   }
9734   unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9735   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9736   if (strpbrk(fspec,"]>:") != NULL) {
9737     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9738         PerlMem_free(unixwild);
9739         PerlMem_free(unixified);
9740         return 0;
9741     }
9742     else base = unixified;
9743     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9744      * check to see that final result fits into (isn't longer than) fspec */
9745     reslen = strlen(fspec);
9746   }
9747   else base = fspec;
9748
9749   /* No prefix or absolute path on wildcard, so nothing to remove */
9750   if (!*tplate || *tplate == '/') {
9751     PerlMem_free(unixwild);
9752     if (base == fspec) {
9753         PerlMem_free(unixified);
9754         return 1;
9755     }
9756     tmplen = strlen(unixified);
9757     if (tmplen > reslen) {
9758         PerlMem_free(unixified);
9759         return 0;  /* not enough space */
9760     }
9761     /* Copy unixified resultant, including trailing NUL */
9762     memmove(fspec,unixified,tmplen+1);
9763     PerlMem_free(unixified);
9764     return 1;
9765   }
9766
9767   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9768   if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9769     for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9770     for (cp1 = end ;cp1 >= base; cp1--)
9771       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9772         { cp1++; break; }
9773     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9774     PerlMem_free(unixified);
9775     PerlMem_free(unixwild);
9776     return 1;
9777   }
9778   else {
9779     char *tpl, *lcres;
9780     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9781     int ells = 1, totells, segdirs, match;
9782     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9783                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9784
9785     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9786     totells = ells;
9787     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9788     tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9789     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9790     if (ellipsis == tplate && opts & 1) {
9791       /* Template begins with an ellipsis.  Since we can't tell how many
9792        * directory names at the front of the resultant to keep for an
9793        * arbitrary starting point, we arbitrarily choose the current
9794        * default directory as a starting point.  If it's there as a prefix,
9795        * clip it off.  If not, fall through and act as if the leading
9796        * ellipsis weren't there (i.e. return shortest possible path that
9797        * could match template).
9798        */
9799       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9800           PerlMem_free(tpl);
9801           PerlMem_free(unixified);
9802           PerlMem_free(unixwild);
9803           return 0;
9804       }
9805       if (!decc_efs_case_preserve) {
9806         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9807           if (_tolower(*cp1) != _tolower(*cp2)) break;
9808       }
9809       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9810       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9811       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9812         memmove(fspec,cp2+1,end - cp2);
9813         PerlMem_free(tpl);
9814         PerlMem_free(unixified);
9815         PerlMem_free(unixwild);
9816         return 1;
9817       }
9818     }
9819     /* First off, back up over constant elements at end of path */
9820     if (dirs) {
9821       for (front = end ; front >= base; front--)
9822          if (*front == '/' && !dirs--) { front++; break; }
9823     }
9824     lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9825     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9826     for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9827          cp1++,cp2++) {
9828             if (!decc_efs_case_preserve) {
9829                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9830             }
9831             else {
9832                 *cp2 = *cp1;
9833             }
9834     }
9835     if (cp1 != '\0') {
9836         PerlMem_free(tpl);
9837         PerlMem_free(unixified);
9838         PerlMem_free(unixwild);
9839         PerlMem_free(lcres);
9840         return 0;  /* Path too long. */
9841     }
9842     lcend = cp2;
9843     *cp2 = '\0';  /* Pick up with memcpy later */
9844     lcfront = lcres + (front - base);
9845     /* Now skip over each ellipsis and try to match the path in front of it. */
9846     while (ells--) {
9847       for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9848         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9849             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9850       if (cp1 < tplate) break; /* template started with an ellipsis */
9851       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9852         ellipsis = cp1; continue;
9853       }
9854       wilddsc.dsc$a_pointer = tpl;
9855       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9856       nextell = cp1;
9857       for (segdirs = 0, cp2 = tpl;
9858            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9859            cp1++, cp2++) {
9860          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9861          else {
9862             if (!decc_efs_case_preserve) {
9863               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9864             }
9865             else {
9866               *cp2 = *cp1;  /* else preserve case for match */
9867             }
9868          }
9869          if (*cp2 == '/') segdirs++;
9870       }
9871       if (cp1 != ellipsis - 1) {
9872           PerlMem_free(tpl);
9873           PerlMem_free(unixified);
9874           PerlMem_free(unixwild);
9875           PerlMem_free(lcres);
9876           return 0; /* Path too long */
9877       }
9878       /* Back up at least as many dirs as in template before matching */
9879       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9880         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9881       for (match = 0; cp1 > lcres;) {
9882         resdsc.dsc$a_pointer = cp1;
9883         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9884           match++;
9885           if (match == 1) lcfront = cp1;
9886         }
9887         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9888       }
9889       if (!match) {
9890         PerlMem_free(tpl);
9891         PerlMem_free(unixified);
9892         PerlMem_free(unixwild);
9893         PerlMem_free(lcres);
9894         return 0;  /* Can't find prefix ??? */
9895       }
9896       if (match > 1 && opts & 1) {
9897         /* This ... wildcard could cover more than one set of dirs (i.e.
9898          * a set of similar dir names is repeated).  If the template
9899          * contains more than 1 ..., upstream elements could resolve the
9900          * ambiguity, but it's not worth a full backtracking setup here.
9901          * As a quick heuristic, clip off the current default directory
9902          * if it's present to find the trimmed spec, else use the
9903          * shortest string that this ... could cover.
9904          */
9905         char def[NAM$C_MAXRSS+1], *st;
9906
9907         if (getcwd(def, sizeof def,0) == NULL) {
9908             PerlMem_free(unixified);
9909             PerlMem_free(unixwild);
9910             PerlMem_free(lcres);
9911             PerlMem_free(tpl);
9912             return 0;
9913         }
9914         if (!decc_efs_case_preserve) {
9915           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9916             if (_tolower(*cp1) != _tolower(*cp2)) break;
9917         }
9918         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9919         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9920         if (*cp1 == '\0' && *cp2 == '/') {
9921           memmove(fspec,cp2+1,end - cp2);
9922           PerlMem_free(tpl);
9923           PerlMem_free(unixified);
9924           PerlMem_free(unixwild);
9925           PerlMem_free(lcres);
9926           return 1;
9927         }
9928         /* Nope -- stick with lcfront from above and keep going. */
9929       }
9930     }
9931     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9932     PerlMem_free(tpl);
9933     PerlMem_free(unixified);
9934     PerlMem_free(unixwild);
9935     PerlMem_free(lcres);
9936     return 1;
9937   }
9938
9939 }  /* end of trim_unixpath() */
9940 /*}}}*/
9941
9942
9943 /*
9944  *  VMS readdir() routines.
9945  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9946  *
9947  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9948  *  Minor modifications to original routines.
9949  */
9950
9951 /* readdir may have been redefined by reentr.h, so make sure we get
9952  * the local version for what we do here.
9953  */
9954 #ifdef readdir
9955 # undef readdir
9956 #endif
9957 #if !defined(PERL_IMPLICIT_CONTEXT)
9958 # define readdir Perl_readdir
9959 #else
9960 # define readdir(a) Perl_readdir(aTHX_ a)
9961 #endif
9962
9963     /* Number of elements in vms_versions array */
9964 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9965
9966 /*
9967  *  Open a directory, return a handle for later use.
9968  */
9969 /*{{{ DIR *opendir(char*name) */
9970 DIR *
9971 Perl_opendir(pTHX_ const char *name)
9972 {
9973     DIR *dd;
9974     char *dir;
9975     Stat_t sb;
9976
9977     Newx(dir, VMS_MAXRSS, char);
9978     if (int_tovmspath(name, dir, NULL) == NULL) {
9979       Safefree(dir);
9980       return NULL;
9981     }
9982     /* Check access before stat; otherwise stat does not
9983      * accurately report whether it's a directory.
9984      */
9985     if (!strstr(dir, "::") /* sys$check_access doesn't do remotes */
9986         && !cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9987       /* cando_by_name has already set errno */
9988       Safefree(dir);
9989       return NULL;
9990     }
9991     if (flex_stat(dir,&sb) == -1) return NULL;
9992     if (!S_ISDIR(sb.st_mode)) {
9993       Safefree(dir);
9994       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9995       return NULL;
9996     }
9997     /* Get memory for the handle, and the pattern. */
9998     Newx(dd,1,DIR);
9999     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10000
10001     /* Fill in the fields; mainly playing with the descriptor. */
10002     sprintf(dd->pattern, "%s*.*",dir);
10003     Safefree(dir);
10004     dd->context = 0;
10005     dd->count = 0;
10006     dd->flags = 0;
10007     /* By saying we want the result of readdir() in unix format, we are really
10008      * saying we want all the escapes removed, translating characters that
10009      * must be escaped in a VMS-format name to their unescaped form, which is
10010      * presumably allowed in a Unix-format name.
10011      */
10012     dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
10013     dd->pat.dsc$a_pointer = dd->pattern;
10014     dd->pat.dsc$w_length = strlen(dd->pattern);
10015     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10016     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10017 #if defined(USE_ITHREADS)
10018     Newx(dd->mutex,1,perl_mutex);
10019     MUTEX_INIT( (perl_mutex *) dd->mutex );
10020 #else
10021     dd->mutex = NULL;
10022 #endif
10023
10024     return dd;
10025 }  /* end of opendir() */
10026 /*}}}*/
10027
10028 /*
10029  *  Set the flag to indicate we want versions or not.
10030  */
10031 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10032 void
10033 vmsreaddirversions(DIR *dd, int flag)
10034 {
10035     if (flag)
10036         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10037     else
10038         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10039 }
10040 /*}}}*/
10041
10042 /*
10043  *  Free up an opened directory.
10044  */
10045 /*{{{ void closedir(DIR *dd)*/
10046 void
10047 Perl_closedir(DIR *dd)
10048 {
10049     int sts;
10050
10051     sts = lib$find_file_end(&dd->context);
10052     Safefree(dd->pattern);
10053 #if defined(USE_ITHREADS)
10054     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10055     Safefree(dd->mutex);
10056 #endif
10057     Safefree(dd);
10058 }
10059 /*}}}*/
10060
10061 /*
10062  *  Collect all the version numbers for the current file.
10063  */
10064 static void
10065 collectversions(pTHX_ DIR *dd)
10066 {
10067     struct dsc$descriptor_s     pat;
10068     struct dsc$descriptor_s     res;
10069     struct dirent *e;
10070     char *p, *text, *buff;
10071     int i;
10072     unsigned long context, tmpsts;
10073
10074     /* Convenient shorthand. */
10075     e = &dd->entry;
10076
10077     /* Add the version wildcard, ignoring the "*.*" put on before */
10078     i = strlen(dd->pattern);
10079     Newx(text,i + e->d_namlen + 3,char);
10080     my_strlcpy(text, dd->pattern, i + 1);
10081     sprintf(&text[i - 3], "%s;*", e->d_name);
10082
10083     /* Set up the pattern descriptor. */
10084     pat.dsc$a_pointer = text;
10085     pat.dsc$w_length = i + e->d_namlen - 1;
10086     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10087     pat.dsc$b_class = DSC$K_CLASS_S;
10088
10089     /* Set up result descriptor. */
10090     Newx(buff, VMS_MAXRSS, char);
10091     res.dsc$a_pointer = buff;
10092     res.dsc$w_length = VMS_MAXRSS - 1;
10093     res.dsc$b_dtype = DSC$K_DTYPE_T;
10094     res.dsc$b_class = DSC$K_CLASS_S;
10095
10096     /* Read files, collecting versions. */
10097     for (context = 0, e->vms_verscount = 0;
10098          e->vms_verscount < VERSIZE(e);
10099          e->vms_verscount++) {
10100         unsigned long rsts;
10101         unsigned long flags = 0;
10102
10103 #ifdef VMS_LONGNAME_SUPPORT
10104         flags = LIB$M_FIL_LONG_NAMES;
10105 #endif
10106         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10107         if (tmpsts == RMS$_NMF || context == 0) break;
10108         _ckvmssts(tmpsts);
10109         buff[VMS_MAXRSS - 1] = '\0';
10110         if ((p = strchr(buff, ';')))
10111             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10112         else
10113             e->vms_versions[e->vms_verscount] = -1;
10114     }
10115
10116     _ckvmssts(lib$find_file_end(&context));
10117     Safefree(text);
10118     Safefree(buff);
10119
10120 }  /* end of collectversions() */
10121
10122 /*
10123  *  Read the next entry from the directory.
10124  */
10125 /*{{{ struct dirent *readdir(DIR *dd)*/
10126 struct dirent *
10127 Perl_readdir(pTHX_ DIR *dd)
10128 {
10129     struct dsc$descriptor_s     res;
10130     char *p, *buff;
10131     unsigned long int tmpsts;
10132     unsigned long rsts;
10133     unsigned long flags = 0;
10134     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10135     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10136
10137     /* Set up result descriptor, and get next file. */
10138     Newx(buff, VMS_MAXRSS, char);
10139     res.dsc$a_pointer = buff;
10140     res.dsc$w_length = VMS_MAXRSS - 1;
10141     res.dsc$b_dtype = DSC$K_DTYPE_T;
10142     res.dsc$b_class = DSC$K_CLASS_S;
10143
10144 #ifdef VMS_LONGNAME_SUPPORT
10145     flags = LIB$M_FIL_LONG_NAMES;
10146 #endif
10147
10148     tmpsts = lib$find_file
10149         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10150     if (dd->context == 0)
10151         tmpsts = RMS$_NMF;  /* None left. (should be set, but make sure) */
10152
10153     if (!(tmpsts & 1)) {
10154       switch (tmpsts) {
10155         case RMS$_NMF:
10156           break;  /* no more files considered success */
10157         case RMS$_PRV:
10158           SETERRNO(EACCES, tmpsts); break;
10159         case RMS$_DEV:
10160           SETERRNO(ENODEV, tmpsts); break;
10161         case RMS$_DIR:
10162           SETERRNO(ENOTDIR, tmpsts); break;
10163         case RMS$_FNF: case RMS$_DNF:
10164           SETERRNO(ENOENT, tmpsts); break;
10165         default:
10166           SETERRNO(EVMSERR, tmpsts);
10167       }
10168       Safefree(buff);
10169       return NULL;
10170     }
10171     dd->count++;
10172     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10173     buff[res.dsc$w_length] = '\0';
10174     p = buff + res.dsc$w_length;
10175     while (--p >= buff) if (!isspace(*p)) break;
10176     *p = '\0';
10177     if (!decc_efs_case_preserve) {
10178       for (p = buff; *p; p++) *p = _tolower(*p);
10179     }
10180
10181     /* Skip any directory component and just copy the name. */
10182     sts = vms_split_path
10183        (buff,
10184         &v_spec,
10185         &v_len,
10186         &r_spec,
10187         &r_len,
10188         &d_spec,
10189         &d_len,
10190         &n_spec,
10191         &n_len,
10192         &e_spec,
10193         &e_len,
10194         &vs_spec,
10195         &vs_len);
10196
10197     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10198
10199         /* In Unix report mode, remove the ".dir;1" from the name */
10200         /* if it is a real directory. */
10201         if (decc_filename_unix_report && decc_efs_charset) {
10202             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10203                 Stat_t statbuf;
10204                 int ret_sts;
10205
10206                 ret_sts = flex_lstat(buff, &statbuf);
10207                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10208                     e_len = 0;
10209                     e_spec[0] = 0;
10210                 }
10211             }
10212         }
10213
10214         /* Drop NULL extensions on UNIX file specification */
10215         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10216             e_len = 0;
10217             e_spec[0] = '\0';
10218         }
10219     }
10220
10221     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10222     dd->entry.d_name[n_len + e_len] = '\0';
10223     dd->entry.d_namlen = n_len + e_len;
10224
10225     /* Convert the filename to UNIX format if needed */
10226     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10227
10228         /* Translate the encoded characters. */
10229         /* Fixme: Unicode handling could result in embedded 0 characters */
10230         if (strchr(dd->entry.d_name, '^') != NULL) {
10231             char new_name[256];
10232             char * q;
10233             p = dd->entry.d_name;
10234             q = new_name;
10235             while (*p != 0) {
10236                 int inchars_read, outchars_added;
10237                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10238                 p += inchars_read;
10239                 q += outchars_added;
10240                 /* fix-me */
10241                 /* if outchars_added > 1, then this is a wide file specification */
10242                 /* Wide file specifications need to be passed in Perl */
10243                 /* counted strings apparently with a Unicode flag */
10244             }
10245             *q = 0;
10246             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10247         }
10248     }
10249
10250     dd->entry.vms_verscount = 0;
10251     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10252     Safefree(buff);
10253     return &dd->entry;
10254
10255 }  /* end of readdir() */
10256 /*}}}*/
10257
10258 /*
10259  *  Read the next entry from the directory -- thread-safe version.
10260  */
10261 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10262 int
10263 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10264 {
10265     int retval;
10266
10267     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10268
10269     entry = readdir(dd);
10270     *result = entry;
10271     retval = ( *result == NULL ? errno : 0 );
10272
10273     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10274
10275     return retval;
10276
10277 }  /* end of readdir_r() */
10278 /*}}}*/
10279
10280 /*
10281  *  Return something that can be used in a seekdir later.
10282  */
10283 /*{{{ long telldir(DIR *dd)*/
10284 long
10285 Perl_telldir(DIR *dd)
10286 {
10287     return dd->count;
10288 }
10289 /*}}}*/
10290
10291 /*
10292  *  Return to a spot where we used to be.  Brute force.
10293  */
10294 /*{{{ void seekdir(DIR *dd,long count)*/
10295 void
10296 Perl_seekdir(pTHX_ DIR *dd, long count)
10297 {
10298     int old_flags;
10299
10300     /* If we haven't done anything yet... */
10301     if (dd->count == 0)
10302         return;
10303
10304     /* Remember some state, and clear it. */
10305     old_flags = dd->flags;
10306     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10307     _ckvmssts(lib$find_file_end(&dd->context));
10308     dd->context = 0;
10309
10310     /* The increment is in readdir(). */
10311     for (dd->count = 0; dd->count < count; )
10312         readdir(dd);
10313
10314     dd->flags = old_flags;
10315
10316 }  /* end of seekdir() */
10317 /*}}}*/
10318
10319 /* VMS subprocess management
10320  *
10321  * my_vfork() - just a vfork(), after setting a flag to record that
10322  * the current script is trying a Unix-style fork/exec.
10323  *
10324  * vms_do_aexec() and vms_do_exec() are called in response to the
10325  * perl 'exec' function.  If this follows a vfork call, then they
10326  * call out the regular perl routines in doio.c which do an
10327  * execvp (for those who really want to try this under VMS).
10328  * Otherwise, they do exactly what the perl docs say exec should
10329  * do - terminate the current script and invoke a new command
10330  * (See below for notes on command syntax.)
10331  *
10332  * do_aspawn() and do_spawn() implement the VMS side of the perl
10333  * 'system' function.
10334  *
10335  * Note on command arguments to perl 'exec' and 'system': When handled
10336  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10337  * are concatenated to form a DCL command string.  If the first non-numeric
10338  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10339  * the command string is handed off to DCL directly.  Otherwise,
10340  * the first token of the command is taken as the filespec of an image
10341  * to run.  The filespec is expanded using a default type of '.EXE' and
10342  * the process defaults for device, directory, etc., and if found, the resultant
10343  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10344  * the command string as parameters.  This is perhaps a bit complicated,
10345  * but I hope it will form a happy medium between what VMS folks expect
10346  * from lib$spawn and what Unix folks expect from exec.
10347  */
10348
10349 static int vfork_called;
10350
10351 /*{{{int my_vfork(void)*/
10352 int
10353 my_vfork(void)
10354 {
10355   vfork_called++;
10356   return vfork();
10357 }
10358 /*}}}*/
10359
10360
10361 static void
10362 vms_execfree(struct dsc$descriptor_s *vmscmd)
10363 {
10364   if (vmscmd) {
10365       if (vmscmd->dsc$a_pointer) {
10366           PerlMem_free(vmscmd->dsc$a_pointer);
10367       }
10368       PerlMem_free(vmscmd);
10369   }
10370 }
10371
10372 static char *
10373 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10374 {
10375   char *junk, *tmps = NULL;
10376   size_t cmdlen = 0;
10377   size_t rlen;
10378   SV **idx;
10379   STRLEN n_a;
10380
10381   idx = mark;
10382   if (really) {
10383     tmps = SvPV(really,rlen);
10384     if (*tmps) {
10385       cmdlen += rlen + 1;
10386       idx++;
10387     }
10388   }
10389
10390   for (idx++; idx <= sp; idx++) {
10391     if (*idx) {
10392       junk = SvPVx(*idx,rlen);
10393       cmdlen += rlen ? rlen + 1 : 0;
10394     }
10395   }
10396   Newx(PL_Cmd, cmdlen+1, char);
10397
10398   if (tmps && *tmps) {
10399     my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10400     mark++;
10401   }
10402   else *PL_Cmd = '\0';
10403   while (++mark <= sp) {
10404     if (*mark) {
10405       char *s = SvPVx(*mark,n_a);
10406       if (!*s) continue;
10407       if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10408       my_strlcat(PL_Cmd, s, cmdlen+1);
10409     }
10410   }
10411   return PL_Cmd;
10412
10413 }  /* end of setup_argstr() */
10414
10415
10416 static unsigned long int
10417 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10418                    struct dsc$descriptor_s **pvmscmd)
10419 {
10420   char * vmsspec;
10421   char * resspec;
10422   char image_name[NAM$C_MAXRSS+1];
10423   char image_argv[NAM$C_MAXRSS+1];
10424   $DESCRIPTOR(defdsc,".EXE");
10425   $DESCRIPTOR(defdsc2,".");
10426   struct dsc$descriptor_s resdsc;
10427   struct dsc$descriptor_s *vmscmd;
10428   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10429   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10430   char *s, *rest, *cp, *wordbreak;
10431   char * cmd;
10432   int cmdlen;
10433   int isdcl;
10434
10435   vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10436   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10437
10438   /* vmsspec is a DCL command buffer, not just a filename */
10439   vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10440   if (vmsspec == NULL)
10441       _ckvmssts_noperl(SS$_INSFMEM);
10442
10443   resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10444   if (resspec == NULL)
10445       _ckvmssts_noperl(SS$_INSFMEM);
10446
10447   /* Make a copy for modification */
10448   cmdlen = strlen(incmd);
10449   cmd = (char *)PerlMem_malloc(cmdlen+1);
10450   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10451   my_strlcpy(cmd, incmd, cmdlen + 1);
10452   image_name[0] = 0;
10453   image_argv[0] = 0;
10454
10455   resdsc.dsc$a_pointer = resspec;
10456   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10457   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10458   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10459
10460   vmscmd->dsc$a_pointer = NULL;
10461   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10462   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10463   vmscmd->dsc$w_length = 0;
10464   if (pvmscmd) *pvmscmd = vmscmd;
10465
10466   if (suggest_quote) *suggest_quote = 0;
10467
10468   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10469     PerlMem_free(cmd);
10470     PerlMem_free(vmsspec);
10471     PerlMem_free(resspec);
10472     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10473   }
10474
10475   s = cmd;
10476
10477   while (*s && isspace(*s)) s++;
10478
10479   if (*s == '@' || *s == '$') {
10480     vmsspec[0] = *s;  rest = s + 1;
10481     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10482   }
10483   else { cp = vmsspec; rest = s; }
10484
10485   /* If the first word is quoted, then we need to unquote it and
10486    * escape spaces within it.  We'll expand into the resspec buffer,
10487    * then copy back into the cmd buffer, expanding the latter if
10488    * necessary.
10489    */
10490   if (*rest == '"') {
10491     char *cp2;
10492     char *r = rest;
10493     bool in_quote = 0;
10494     int clen = cmdlen;
10495     int soff = s - cmd;
10496
10497     for (cp2 = resspec;
10498          *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10499          rest++) {
10500
10501       if (*rest == ' ') {    /* Escape ' ' to '^_'. */
10502         *cp2 = '^';
10503         *(++cp2) = '_';
10504         cp2++;
10505         clen++;
10506       }
10507       else if (*rest == '"') {
10508         clen--;
10509         if (in_quote) {     /* Must be closing quote. */
10510           rest++;
10511           break;
10512         }
10513         in_quote = 1;
10514       }
10515       else {
10516         *cp2 = *rest;
10517         cp2++;
10518       }
10519     }
10520     *cp2 = '\0';
10521
10522     /* Expand the command buffer if necessary. */
10523     if (clen > cmdlen) {
10524       cmd = (char *)PerlMem_realloc(cmd, clen);
10525       if (cmd == NULL)
10526         _ckvmssts_noperl(SS$_INSFMEM);
10527       /* Where we are may have changed, so recompute offsets */
10528       r = cmd + (r - s - soff);
10529       rest = cmd + (rest - s - soff);
10530       s = cmd + soff;
10531     }
10532
10533     /* Shift the non-verb portion of the command (if any) up or
10534      * down as necessary.
10535      */
10536     if (*rest)
10537       memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10538
10539     /* Copy the unquoted and escaped command verb into place. */
10540     memcpy(r, resspec, cp2 - resspec);
10541     cmd[clen] = '\0';
10542     cmdlen = clen;
10543     rest = r;         /* Rewind for subsequent operations. */
10544   }
10545
10546   if (*rest == '.' || *rest == '/') {
10547     char *cp2;
10548     for (cp2 = resspec;
10549          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10550          rest++, cp2++) *cp2 = *rest;
10551     *cp2 = '\0';
10552     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10553       s = vmsspec;
10554
10555       /* When a UNIX spec with no file type is translated to VMS, */
10556       /* A trailing '.' is appended under ODS-5 rules.            */
10557       /* Here we do not want that trailing "." as it prevents     */
10558       /* Looking for a implied ".exe" type. */
10559       if (decc_efs_charset) {
10560           int i;
10561           i = strlen(vmsspec);
10562           if (vmsspec[i-1] == '.') {
10563               vmsspec[i-1] = '\0';
10564           }
10565       }
10566
10567       if (*rest) {
10568         for (cp2 = vmsspec + strlen(vmsspec);
10569              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10570              rest++, cp2++) *cp2 = *rest;
10571         *cp2 = '\0';
10572       }
10573     }
10574   }
10575   /* Intuit whether verb (first word of cmd) is a DCL command:
10576    *   - if first nonspace char is '@', it's a DCL indirection
10577    * otherwise
10578    *   - if verb contains a filespec separator, it's not a DCL command
10579    *   - if it doesn't, caller tells us whether to default to a DCL
10580    *     command, or to a local image unless told it's DCL (by leading '$')
10581    */
10582   if (*s == '@') {
10583       isdcl = 1;
10584       if (suggest_quote) *suggest_quote = 1;
10585   } else {
10586     char *filespec = strpbrk(s,":<[.;");
10587     rest = wordbreak = strpbrk(s," \"\t/");
10588     if (!wordbreak) wordbreak = s + strlen(s);
10589     if (*s == '$') check_img = 0;
10590     if (filespec && (filespec < wordbreak)) isdcl = 0;
10591     else isdcl = !check_img;
10592   }
10593
10594   if (!isdcl) {
10595     int rsts;
10596     imgdsc.dsc$a_pointer = s;
10597     imgdsc.dsc$w_length = wordbreak - s;
10598     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10599     if (!(retsts&1)) {
10600         _ckvmssts_noperl(lib$find_file_end(&cxt));
10601         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10602       if (!(retsts & 1) && *s == '$') {
10603         _ckvmssts_noperl(lib$find_file_end(&cxt));
10604         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10605         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10606         if (!(retsts&1)) {
10607           _ckvmssts_noperl(lib$find_file_end(&cxt));
10608           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10609         }
10610       }
10611     }
10612     _ckvmssts_noperl(lib$find_file_end(&cxt));
10613
10614     if (retsts & 1) {
10615       FILE *fp;
10616       s = resspec;
10617       while (*s && !isspace(*s)) s++;
10618       *s = '\0';
10619
10620       /* check that it's really not DCL with no file extension */
10621       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10622       if (fp) {
10623         char b[256] = {0,0,0,0};
10624         read(fileno(fp), b, 256);
10625         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10626         if (isdcl) {
10627           int shebang_len;
10628
10629           /* Check for script */
10630           shebang_len = 0;
10631           if ((b[0] == '#') && (b[1] == '!'))
10632              shebang_len = 2;
10633 #ifdef ALTERNATE_SHEBANG
10634           else {
10635             shebang_len = strlen(ALTERNATE_SHEBANG);
10636             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10637               char * perlstr;
10638                 perlstr = strstr("perl",b);
10639                 if (perlstr == NULL)
10640                   shebang_len = 0;
10641             }
10642             else
10643               shebang_len = 0;
10644           }
10645 #endif
10646
10647           if (shebang_len > 0) {
10648           int i;
10649           int j;
10650           char tmpspec[NAM$C_MAXRSS + 1];
10651
10652             i = shebang_len;
10653              /* Image is following after white space */
10654             /*--------------------------------------*/
10655             while (isprint(b[i]) && isspace(b[i]))
10656                 i++;
10657
10658             j = 0;
10659             while (isprint(b[i]) && !isspace(b[i])) {
10660                 tmpspec[j++] = b[i++];
10661                 if (j >= NAM$C_MAXRSS)
10662                    break;
10663             }
10664             tmpspec[j] = '\0';
10665
10666              /* There may be some default parameters to the image */
10667             /*---------------------------------------------------*/
10668             j = 0;
10669             while (isprint(b[i])) {
10670                 image_argv[j++] = b[i++];
10671                 if (j >= NAM$C_MAXRSS)
10672                    break;
10673             }
10674             while ((j > 0) && !isprint(image_argv[j-1]))
10675                 j--;
10676             image_argv[j] = 0;
10677
10678             /* It will need to be converted to VMS format and validated */
10679             if (tmpspec[0] != '\0') {
10680               char * iname;
10681
10682                /* Try to find the exact program requested to be run */
10683               /*---------------------------------------------------*/
10684               iname = int_rmsexpand
10685                  (tmpspec, image_name, ".exe",
10686                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10687               if (iname != NULL) {
10688                 if (cando_by_name_int
10689                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10690                   /* MCR prefix needed */
10691                   isdcl = 0;
10692                 }
10693                 else {
10694                    /* Try again with a null type */
10695                   /*----------------------------*/
10696                   iname = int_rmsexpand
10697                     (tmpspec, image_name, ".",
10698                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10699                   if (iname != NULL) {
10700                     if (cando_by_name_int
10701                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10702                       /* MCR prefix needed */
10703                       isdcl = 0;
10704                     }
10705                   }
10706                 }
10707
10708                  /* Did we find the image to run the script? */
10709                 /*------------------------------------------*/
10710                 if (isdcl) {
10711                   char *tchr;
10712
10713                    /* Assume DCL or foreign command exists */
10714                   /*--------------------------------------*/
10715                   tchr = strrchr(tmpspec, '/');
10716                   if (tchr != NULL) {
10717                     tchr++;
10718                   }
10719                   else {
10720                     tchr = tmpspec;
10721                   }
10722                   my_strlcpy(image_name, tchr, sizeof(image_name));
10723                 }
10724               }
10725             }
10726           }
10727         }
10728         fclose(fp);
10729       }
10730       if (check_img && isdcl) {
10731           PerlMem_free(cmd);
10732           PerlMem_free(resspec);
10733           PerlMem_free(vmsspec);
10734           return RMS$_FNF;
10735       }
10736
10737       if (cando_by_name(S_IXUSR,0,resspec)) {
10738         vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10739         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10740         if (!isdcl) {
10741             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10742             if (image_name[0] != 0) {
10743                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10744                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10745             }
10746         } else if (image_name[0] != 0) {
10747             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10748             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10749         } else {
10750             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10751         }
10752         if (suggest_quote) *suggest_quote = 1;
10753
10754         /* If there is an image name, use original command */
10755         if (image_name[0] == 0)
10756             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10757         else {
10758             rest = cmd;
10759             while (*rest && isspace(*rest)) rest++;
10760         }
10761
10762         if (image_argv[0] != 0) {
10763           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10764           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10765         }
10766         if (rest) {
10767            int rest_len;
10768            int vmscmd_len;
10769
10770            rest_len = strlen(rest);
10771            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10772            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10773               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10774            else
10775              retsts = CLI$_BUFOVF;
10776         }
10777         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10778         PerlMem_free(cmd);
10779         PerlMem_free(vmsspec);
10780         PerlMem_free(resspec);
10781         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10782       }
10783       else
10784         retsts = RMS$_PRV;
10785     }
10786   }
10787   /* It's either a DCL command or we couldn't find a suitable image */
10788   vmscmd->dsc$w_length = strlen(cmd);
10789
10790   vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10791   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10792
10793   PerlMem_free(cmd);
10794   PerlMem_free(resspec);
10795   PerlMem_free(vmsspec);
10796
10797   /* check if it's a symbol (for quoting purposes) */
10798   if (suggest_quote && !*suggest_quote) {
10799     int iss;
10800     char equiv[LNM$C_NAMLENGTH];
10801     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10802     eqvdsc.dsc$a_pointer = equiv;
10803
10804     iss = lib$get_symbol(vmscmd,&eqvdsc);
10805     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10806   }
10807   if (!(retsts & 1)) {
10808     /* just hand off status values likely to be due to user error */
10809     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10810         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10811        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10812     else { _ckvmssts_noperl(retsts); }
10813   }
10814
10815   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10816
10817 }  /* end of setup_cmddsc() */
10818
10819
10820 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10821 bool
10822 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10823 {
10824 bool exec_sts;
10825 char * cmd;
10826
10827   if (sp > mark) {
10828     if (vfork_called) {           /* this follows a vfork - act Unixish */
10829       vfork_called--;
10830       if (vfork_called < 0) {
10831         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10832         vfork_called = 0;
10833       }
10834       else return do_aexec(really,mark,sp);
10835     }
10836                                            /* no vfork - act VMSish */
10837     cmd = setup_argstr(aTHX_ really,mark,sp);
10838     exec_sts = vms_do_exec(cmd);
10839     Safefree(cmd);  /* Clean up from setup_argstr() */
10840     return exec_sts;
10841   }
10842
10843   return FALSE;
10844 }  /* end of vms_do_aexec() */
10845 /*}}}*/
10846
10847 /* {{{bool vms_do_exec(char *cmd) */
10848 bool
10849 Perl_vms_do_exec(pTHX_ const char *cmd)
10850 {
10851   struct dsc$descriptor_s *vmscmd;
10852
10853   if (vfork_called) {             /* this follows a vfork - act Unixish */
10854     vfork_called--;
10855     if (vfork_called < 0) {
10856       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10857       vfork_called = 0;
10858     }
10859     else return do_exec(cmd);
10860   }
10861
10862   {                               /* no vfork - act VMSish */
10863     unsigned long int retsts;
10864
10865     TAINT_ENV();
10866     TAINT_PROPER("exec");
10867     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10868       retsts = lib$do_command(vmscmd);
10869
10870     switch (retsts) {
10871       case RMS$_FNF: case RMS$_DNF:
10872         set_errno(ENOENT); break;
10873       case RMS$_DIR:
10874         set_errno(ENOTDIR); break;
10875       case RMS$_DEV:
10876         set_errno(ENODEV); break;
10877       case RMS$_PRV:
10878         set_errno(EACCES); break;
10879       case RMS$_SYN:
10880         set_errno(EINVAL); break;
10881       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10882         set_errno(E2BIG); break;
10883       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10884         _ckvmssts_noperl(retsts); /* fall through */
10885       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10886         set_errno(EVMSERR);
10887     }
10888     set_vaxc_errno(retsts);
10889     if (ckWARN(WARN_EXEC)) {
10890       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10891              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10892     }
10893     vms_execfree(vmscmd);
10894   }
10895
10896   return FALSE;
10897
10898 }  /* end of vms_do_exec() */
10899 /*}}}*/
10900
10901 int do_spawn2(pTHX_ const char *, int);
10902
10903 int
10904 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10905 {
10906 unsigned long int sts;
10907 char * cmd;
10908 int flags = 0;
10909
10910   if (sp > mark) {
10911
10912     /* We'll copy the (undocumented?) Win32 behavior and allow a
10913      * numeric first argument.  But the only value we'll support
10914      * through do_aspawn is a value of 1, which means spawn without
10915      * waiting for completion -- other values are ignored.
10916      */
10917     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10918         ++mark;
10919         flags = SvIVx(*mark);
10920     }
10921
10922     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10923         flags = CLI$M_NOWAIT;
10924     else
10925         flags = 0;
10926
10927     cmd = setup_argstr(aTHX_ really, mark, sp);
10928     sts = do_spawn2(aTHX_ cmd, flags);
10929     /* pp_sys will clean up cmd */
10930     return sts;
10931   }
10932   return SS$_ABORT;
10933 }  /* end of do_aspawn() */
10934 /*}}}*/
10935
10936
10937 /* {{{int do_spawn(char* cmd) */
10938 int
10939 Perl_do_spawn(pTHX_ char* cmd)
10940 {
10941     PERL_ARGS_ASSERT_DO_SPAWN;
10942
10943     return do_spawn2(aTHX_ cmd, 0);
10944 }
10945 /*}}}*/
10946
10947 /* {{{int do_spawn_nowait(char* cmd) */
10948 int
10949 Perl_do_spawn_nowait(pTHX_ char* cmd)
10950 {
10951     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10952
10953     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10954 }
10955 /*}}}*/
10956
10957 /* {{{int do_spawn2(char *cmd) */
10958 int
10959 do_spawn2(pTHX_ const char *cmd, int flags)
10960 {
10961   unsigned long int sts, substs;
10962
10963   /* The caller of this routine expects to Safefree(PL_Cmd) */
10964   Newx(PL_Cmd,10,char);
10965
10966   TAINT_ENV();
10967   TAINT_PROPER("spawn");
10968   if (!cmd || !*cmd) {
10969     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10970     if (!(sts & 1)) {
10971       switch (sts) {
10972         case RMS$_FNF:  case RMS$_DNF:
10973           set_errno(ENOENT); break;
10974         case RMS$_DIR:
10975           set_errno(ENOTDIR); break;
10976         case RMS$_DEV:
10977           set_errno(ENODEV); break;
10978         case RMS$_PRV:
10979           set_errno(EACCES); break;
10980         case RMS$_SYN:
10981           set_errno(EINVAL); break;
10982         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10983           set_errno(E2BIG); break;
10984         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10985           _ckvmssts_noperl(sts); /* fall through */
10986         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10987           set_errno(EVMSERR);
10988       }
10989       set_vaxc_errno(sts);
10990       if (ckWARN(WARN_EXEC)) {
10991         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10992                     Strerror(errno));
10993       }
10994     }
10995     sts = substs;
10996   }
10997   else {
10998     char mode[3];
10999     PerlIO * fp;
11000     if (flags & CLI$M_NOWAIT)
11001         strcpy(mode, "n");
11002     else
11003         strcpy(mode, "nW");
11004
11005     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11006     if (fp != NULL)
11007       my_pclose(fp);
11008     /* sts will be the pid in the nowait case */
11009   }
11010   return sts;
11011 }  /* end of do_spawn2() */
11012 /*}}}*/
11013
11014
11015 static unsigned int *sockflags, sockflagsize;
11016
11017 /*
11018  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11019  * routines found in some versions of the CRTL can't deal with sockets.
11020  * We don't shim the other file open routines since a socket isn't
11021  * likely to be opened by a name.
11022  */
11023 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11024 FILE *my_fdopen(int fd, const char *mode)
11025 {
11026   FILE *fp = fdopen(fd, mode);
11027
11028   if (fp) {
11029     unsigned int fdoff = fd / sizeof(unsigned int);
11030     Stat_t sbuf; /* native stat; we don't need flex_stat */
11031     if (!sockflagsize || fdoff > sockflagsize) {
11032       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11033       else           Newx  (sockflags,fdoff+2,unsigned int);
11034       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11035       sockflagsize = fdoff + 2;
11036     }
11037     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11038       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11039   }
11040   return fp;
11041
11042 }
11043 /*}}}*/
11044
11045
11046 /*
11047  * Clear the corresponding bit when the (possibly) socket stream is closed.
11048  * There still a small hole: we miss an implicit close which might occur
11049  * via freopen().  >> Todo
11050  */
11051 /*{{{ int my_fclose(FILE *fp)*/
11052 int my_fclose(FILE *fp) {
11053   if (fp) {
11054     unsigned int fd = fileno(fp);
11055     unsigned int fdoff = fd / sizeof(unsigned int);
11056
11057     if (sockflagsize && fdoff < sockflagsize)
11058       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11059   }
11060   return fclose(fp);
11061 }
11062 /*}}}*/
11063
11064
11065 /*
11066  * A simple fwrite replacement which outputs itmsz*nitm chars without
11067  * introducing record boundaries every itmsz chars.
11068  * We are using fputs, which depends on a terminating null.  We may
11069  * well be writing binary data, so we need to accommodate not only
11070  * data with nulls sprinkled in the middle but also data with no null
11071  * byte at the end.
11072  */
11073 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11074 int
11075 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11076 {
11077   char *cp, *end, *cpd;
11078   char *data;
11079   unsigned int fd = fileno(dest);
11080   unsigned int fdoff = fd / sizeof(unsigned int);
11081   int retval;
11082   int bufsize = itmsz * nitm + 1;
11083
11084   if (fdoff < sockflagsize &&
11085       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11086     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11087     return nitm;
11088   }
11089
11090   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11091   memcpy( data, src, itmsz*nitm );
11092   data[itmsz*nitm] = '\0';
11093
11094   end = data + itmsz * nitm;
11095   retval = (int) nitm; /* on success return # items written */
11096
11097   cpd = data;
11098   while (cpd <= end) {
11099     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11100     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11101     if (cp < end)
11102       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11103     cpd = cp + 1;
11104   }
11105
11106   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11107   return retval;
11108
11109 }  /* end of my_fwrite() */
11110 /*}}}*/
11111
11112 /*{{{ int my_flush(FILE *fp)*/
11113 int
11114 Perl_my_flush(pTHX_ FILE *fp)
11115 {
11116     int res;
11117     if ((res = fflush(fp)) == 0 && fp) {
11118 #ifdef VMS_DO_SOCKETS
11119         Stat_t s;
11120         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11121 #endif
11122             res = fsync(fileno(fp));
11123     }
11124 /*
11125  * If the flush succeeded but set end-of-file, we need to clear
11126  * the error because our caller may check ferror().  BTW, this
11127  * probably means we just flushed an empty file.
11128  */
11129     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11130
11131     return res;
11132 }
11133 /*}}}*/
11134
11135 /* fgetname() is not returning the correct file specifications when
11136  * decc_filename_unix_report mode is active.  So we have to have it
11137  * aways return filenames in VMS mode and convert it ourselves.
11138  */
11139
11140 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11141 char *
11142 Perl_my_fgetname(FILE *fp, char * buf) {
11143     char * retname;
11144     char * vms_name;
11145
11146     retname = fgetname(fp, buf, 1);
11147
11148     /* If we are in VMS mode, then we are done */
11149     if (!decc_filename_unix_report || (retname == NULL)) {
11150        return retname;
11151     }
11152
11153     /* Convert this to Unix format */
11154     vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11155     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11156     retname = int_tounixspec(vms_name, buf, NULL);
11157     PerlMem_free(vms_name);
11158
11159     return retname;
11160 }
11161 /*}}}*/
11162
11163 /*
11164  * Here are replacements for the following Unix routines in the VMS environment:
11165  *      getpwuid    Get information for a particular UIC or UID
11166  *      getpwnam    Get information for a named user
11167  *      getpwent    Get information for each user in the rights database
11168  *      setpwent    Reset search to the start of the rights database
11169  *      endpwent    Finish searching for users in the rights database
11170  *
11171  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11172  * (defined in pwd.h), which contains the following fields:-
11173  *      struct passwd {
11174  *              char        *pw_name;    Username (in lower case)
11175  *              char        *pw_passwd;  Hashed password
11176  *              unsigned int pw_uid;     UIC
11177  *              unsigned int pw_gid;     UIC group  number
11178  *              char        *pw_unixdir; Default device/directory (VMS-style)
11179  *              char        *pw_gecos;   Owner name
11180  *              char        *pw_dir;     Default device/directory (Unix-style)
11181  *              char        *pw_shell;   Default CLI name (eg. DCL)
11182  *      };
11183  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11184  *
11185  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11186  * not the UIC member number (eg. what's returned by getuid()),
11187  * getpwuid() can accept either as input (if uid is specified, the caller's
11188  * UIC group is used), though it won't recognise gid=0.
11189  *
11190  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11191  * information about other users in your group or in other groups, respectively.
11192  * If the required privilege is not available, then these routines fill only
11193  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11194  * string).
11195  *
11196  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11197  */
11198
11199 /* sizes of various UAF record fields */
11200 #define UAI$S_USERNAME 12
11201 #define UAI$S_IDENT    31
11202 #define UAI$S_OWNER    31
11203 #define UAI$S_DEFDEV   31
11204 #define UAI$S_DEFDIR   63
11205 #define UAI$S_DEFCLI   31
11206 #define UAI$S_PWD       8
11207
11208 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11209                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11210                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11211
11212 static char __empty[]= "";
11213 static struct passwd __passwd_empty=
11214     {(char *) __empty, (char *) __empty, 0, 0,
11215      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11216 static int contxt= 0;
11217 static struct passwd __pwdcache;
11218 static char __pw_namecache[UAI$S_IDENT+1];
11219
11220 /*
11221  * This routine does most of the work extracting the user information.
11222  */
11223 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11224 {
11225     static struct {
11226         unsigned char length;
11227         char pw_gecos[UAI$S_OWNER+1];
11228     } owner;
11229     static union uicdef uic;
11230     static struct {
11231         unsigned char length;
11232         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11233     } defdev;
11234     static struct {
11235         unsigned char length;
11236         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11237     } defdir;
11238     static struct {
11239         unsigned char length;
11240         char pw_shell[UAI$S_DEFCLI+1];
11241     } defcli;
11242     static char pw_passwd[UAI$S_PWD+1];
11243
11244     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11245     struct dsc$descriptor_s name_desc;
11246     unsigned long int sts;
11247
11248     static struct itmlst_3 itmlst[]= {
11249         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11250         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11251         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11252         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11253         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11254         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11255         {0,                0,           NULL,    NULL}};
11256
11257     name_desc.dsc$w_length=  strlen(name);
11258     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11259     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11260     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11261
11262 /*  Note that sys$getuai returns many fields as counted strings. */
11263     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11264     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11265       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11266     }
11267     else { _ckvmssts(sts); }
11268     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11269
11270     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11271     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11272     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11273     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11274     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11275     owner.pw_gecos[lowner]=            '\0';
11276     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11277     defcli.pw_shell[ldefcli]=          '\0';
11278     if (valid_uic(uic)) {
11279         pwd->pw_uid= uic.uic$l_uic;
11280         pwd->pw_gid= uic.uic$v_group;
11281     }
11282     else
11283       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11284     pwd->pw_passwd=  pw_passwd;
11285     pwd->pw_gecos=   owner.pw_gecos;
11286     pwd->pw_dir=     defdev.pw_dir;
11287     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11288     pwd->pw_shell=   defcli.pw_shell;
11289     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11290         int ldir;
11291         ldir= strlen(pwd->pw_unixdir) - 1;
11292         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11293     }
11294     else
11295         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11296     if (!decc_efs_case_preserve)
11297         __mystrtolower(pwd->pw_unixdir);
11298     return 1;
11299 }
11300
11301 /*
11302  * Get information for a named user.
11303 */
11304 /*{{{struct passwd *getpwnam(char *name)*/
11305 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11306 {
11307     struct dsc$descriptor_s name_desc;
11308     union uicdef uic;
11309     unsigned long int sts;
11310
11311     __pwdcache = __passwd_empty;
11312     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11313       /* We still may be able to determine pw_uid and pw_gid */
11314       name_desc.dsc$w_length=  strlen(name);
11315       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11316       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11317       name_desc.dsc$a_pointer= (char *) name;
11318       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11319         __pwdcache.pw_uid= uic.uic$l_uic;
11320         __pwdcache.pw_gid= uic.uic$v_group;
11321       }
11322       else {
11323         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11324           set_vaxc_errno(sts);
11325           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11326           return NULL;
11327         }
11328         else { _ckvmssts(sts); }
11329       }
11330     }
11331     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11332     __pwdcache.pw_name= __pw_namecache;
11333     return &__pwdcache;
11334 }  /* end of my_getpwnam() */
11335 /*}}}*/
11336
11337 /*
11338  * Get information for a particular UIC or UID.
11339  * Called by my_getpwent with uid=-1 to list all users.
11340 */
11341 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11342 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11343 {
11344     const $DESCRIPTOR(name_desc,__pw_namecache);
11345     unsigned short lname;
11346     union uicdef uic;
11347     unsigned long int status;
11348
11349     if (uid == (unsigned int) -1) {
11350       do {
11351         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11352         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11353           set_vaxc_errno(status);
11354           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11355           my_endpwent();
11356           return NULL;
11357         }
11358         else { _ckvmssts(status); }
11359       } while (!valid_uic (uic));
11360     }
11361     else {
11362       uic.uic$l_uic= uid;
11363       if (!uic.uic$v_group)
11364         uic.uic$v_group= PerlProc_getgid();
11365       if (valid_uic(uic))
11366         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11367       else status = SS$_IVIDENT;
11368       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11369           status == RMS$_PRV) {
11370         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11371         return NULL;
11372       }
11373       else { _ckvmssts(status); }
11374     }
11375     __pw_namecache[lname]= '\0';
11376     __mystrtolower(__pw_namecache);
11377
11378     __pwdcache = __passwd_empty;
11379     __pwdcache.pw_name = __pw_namecache;
11380
11381 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11382     The identifier's value is usually the UIC, but it doesn't have to be,
11383     so if we can, we let fillpasswd update this. */
11384     __pwdcache.pw_uid =  uic.uic$l_uic;
11385     __pwdcache.pw_gid =  uic.uic$v_group;
11386
11387     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11388     return &__pwdcache;
11389
11390 }  /* end of my_getpwuid() */
11391 /*}}}*/
11392
11393 /*
11394  * Get information for next user.
11395 */
11396 /*{{{struct passwd *my_getpwent()*/
11397 struct passwd *Perl_my_getpwent(pTHX)
11398 {
11399     return (my_getpwuid((unsigned int) -1));
11400 }
11401 /*}}}*/
11402
11403 /*
11404  * Finish searching rights database for users.
11405 */
11406 /*{{{void my_endpwent()*/
11407 void Perl_my_endpwent(pTHX)
11408 {
11409     if (contxt) {
11410       _ckvmssts(sys$finish_rdb(&contxt));
11411       contxt= 0;
11412     }
11413 }
11414 /*}}}*/
11415
11416 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11417  * my_utime(), and flex_stat(), all of which operate on UTC unless
11418  * VMSISH_TIMES is true.
11419  */
11420 /* method used to handle UTC conversions:
11421  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11422  */
11423 static int gmtime_emulation_type;
11424 /* number of secs to add to UTC POSIX-style time to get local time */
11425 static long int utc_offset_secs;
11426
11427 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11428  * in vmsish.h.  #undef them here so we can call the CRTL routines
11429  * directly.
11430  */
11431 #undef gmtime
11432 #undef localtime
11433 #undef time
11434
11435
11436 static time_t toutc_dst(time_t loc) {
11437   struct tm *rsltmp;
11438
11439   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11440   loc -= utc_offset_secs;
11441   if (rsltmp->tm_isdst) loc -= 3600;
11442   return loc;
11443 }
11444 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11445        ((gmtime_emulation_type || my_time(NULL)), \
11446        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11447        ((secs) - utc_offset_secs))))
11448
11449 static time_t toloc_dst(time_t utc) {
11450   struct tm *rsltmp;
11451
11452   utc += utc_offset_secs;
11453   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11454   if (rsltmp->tm_isdst) utc += 3600;
11455   return utc;
11456 }
11457 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11458        ((gmtime_emulation_type || my_time(NULL)), \
11459        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11460        ((secs) + utc_offset_secs))))
11461
11462 /* my_time(), my_localtime(), my_gmtime()
11463  * By default traffic in UTC time values, using CRTL gmtime() or
11464  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11465  * Note: We need to use these functions even when the CRTL has working
11466  * UTC support, since they also handle C<use vmsish qw(times);>
11467  *
11468  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11469  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11470  */
11471
11472 /*{{{time_t my_time(time_t *timep)*/
11473 time_t Perl_my_time(pTHX_ time_t *timep)
11474 {
11475   time_t when;
11476   struct tm *tm_p;
11477
11478   if (gmtime_emulation_type == 0) {
11479     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11480                               /* results of calls to gmtime() and localtime() */
11481                               /* for same &base */
11482
11483     gmtime_emulation_type++;
11484     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11485       char off[LNM$C_NAMLENGTH+1];;
11486
11487       gmtime_emulation_type++;
11488       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11489         gmtime_emulation_type++;
11490         utc_offset_secs = 0;
11491         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11492       }
11493       else { utc_offset_secs = atol(off); }
11494     }
11495     else { /* We've got a working gmtime() */
11496       struct tm gmt, local;
11497
11498       gmt = *tm_p;
11499       tm_p = localtime(&base);
11500       local = *tm_p;
11501       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11502       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11503       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11504       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11505     }
11506   }
11507
11508   when = time(NULL);
11509 # ifdef VMSISH_TIME
11510   if (VMSISH_TIME) when = _toloc(when);
11511 # endif
11512   if (timep != NULL) *timep = when;
11513   return when;
11514
11515 }  /* end of my_time() */
11516 /*}}}*/
11517
11518
11519 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11520 struct tm *
11521 Perl_my_gmtime(pTHX_ const time_t *timep)
11522 {
11523   time_t when;
11524   struct tm *rsltmp;
11525
11526   if (timep == NULL) {
11527     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11528     return NULL;
11529   }
11530   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11531
11532   when = *timep;
11533 # ifdef VMSISH_TIME
11534   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11535 #  endif
11536   return gmtime(&when);
11537 }  /* end of my_gmtime() */
11538 /*}}}*/
11539
11540
11541 /*{{{struct tm *my_localtime(const time_t *timep)*/
11542 struct tm *
11543 Perl_my_localtime(pTHX_ const time_t *timep)
11544 {
11545   time_t when;
11546
11547   if (timep == NULL) {
11548     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11549     return NULL;
11550   }
11551   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11552   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11553
11554   when = *timep;
11555 # ifdef VMSISH_TIME
11556   if (VMSISH_TIME) when = _toutc(when);
11557 # endif
11558   /* CRTL localtime() wants UTC as input, does tz correction itself */
11559   return localtime(&when);
11560 } /*  end of my_localtime() */
11561 /*}}}*/
11562
11563 /* Reset definitions for later calls */
11564 #define gmtime(t)    my_gmtime(t)
11565 #define localtime(t) my_localtime(t)
11566 #define time(t)      my_time(t)
11567
11568
11569 /* my_utime - update modification/access time of a file
11570  *
11571  * VMS 7.3 and later implementation
11572  * Only the UTC translation is home-grown. The rest is handled by the
11573  * CRTL utime(), which will take into account the relevant feature
11574  * logicals and ODS-5 volume characteristics for true access times.
11575  *
11576  * pre VMS 7.3 implementation:
11577  * The calling sequence is identical to POSIX utime(), but under
11578  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11579  * not maintain access times.  Restrictions differ from the POSIX
11580  * definition in that the time can be changed as long as the
11581  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11582  * no separate checks are made to insure that the caller is the
11583  * owner of the file or has special privs enabled.
11584  * Code here is based on Joe Meadows' FILE utility.
11585  *
11586  */
11587
11588 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11589  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11590  * in 100 ns intervals.
11591  */
11592 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11593
11594 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11595 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11596 {
11597 #if __CRTL_VER >= 70300000
11598   struct utimbuf utc_utimes, *utc_utimesp;
11599
11600   if (utimes != NULL) {
11601     utc_utimes.actime = utimes->actime;
11602     utc_utimes.modtime = utimes->modtime;
11603 # ifdef VMSISH_TIME
11604     /* If input was local; convert to UTC for sys svc */
11605     if (VMSISH_TIME) {
11606       utc_utimes.actime = _toutc(utimes->actime);
11607       utc_utimes.modtime = _toutc(utimes->modtime);
11608     }
11609 # endif
11610     utc_utimesp = &utc_utimes;
11611   }
11612   else {
11613     utc_utimesp = NULL;
11614   }
11615
11616   return utime(file, utc_utimesp);
11617
11618 #else /* __CRTL_VER < 70300000 */
11619
11620   int i;
11621   int sts;
11622   long int bintime[2], len = 2, lowbit, unixtime,
11623            secscale = 10000000; /* seconds --> 100 ns intervals */
11624   unsigned long int chan, iosb[2], retsts;
11625   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11626   struct FAB myfab = cc$rms_fab;
11627   struct NAM mynam = cc$rms_nam;
11628 #if defined (__DECC) && defined (__VAX)
11629   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11630    * at least through VMS V6.1, which causes a type-conversion warning.
11631    */
11632 #  pragma message save
11633 #  pragma message disable cvtdiftypes
11634 #endif
11635   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11636   struct fibdef myfib;
11637 #if defined (__DECC) && defined (__VAX)
11638   /* This should be right after the declaration of myatr, but due
11639    * to a bug in VAX DEC C, this takes effect a statement early.
11640    */
11641 #  pragma message restore
11642 #endif
11643   /* cast ok for read only parameter */
11644   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11645                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11646                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11647
11648   if (file == NULL || *file == '\0') {
11649     SETERRNO(ENOENT, LIB$_INVARG);
11650     return -1;
11651   }
11652
11653   /* Convert to VMS format ensuring that it will fit in 255 characters */
11654   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11655       SETERRNO(ENOENT, LIB$_INVARG);
11656       return -1;
11657   }
11658   if (utimes != NULL) {
11659     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11660      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11661      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11662      * as input, we force the sign bit to be clear by shifting unixtime right
11663      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11664      */
11665     lowbit = (utimes->modtime & 1) ? secscale : 0;
11666     unixtime = (long int) utimes->modtime;
11667 #   ifdef VMSISH_TIME
11668     /* If input was UTC; convert to local for sys svc */
11669     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11670 #   endif
11671     unixtime >>= 1;  secscale <<= 1;
11672     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11673     if (!(retsts & 1)) {
11674       SETERRNO(EVMSERR, retsts);
11675       return -1;
11676     }
11677     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11678     if (!(retsts & 1)) {
11679       SETERRNO(EVMSERR, retsts);
11680       return -1;
11681     }
11682   }
11683   else {
11684     /* Just get the current time in VMS format directly */
11685     retsts = sys$gettim(bintime);
11686     if (!(retsts & 1)) {
11687       SETERRNO(EVMSERR, retsts);
11688       return -1;
11689     }
11690   }
11691
11692   myfab.fab$l_fna = vmsspec;
11693   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11694   myfab.fab$l_nam = &mynam;
11695   mynam.nam$l_esa = esa;
11696   mynam.nam$b_ess = (unsigned char) sizeof esa;
11697   mynam.nam$l_rsa = rsa;
11698   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11699   if (decc_efs_case_preserve)
11700       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11701
11702   /* Look for the file to be affected, letting RMS parse the file
11703    * specification for us as well.  I have set errno using only
11704    * values documented in the utime() man page for VMS POSIX.
11705    */
11706   retsts = sys$parse(&myfab,0,0);
11707   if (!(retsts & 1)) {
11708     set_vaxc_errno(retsts);
11709     if      (retsts == RMS$_PRV) set_errno(EACCES);
11710     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11711     else                         set_errno(EVMSERR);
11712     return -1;
11713   }
11714   retsts = sys$search(&myfab,0,0);
11715   if (!(retsts & 1)) {
11716     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11717     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11718     set_vaxc_errno(retsts);
11719     if      (retsts == RMS$_PRV) set_errno(EACCES);
11720     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11721     else                         set_errno(EVMSERR);
11722     return -1;
11723   }
11724
11725   devdsc.dsc$w_length = mynam.nam$b_dev;
11726   /* cast ok for read only parameter */
11727   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11728
11729   retsts = sys$assign(&devdsc,&chan,0,0);
11730   if (!(retsts & 1)) {
11731     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11732     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11733     set_vaxc_errno(retsts);
11734     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11735     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11736     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11737     else                               set_errno(EVMSERR);
11738     return -1;
11739   }
11740
11741   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11742   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11743
11744   memset((void *) &myfib, 0, sizeof myfib);
11745 #if defined(__DECC) || defined(__DECCXX)
11746   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11747   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11748   /* This prevents the revision time of the file being reset to the current
11749    * time as a result of our IO$_MODIFY $QIO. */
11750   myfib.fib$l_acctl = FIB$M_NORECORD;
11751 #else
11752   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11753   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11754   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11755 #endif
11756   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11757   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11758   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11759   _ckvmssts(sys$dassgn(chan));
11760   if (retsts & 1) retsts = iosb[0];
11761   if (!(retsts & 1)) {
11762     set_vaxc_errno(retsts);
11763     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11764     else                      set_errno(EVMSERR);
11765     return -1;
11766   }
11767
11768   return 0;
11769
11770 #endif /* #if __CRTL_VER >= 70300000 */
11771
11772 }  /* end of my_utime() */
11773 /*}}}*/
11774
11775 /*
11776  * flex_stat, flex_lstat, flex_fstat
11777  * basic stat, but gets it right when asked to stat
11778  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11779  */
11780
11781 #ifndef _USE_STD_STAT
11782 /* encode_dev packs a VMS device name string into an integer to allow
11783  * simple comparisons. This can be used, for example, to check whether two
11784  * files are located on the same device, by comparing their encoded device
11785  * names. Even a string comparison would not do, because stat() reuses the
11786  * device name buffer for each call; so without encode_dev, it would be
11787  * necessary to save the buffer and use strcmp (this would mean a number of
11788  * changes to the standard Perl code, to say nothing of what a Perl script
11789  * would have to do.
11790  *
11791  * The device lock id, if it exists, should be unique (unless perhaps compared
11792  * with lock ids transferred from other nodes). We have a lock id if the disk is
11793  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11794  * device names. Thus we use the lock id in preference, and only if that isn't
11795  * available, do we try to pack the device name into an integer (flagged by
11796  * the sign bit (LOCKID_MASK) being set).
11797  *
11798  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11799  * name and its encoded form, but it seems very unlikely that we will find
11800  * two files on different disks that share the same encoded device names,
11801  * and even more remote that they will share the same file id (if the test
11802  * is to check for the same file).
11803  *
11804  * A better method might be to use sys$device_scan on the first call, and to
11805  * search for the device, returning an index into the cached array.
11806  * The number returned would be more intelligible.
11807  * This is probably not worth it, and anyway would take quite a bit longer
11808  * on the first call.
11809  */
11810 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11811 static mydev_t encode_dev (pTHX_ const char *dev)
11812 {
11813   int i;
11814   unsigned long int f;
11815   mydev_t enc;
11816   char c;
11817   const char *q;
11818
11819   if (!dev || !dev[0]) return 0;
11820
11821 #if LOCKID_MASK
11822   {
11823     struct dsc$descriptor_s dev_desc;
11824     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11825
11826     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11827        can try that first. */
11828     dev_desc.dsc$w_length =  strlen (dev);
11829     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11830     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11831     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11832     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11833     if (!$VMS_STATUS_SUCCESS(status)) {
11834       switch (status) {
11835         case SS$_NOSUCHDEV:
11836           SETERRNO(ENODEV, status);
11837           return 0;
11838         default:
11839           _ckvmssts(status);
11840       }
11841     }
11842     if (lockid) return (lockid & ~LOCKID_MASK);
11843   }
11844 #endif
11845
11846   /* Otherwise we try to encode the device name */
11847   enc = 0;
11848   f = 1;
11849   i = 0;
11850   for (q = dev + strlen(dev); q--; q >= dev) {
11851     if (*q == ':')
11852         break;
11853     if (isdigit (*q))
11854       c= (*q) - '0';
11855     else if (isalpha (toupper (*q)))
11856       c= toupper (*q) - 'A' + (char)10;
11857     else
11858       continue; /* Skip '$'s */
11859     i++;
11860     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11861     if (i>1) f *= 36;
11862     enc += f * (unsigned long int) c;
11863   }
11864   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11865
11866 }  /* end of encode_dev() */
11867 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11868         device_no = encode_dev(aTHX_ devname)
11869 #else
11870 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11871         device_no = new_dev_no
11872 #endif
11873
11874 static int
11875 is_null_device(const char *name)
11876 {
11877   if (decc_bug_devnull != 0) {
11878     if (strncmp("/dev/null", name, 9) == 0)
11879       return 1;
11880   }
11881     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11882        The underscore prefix, controller letter, and unit number are
11883        independently optional; for our purposes, the colon punctuation
11884        is not.  The colon can be trailed by optional directory and/or
11885        filename, but two consecutive colons indicates a nodename rather
11886        than a device.  [pr]  */
11887   if (*name == '_') ++name;
11888   if (tolower(*name++) != 'n') return 0;
11889   if (tolower(*name++) != 'l') return 0;
11890   if (tolower(*name) == 'a') ++name;
11891   if (*name == '0') ++name;
11892   return (*name++ == ':') && (*name != ':');
11893 }
11894
11895 static int
11896 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11897
11898 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11899
11900 static I32
11901 Perl_cando_by_name_int
11902    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11903 {
11904   char usrname[L_cuserid];
11905   struct dsc$descriptor_s usrdsc =
11906          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11907   char *vmsname = NULL, *fileified = NULL;
11908   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11909   unsigned short int retlen, trnlnm_iter_count;
11910   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11911   union prvdef curprv;
11912   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11913          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11914          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11915   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11916          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11917          {0,0,0,0}};
11918   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11919          {0,0,0,0}};
11920   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11921   Stat_t st;
11922   static int profile_context = -1;
11923
11924   if (!fname || !*fname) return FALSE;
11925
11926   /* Make sure we expand logical names, since sys$check_access doesn't */
11927   fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11928   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11929   if (!strpbrk(fname,"/]>:")) {
11930       my_strlcpy(fileified, fname, VMS_MAXRSS);
11931       trnlnm_iter_count = 0;
11932       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11933         trnlnm_iter_count++;
11934         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11935       }
11936       fname = fileified;
11937   }
11938
11939   vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11940   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11941   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11942     /* Don't know if already in VMS format, so make sure */
11943     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11944       PerlMem_free(fileified);
11945       PerlMem_free(vmsname);
11946       return FALSE;
11947     }
11948   }
11949   else {
11950     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11951   }
11952
11953   /* sys$check_access needs a file spec, not a directory spec.
11954    * flex_stat now will handle a null thread context during startup.
11955    */
11956
11957   retlen = namdsc.dsc$w_length = strlen(vmsname);
11958   if (vmsname[retlen-1] == ']'
11959       || vmsname[retlen-1] == '>'
11960       || vmsname[retlen-1] == ':'
11961       || (!flex_stat_int(vmsname, &st, 1) &&
11962           S_ISDIR(st.st_mode))) {
11963
11964       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11965         PerlMem_free(fileified);
11966         PerlMem_free(vmsname);
11967         return FALSE;
11968       }
11969       fname = fileified;
11970   }
11971   else {
11972       fname = vmsname;
11973   }
11974
11975   retlen = namdsc.dsc$w_length = strlen(fname);
11976   namdsc.dsc$a_pointer = (char *)fname;
11977
11978   switch (bit) {
11979     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11980       access = ARM$M_EXECUTE;
11981       flags = CHP$M_READ;
11982       break;
11983     case S_IRUSR: case S_IRGRP: case S_IROTH:
11984       access = ARM$M_READ;
11985       flags = CHP$M_READ | CHP$M_USEREADALL;
11986       break;
11987     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11988       access = ARM$M_WRITE;
11989       flags = CHP$M_READ | CHP$M_WRITE;
11990       break;
11991     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11992       access = ARM$M_DELETE;
11993       flags = CHP$M_READ | CHP$M_WRITE;
11994       break;
11995     default:
11996       if (fileified != NULL)
11997         PerlMem_free(fileified);
11998       if (vmsname != NULL)
11999         PerlMem_free(vmsname);
12000       return FALSE;
12001   }
12002
12003   /* Before we call $check_access, create a user profile with the current
12004    * process privs since otherwise it just uses the default privs from the
12005    * UAF and might give false positives or negatives.  This only works on
12006    * VMS versions v6.0 and later since that's when sys$create_user_profile
12007    * became available.
12008    */
12009
12010   /* get current process privs and username */
12011   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12012   _ckvmssts_noperl(iosb[0]);
12013
12014   /* find out the space required for the profile */
12015   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12016                                     &usrprodsc.dsc$w_length,&profile_context));
12017
12018   /* allocate space for the profile and get it filled in */
12019   usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
12020   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12021   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12022                                     &usrprodsc.dsc$w_length,&profile_context));
12023
12024   /* use the profile to check access to the file; free profile & analyze results */
12025   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12026   PerlMem_free(usrprodsc.dsc$a_pointer);
12027   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12028
12029   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12030       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12031       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12032     set_vaxc_errno(retsts);
12033     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12034     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12035     else set_errno(ENOENT);
12036     if (fileified != NULL)
12037       PerlMem_free(fileified);
12038     if (vmsname != NULL)
12039       PerlMem_free(vmsname);
12040     return FALSE;
12041   }
12042   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12043     if (fileified != NULL)
12044       PerlMem_free(fileified);
12045     if (vmsname != NULL)
12046       PerlMem_free(vmsname);
12047     return TRUE;
12048   }
12049   _ckvmssts_noperl(retsts);
12050
12051   if (fileified != NULL)
12052     PerlMem_free(fileified);
12053   if (vmsname != NULL)
12054     PerlMem_free(vmsname);
12055   return FALSE;  /* Should never get here */
12056
12057 }
12058
12059 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12060 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12061  * subset of the applicable information.
12062  */
12063 bool
12064 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12065 {
12066   return cando_by_name_int
12067         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12068 }  /* end of cando() */
12069 /*}}}*/
12070
12071
12072 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12073 I32
12074 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12075 {
12076    return cando_by_name_int(bit, effective, fname, 0);
12077
12078 }  /* end of cando_by_name() */
12079 /*}}}*/
12080
12081
12082 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12083 int
12084 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12085 {
12086   dSAVE_ERRNO; /* fstat may set this even on success */
12087   if (!fstat(fd, &statbufp->crtl_stat)) {
12088     char *cptr;
12089     char *vms_filename;
12090     vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12091     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12092
12093     /* Save name for cando by name in VMS format */
12094     cptr = getname(fd, vms_filename, 1);
12095
12096     /* This should not happen, but just in case */
12097     if (cptr == NULL) {
12098         statbufp->st_devnam[0] = 0;
12099     }
12100     else {
12101         /* Make sure that the saved name fits in 255 characters */
12102         cptr = int_rmsexpand_vms
12103                        (vms_filename,
12104                         statbufp->st_devnam,
12105                         0);
12106         if (cptr == NULL)
12107             statbufp->st_devnam[0] = 0;
12108     }
12109     PerlMem_free(vms_filename);
12110
12111     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12112     VMS_DEVICE_ENCODE
12113         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12114
12115 #   ifdef VMSISH_TIME
12116     if (VMSISH_TIME) {
12117       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12118       statbufp->st_atime = _toloc(statbufp->st_atime);
12119       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12120     }
12121 #   endif
12122     RESTORE_ERRNO;
12123     return 0;
12124   }
12125   return -1;
12126
12127 }  /* end of flex_fstat() */
12128 /*}}}*/
12129
12130 static int
12131 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12132 {
12133     char *temp_fspec = NULL;
12134     char *fileified = NULL;
12135     const char *save_spec;
12136     char *ret_spec;
12137     int retval = -1;
12138     char efs_hack = 0;
12139     char already_fileified = 0;
12140     dSAVEDERRNO;
12141
12142     if (!fspec) {
12143         errno = EINVAL;
12144         return retval;
12145     }
12146
12147     if (decc_bug_devnull != 0) {
12148       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12149         memset(statbufp,0,sizeof *statbufp);
12150         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12151         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12152         statbufp->st_uid = 0x00010001;
12153         statbufp->st_gid = 0x0001;
12154         time((time_t *)&statbufp->st_mtime);
12155         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12156         return 0;
12157       }
12158     }
12159
12160     SAVE_ERRNO;
12161
12162 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12163   /*
12164    * If we are in POSIX filespec mode, accept the filename as is.
12165    */
12166   if (decc_posix_compliant_pathnames == 0) {
12167 #endif
12168
12169     /* Try for a simple stat first.  If fspec contains a filename without
12170      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12171      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12172      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12173      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12174      * the file with null type, specify this by calling flex_stat() with
12175      * a '.' at the end of fspec.
12176      */
12177
12178     if (lstat_flag == 0)
12179         retval = stat(fspec, &statbufp->crtl_stat);
12180     else
12181         retval = lstat(fspec, &statbufp->crtl_stat);
12182
12183     if (!retval) {
12184         save_spec = fspec;
12185     }
12186     else {
12187         /* In the odd case where we have write but not read access
12188          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12189          */
12190         fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12191         if (fileified == NULL)
12192               _ckvmssts_noperl(SS$_INSFMEM);
12193
12194         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12195         if (ret_spec != NULL) {
12196             if (lstat_flag == 0)
12197                 retval = stat(fileified, &statbufp->crtl_stat);
12198             else
12199                 retval = lstat(fileified, &statbufp->crtl_stat);
12200             save_spec = fileified;
12201             already_fileified = 1;
12202         }
12203     }
12204
12205     if (retval && vms_bug_stat_filename) {
12206
12207         temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12208         if (temp_fspec == NULL)
12209             _ckvmssts_noperl(SS$_INSFMEM);
12210
12211         /* We should try again as a vmsified file specification. */
12212
12213         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12214         if (ret_spec != NULL) {
12215             if (lstat_flag == 0)
12216                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12217             else
12218                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12219             save_spec = temp_fspec;
12220         }
12221     }
12222
12223     if (retval) {
12224         /* Last chance - allow multiple dots without EFS CHARSET */
12225         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12226          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12227          * enable it if it isn't already.
12228          */
12229 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12230         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12231             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12232 #endif
12233         if (lstat_flag == 0)
12234             retval = stat(fspec, &statbufp->crtl_stat);
12235         else
12236             retval = lstat(fspec, &statbufp->crtl_stat);
12237         save_spec = fspec;
12238 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12239         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12240             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12241             efs_hack = 1;
12242         }
12243 #endif
12244     }
12245
12246 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12247   } else {
12248     if (lstat_flag == 0)
12249       retval = stat(temp_fspec, &statbufp->crtl_stat);
12250     else
12251       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12252       save_spec = temp_fspec;
12253   }
12254 #endif
12255
12256 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12257   /* As you were... */
12258   if (!decc_efs_charset)
12259     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12260 #endif
12261
12262     if (!retval) {
12263       char *cptr;
12264       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12265
12266       /* If this is an lstat, do not follow the link */
12267       if (lstat_flag)
12268         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12269
12270 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12271       /* If we used the efs_hack above, we must also use it here for */
12272       /* perl_cando to work */
12273       if (efs_hack && (decc_efs_charset_index > 0)) {
12274           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12275       }
12276 #endif
12277
12278       /* If we've got a directory, save a fileified, expanded version of it
12279        * in st_devnam.  If not a directory, just an expanded version.
12280        */
12281       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12282           fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12283           if (fileified == NULL)
12284               _ckvmssts_noperl(SS$_INSFMEM);
12285
12286           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12287           if (cptr != NULL)
12288               save_spec = fileified;
12289       }
12290
12291       cptr = int_rmsexpand(save_spec,
12292                            statbufp->st_devnam,
12293                            NULL,
12294                            rmsex_flags,
12295                            0,
12296                            0);
12297
12298 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12299       if (efs_hack && (decc_efs_charset_index > 0)) {
12300           decc$feature_set_value(decc_efs_charset, 1, 0);
12301       }
12302 #endif
12303
12304       /* Fix me: If this is NULL then stat found a file, and we could */
12305       /* not convert the specification to VMS - Should never happen */
12306       if (cptr == NULL)
12307         statbufp->st_devnam[0] = 0;
12308
12309       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12310       VMS_DEVICE_ENCODE
12311         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12312 #     ifdef VMSISH_TIME
12313       if (VMSISH_TIME) {
12314         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12315         statbufp->st_atime = _toloc(statbufp->st_atime);
12316         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12317       }
12318 #     endif
12319     }
12320     /* If we were successful, leave errno where we found it */
12321     if (retval == 0) RESTORE_ERRNO;
12322     if (temp_fspec)
12323         PerlMem_free(temp_fspec);
12324     if (fileified)
12325         PerlMem_free(fileified);
12326     return retval;
12327
12328 }  /* end of flex_stat_int() */
12329
12330
12331 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12332 int
12333 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12334 {
12335    return flex_stat_int(fspec, statbufp, 0);
12336 }
12337 /*}}}*/
12338
12339 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12340 int
12341 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12342 {
12343    return flex_stat_int(fspec, statbufp, 1);
12344 }
12345 /*}}}*/
12346
12347
12348 /*{{{char *my_getlogin()*/
12349 /* VMS cuserid == Unix getlogin, except calling sequence */
12350 char *
12351 my_getlogin(void)
12352 {
12353     static char user[L_cuserid];
12354     return cuserid(user);
12355 }
12356 /*}}}*/
12357
12358
12359 /*  rmscopy - copy a file using VMS RMS routines
12360  *
12361  *  Copies contents and attributes of spec_in to spec_out, except owner
12362  *  and protection information.  Name and type of spec_in are used as
12363  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12364  *  should try to propagate timestamps from the input file to the output file.
12365  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12366  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12367  *  propagated to the output file at creation iff the output file specification
12368  *  did not contain an explicit name or type, and the revision date is always
12369  *  updated at the end of the copy operation.  If it is greater than 0, then
12370  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12371  *  other than the revision date should be propagated, and bit 1 indicates
12372  *  that the revision date should be propagated.
12373  *
12374  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12375  *
12376  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12377  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12378  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12379  * as part of the Perl standard distribution under the terms of the
12380  * GNU General Public License or the Perl Artistic License.  Copies
12381  * of each may be found in the Perl standard distribution.
12382  */ /* FIXME */
12383 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12384 int
12385 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12386 {
12387     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12388          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12389     unsigned long int sts;
12390     int dna_len;
12391     struct FAB fab_in, fab_out;
12392     struct RAB rab_in, rab_out;
12393     rms_setup_nam(nam);
12394     rms_setup_nam(nam_out);
12395     struct XABDAT xabdat;
12396     struct XABFHC xabfhc;
12397     struct XABRDT xabrdt;
12398     struct XABSUM xabsum;
12399
12400     vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12401     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12402     vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12403     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12404     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12405         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12406       PerlMem_free(vmsin);
12407       PerlMem_free(vmsout);
12408       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12409       return 0;
12410     }
12411
12412     esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12413     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12414     esal = NULL;
12415 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12416     esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12417     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12418 #endif
12419     fab_in = cc$rms_fab;
12420     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12421     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12422     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12423     fab_in.fab$l_fop = FAB$M_SQO;
12424     rms_bind_fab_nam(fab_in, nam);
12425     fab_in.fab$l_xab = (void *) &xabdat;
12426
12427     rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12428     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12429     rsal = NULL;
12430 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12431     rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12432     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12433 #endif
12434     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12435     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12436     rms_nam_esl(nam) = 0;
12437     rms_nam_rsl(nam) = 0;
12438     rms_nam_esll(nam) = 0;
12439     rms_nam_rsll(nam) = 0;
12440 #ifdef NAM$M_NO_SHORT_UPCASE
12441     if (decc_efs_case_preserve)
12442         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12443 #endif
12444
12445     xabdat = cc$rms_xabdat;        /* To get creation date */
12446     xabdat.xab$l_nxt = (void *) &xabfhc;
12447
12448     xabfhc = cc$rms_xabfhc;        /* To get record length */
12449     xabfhc.xab$l_nxt = (void *) &xabsum;
12450
12451     xabsum = cc$rms_xabsum;        /* To get key and area information */
12452
12453     if (!((sts = sys$open(&fab_in)) & 1)) {
12454       PerlMem_free(vmsin);
12455       PerlMem_free(vmsout);
12456       PerlMem_free(esa);
12457       if (esal != NULL)
12458         PerlMem_free(esal);
12459       PerlMem_free(rsa);
12460       if (rsal != NULL)
12461         PerlMem_free(rsal);
12462       set_vaxc_errno(sts);
12463       switch (sts) {
12464         case RMS$_FNF: case RMS$_DNF:
12465           set_errno(ENOENT); break;
12466         case RMS$_DIR:
12467           set_errno(ENOTDIR); break;
12468         case RMS$_DEV:
12469           set_errno(ENODEV); break;
12470         case RMS$_SYN:
12471           set_errno(EINVAL); break;
12472         case RMS$_PRV:
12473           set_errno(EACCES); break;
12474         default:
12475           set_errno(EVMSERR);
12476       }
12477       return 0;
12478     }
12479
12480     nam_out = nam;
12481     fab_out = fab_in;
12482     fab_out.fab$w_ifi = 0;
12483     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12484     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12485     fab_out.fab$l_fop = FAB$M_SQO;
12486     rms_bind_fab_nam(fab_out, nam_out);
12487     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12488     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12489     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12490     esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12491     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12492     rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12493     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12494     esal_out = NULL;
12495     rsal_out = NULL;
12496 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12497     esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12498     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12499     rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12500     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12501 #endif
12502     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12503     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12504
12505     if (preserve_dates == 0) {  /* Act like DCL COPY */
12506       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12507       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12508       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12509         PerlMem_free(vmsin);
12510         PerlMem_free(vmsout);
12511         PerlMem_free(esa);
12512         if (esal != NULL)
12513             PerlMem_free(esal);
12514         PerlMem_free(rsa);
12515         if (rsal != NULL)
12516             PerlMem_free(rsal);
12517         PerlMem_free(esa_out);
12518         if (esal_out != NULL)
12519             PerlMem_free(esal_out);
12520         PerlMem_free(rsa_out);
12521         if (rsal_out != NULL)
12522             PerlMem_free(rsal_out);
12523         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12524         set_vaxc_errno(sts);
12525         return 0;
12526       }
12527       fab_out.fab$l_xab = (void *) &xabdat;
12528       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12529         preserve_dates = 1;
12530     }
12531     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12532       preserve_dates =0;      /* bitmask from this point forward   */
12533
12534     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12535     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12536       PerlMem_free(vmsin);
12537       PerlMem_free(vmsout);
12538       PerlMem_free(esa);
12539       if (esal != NULL)
12540           PerlMem_free(esal);
12541       PerlMem_free(rsa);
12542       if (rsal != NULL)
12543           PerlMem_free(rsal);
12544       PerlMem_free(esa_out);
12545       if (esal_out != NULL)
12546           PerlMem_free(esal_out);
12547       PerlMem_free(rsa_out);
12548       if (rsal_out != NULL)
12549           PerlMem_free(rsal_out);
12550       set_vaxc_errno(sts);
12551       switch (sts) {
12552         case RMS$_DNF:
12553           set_errno(ENOENT); break;
12554         case RMS$_DIR:
12555           set_errno(ENOTDIR); break;
12556         case RMS$_DEV:
12557           set_errno(ENODEV); break;
12558         case RMS$_SYN:
12559           set_errno(EINVAL); break;
12560         case RMS$_PRV:
12561           set_errno(EACCES); break;
12562         default:
12563           set_errno(EVMSERR);
12564       }
12565       return 0;
12566     }
12567     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12568     if (preserve_dates & 2) {
12569       /* sys$close() will process xabrdt, not xabdat */
12570       xabrdt = cc$rms_xabrdt;
12571 #ifndef __GNUC__
12572       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12573 #else
12574       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12575        * is unsigned long[2], while DECC & VAXC use a struct */
12576       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12577 #endif
12578       fab_out.fab$l_xab = (void *) &xabrdt;
12579     }
12580
12581     ubf = (char *)PerlMem_malloc(32256);
12582     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12583     rab_in = cc$rms_rab;
12584     rab_in.rab$l_fab = &fab_in;
12585     rab_in.rab$l_rop = RAB$M_BIO;
12586     rab_in.rab$l_ubf = ubf;
12587     rab_in.rab$w_usz = 32256;
12588     if (!((sts = sys$connect(&rab_in)) & 1)) {
12589       sys$close(&fab_in); sys$close(&fab_out);
12590       PerlMem_free(vmsin);
12591       PerlMem_free(vmsout);
12592       PerlMem_free(ubf);
12593       PerlMem_free(esa);
12594       if (esal != NULL)
12595           PerlMem_free(esal);
12596       PerlMem_free(rsa);
12597       if (rsal != NULL)
12598           PerlMem_free(rsal);
12599       PerlMem_free(esa_out);
12600       if (esal_out != NULL)
12601           PerlMem_free(esal_out);
12602       PerlMem_free(rsa_out);
12603       if (rsal_out != NULL)
12604           PerlMem_free(rsal_out);
12605       set_errno(EVMSERR); set_vaxc_errno(sts);
12606       return 0;
12607     }
12608
12609     rab_out = cc$rms_rab;
12610     rab_out.rab$l_fab = &fab_out;
12611     rab_out.rab$l_rbf = ubf;
12612     if (!((sts = sys$connect(&rab_out)) & 1)) {
12613       sys$close(&fab_in); sys$close(&fab_out);
12614       PerlMem_free(vmsin);
12615       PerlMem_free(vmsout);
12616       PerlMem_free(ubf);
12617       PerlMem_free(esa);
12618       if (esal != NULL)
12619           PerlMem_free(esal);
12620       PerlMem_free(rsa);
12621       if (rsal != NULL)
12622           PerlMem_free(rsal);
12623       PerlMem_free(esa_out);
12624       if (esal_out != NULL)
12625           PerlMem_free(esal_out);
12626       PerlMem_free(rsa_out);
12627       if (rsal_out != NULL)
12628           PerlMem_free(rsal_out);
12629       set_errno(EVMSERR); set_vaxc_errno(sts);
12630       return 0;
12631     }
12632
12633     while ((sts = sys$read(&rab_in))) {  /* always true  */
12634       if (sts == RMS$_EOF) break;
12635       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12636       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12637         sys$close(&fab_in); sys$close(&fab_out);
12638         PerlMem_free(vmsin);
12639         PerlMem_free(vmsout);
12640         PerlMem_free(ubf);
12641         PerlMem_free(esa);
12642         if (esal != NULL)
12643             PerlMem_free(esal);
12644         PerlMem_free(rsa);
12645         if (rsal != NULL)
12646             PerlMem_free(rsal);
12647         PerlMem_free(esa_out);
12648         if (esal_out != NULL)
12649             PerlMem_free(esal_out);
12650         PerlMem_free(rsa_out);
12651         if (rsal_out != NULL)
12652             PerlMem_free(rsal_out);
12653         set_errno(EVMSERR); set_vaxc_errno(sts);
12654         return 0;
12655       }
12656     }
12657
12658
12659     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12660     sys$close(&fab_in);  sys$close(&fab_out);
12661     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12662
12663     PerlMem_free(vmsin);
12664     PerlMem_free(vmsout);
12665     PerlMem_free(ubf);
12666     PerlMem_free(esa);
12667     if (esal != NULL)
12668         PerlMem_free(esal);
12669     PerlMem_free(rsa);
12670     if (rsal != NULL)
12671         PerlMem_free(rsal);
12672     PerlMem_free(esa_out);
12673     if (esal_out != NULL)
12674         PerlMem_free(esal_out);
12675     PerlMem_free(rsa_out);
12676     if (rsal_out != NULL)
12677         PerlMem_free(rsal_out);
12678
12679     if (!(sts & 1)) {
12680       set_errno(EVMSERR); set_vaxc_errno(sts);
12681       return 0;
12682     }
12683
12684     return 1;
12685
12686 }  /* end of rmscopy() */
12687 /*}}}*/
12688
12689
12690 /***  The following glue provides 'hooks' to make some of the routines
12691  * from this file available from Perl.  These routines are sufficiently
12692  * basic, and are required sufficiently early in the build process,
12693  * that's it's nice to have them available to miniperl as well as the
12694  * full Perl, so they're set up here instead of in an extension.  The
12695  * Perl code which handles importation of these names into a given
12696  * package lives in [.VMS]Filespec.pm in @INC.
12697  */
12698
12699 void
12700 rmsexpand_fromperl(pTHX_ CV *cv)
12701 {
12702   dXSARGS;
12703   char *fspec, *defspec = NULL, *rslt;
12704   STRLEN n_a;
12705   int fs_utf8, dfs_utf8;
12706
12707   fs_utf8 = 0;
12708   dfs_utf8 = 0;
12709   if (!items || items > 2)
12710     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12711   fspec = SvPV(ST(0),n_a);
12712   fs_utf8 = SvUTF8(ST(0));
12713   if (!fspec || !*fspec) XSRETURN_UNDEF;
12714   if (items == 2) {
12715     defspec = SvPV(ST(1),n_a);
12716     dfs_utf8 = SvUTF8(ST(1));
12717   }
12718   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12719   ST(0) = sv_newmortal();
12720   if (rslt != NULL) {
12721     sv_usepvn(ST(0),rslt,strlen(rslt));
12722     if (fs_utf8) {
12723         SvUTF8_on(ST(0));
12724     }
12725   }
12726   XSRETURN(1);
12727 }
12728
12729 void
12730 vmsify_fromperl(pTHX_ CV *cv)
12731 {
12732   dXSARGS;
12733   char *vmsified;
12734   STRLEN n_a;
12735   int utf8_fl;
12736
12737   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12738   utf8_fl = SvUTF8(ST(0));
12739   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12740   ST(0) = sv_newmortal();
12741   if (vmsified != NULL) {
12742     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12743     if (utf8_fl) {
12744         SvUTF8_on(ST(0));
12745     }
12746   }
12747   XSRETURN(1);
12748 }
12749
12750 void
12751 unixify_fromperl(pTHX_ CV *cv)
12752 {
12753   dXSARGS;
12754   char *unixified;
12755   STRLEN n_a;
12756   int utf8_fl;
12757
12758   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12759   utf8_fl = SvUTF8(ST(0));
12760   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12761   ST(0) = sv_newmortal();
12762   if (unixified != NULL) {
12763     sv_usepvn(ST(0),unixified,strlen(unixified));
12764     if (utf8_fl) {
12765         SvUTF8_on(ST(0));
12766     }
12767   }
12768   XSRETURN(1);
12769 }
12770
12771 void
12772 fileify_fromperl(pTHX_ CV *cv)
12773 {
12774   dXSARGS;
12775   char *fileified;
12776   STRLEN n_a;
12777   int utf8_fl;
12778
12779   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12780   utf8_fl = SvUTF8(ST(0));
12781   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12782   ST(0) = sv_newmortal();
12783   if (fileified != NULL) {
12784     sv_usepvn(ST(0),fileified,strlen(fileified));
12785     if (utf8_fl) {
12786         SvUTF8_on(ST(0));
12787     }
12788   }
12789   XSRETURN(1);
12790 }
12791
12792 void
12793 pathify_fromperl(pTHX_ CV *cv)
12794 {
12795   dXSARGS;
12796   char *pathified;
12797   STRLEN n_a;
12798   int utf8_fl;
12799
12800   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12801   utf8_fl = SvUTF8(ST(0));
12802   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12803   ST(0) = sv_newmortal();
12804   if (pathified != NULL) {
12805     sv_usepvn(ST(0),pathified,strlen(pathified));
12806     if (utf8_fl) {
12807         SvUTF8_on(ST(0));
12808     }
12809   }
12810   XSRETURN(1);
12811 }
12812
12813 void
12814 vmspath_fromperl(pTHX_ CV *cv)
12815 {
12816   dXSARGS;
12817   char *vmspath;
12818   STRLEN n_a;
12819   int utf8_fl;
12820
12821   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12822   utf8_fl = SvUTF8(ST(0));
12823   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12824   ST(0) = sv_newmortal();
12825   if (vmspath != NULL) {
12826     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12827     if (utf8_fl) {
12828         SvUTF8_on(ST(0));
12829     }
12830   }
12831   XSRETURN(1);
12832 }
12833
12834 void
12835 unixpath_fromperl(pTHX_ CV *cv)
12836 {
12837   dXSARGS;
12838   char *unixpath;
12839   STRLEN n_a;
12840   int utf8_fl;
12841
12842   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12843   utf8_fl = SvUTF8(ST(0));
12844   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12845   ST(0) = sv_newmortal();
12846   if (unixpath != NULL) {
12847     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12848     if (utf8_fl) {
12849         SvUTF8_on(ST(0));
12850     }
12851   }
12852   XSRETURN(1);
12853 }
12854
12855 void
12856 candelete_fromperl(pTHX_ CV *cv)
12857 {
12858   dXSARGS;
12859   char *fspec, *fsp;
12860   SV *mysv;
12861   IO *io;
12862   STRLEN n_a;
12863
12864   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12865
12866   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12867   Newx(fspec, VMS_MAXRSS, char);
12868   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12869   if (isGV_with_GP(mysv)) {
12870     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12871       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12872       ST(0) = &PL_sv_no;
12873       Safefree(fspec);
12874       XSRETURN(1);
12875     }
12876     fsp = fspec;
12877   }
12878   else {
12879     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12880       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12881       ST(0) = &PL_sv_no;
12882       Safefree(fspec);
12883       XSRETURN(1);
12884     }
12885   }
12886
12887   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12888   Safefree(fspec);
12889   XSRETURN(1);
12890 }
12891
12892 void
12893 rmscopy_fromperl(pTHX_ CV *cv)
12894 {
12895   dXSARGS;
12896   char *inspec, *outspec, *inp, *outp;
12897   int date_flag;
12898   SV *mysv;
12899   IO *io;
12900   STRLEN n_a;
12901
12902   if (items < 2 || items > 3)
12903     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12904
12905   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12906   Newx(inspec, VMS_MAXRSS, char);
12907   if (isGV_with_GP(mysv)) {
12908     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12909       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12910       ST(0) = sv_2mortal(newSViv(0));
12911       Safefree(inspec);
12912       XSRETURN(1);
12913     }
12914     inp = inspec;
12915   }
12916   else {
12917     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12918       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12919       ST(0) = sv_2mortal(newSViv(0));
12920       Safefree(inspec);
12921       XSRETURN(1);
12922     }
12923   }
12924   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12925   Newx(outspec, VMS_MAXRSS, char);
12926   if (isGV_with_GP(mysv)) {
12927     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12928       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12929       ST(0) = sv_2mortal(newSViv(0));
12930       Safefree(inspec);
12931       Safefree(outspec);
12932       XSRETURN(1);
12933     }
12934     outp = outspec;
12935   }
12936   else {
12937     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12938       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12939       ST(0) = sv_2mortal(newSViv(0));
12940       Safefree(inspec);
12941       Safefree(outspec);
12942       XSRETURN(1);
12943     }
12944   }
12945   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12946
12947   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12948   Safefree(inspec);
12949   Safefree(outspec);
12950   XSRETURN(1);
12951 }
12952
12953 /* The mod2fname is limited to shorter filenames by design, so it should
12954  * not be modified to support longer EFS pathnames
12955  */
12956 void
12957 mod2fname(pTHX_ CV *cv)
12958 {
12959   dXSARGS;
12960   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12961        workbuff[NAM$C_MAXRSS*1 + 1];
12962   SSize_t counter, num_entries;
12963   /* ODS-5 ups this, but we want to be consistent, so... */
12964   int max_name_len = 39;
12965   AV *in_array = (AV *)SvRV(ST(0));
12966
12967   num_entries = av_tindex(in_array);
12968
12969   /* All the names start with PL_. */
12970   strcpy(ultimate_name, "PL_");
12971
12972   /* Clean up our working buffer */
12973   Zero(work_name, sizeof(work_name), char);
12974
12975   /* Run through the entries and build up a working name */
12976   for(counter = 0; counter <= num_entries; counter++) {
12977     /* If it's not the first name then tack on a __ */
12978     if (counter) {
12979       my_strlcat(work_name, "__", sizeof(work_name));
12980     }
12981     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12982   }
12983
12984   /* Check to see if we actually have to bother...*/
12985   if (strlen(work_name) + 3 <= max_name_len) {
12986     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12987   } else {
12988     /* It's too darned big, so we need to go strip. We use the same */
12989     /* algorithm as xsubpp does. First, strip out doubled __ */
12990     char *source, *dest, last;
12991     dest = workbuff;
12992     last = 0;
12993     for (source = work_name; *source; source++) {
12994       if (last == *source && last == '_') {
12995         continue;
12996       }
12997       *dest++ = *source;
12998       last = *source;
12999     }
13000     /* Go put it back */
13001     my_strlcpy(work_name, workbuff, sizeof(work_name));
13002     /* Is it still too big? */
13003     if (strlen(work_name) + 3 > max_name_len) {
13004       /* Strip duplicate letters */
13005       last = 0;
13006       dest = workbuff;
13007       for (source = work_name; *source; source++) {
13008         if (last == toupper(*source)) {
13009         continue;
13010         }
13011         *dest++ = *source;
13012         last = toupper(*source);
13013       }
13014       my_strlcpy(work_name, workbuff, sizeof(work_name));
13015     }
13016
13017     /* Is it *still* too big? */
13018     if (strlen(work_name) + 3 > max_name_len) {
13019       /* Too bad, we truncate */
13020       work_name[max_name_len - 2] = 0;
13021     }
13022     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
13023   }
13024
13025   /* Okay, return it */
13026   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13027   XSRETURN(1);
13028 }
13029
13030 void
13031 hushexit_fromperl(pTHX_ CV *cv)
13032 {
13033     dXSARGS;
13034
13035     if (items > 0) {
13036         VMSISH_HUSHED = SvTRUE(ST(0));
13037     }
13038     ST(0) = boolSV(VMSISH_HUSHED);
13039     XSRETURN(1);
13040 }
13041
13042
13043 PerlIO *
13044 Perl_vms_start_glob
13045    (pTHX_ SV *tmpglob,
13046     IO *io)
13047 {
13048     PerlIO *fp;
13049     struct vs_str_st *rslt;
13050     char *vmsspec;
13051     char *rstr;
13052     char *begin, *cp;
13053     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13054     PerlIO *tmpfp;
13055     STRLEN i;
13056     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13057     struct dsc$descriptor_vs rsdsc;
13058     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13059     unsigned long hasver = 0, isunix = 0;
13060     unsigned long int lff_flags = 0;
13061     int rms_sts;
13062     int vms_old_glob = 1;
13063
13064     if (!SvOK(tmpglob)) {
13065         SETERRNO(ENOENT,RMS$_FNF);
13066         return NULL;
13067     }
13068
13069     vms_old_glob = !decc_filename_unix_report;
13070
13071 #ifdef VMS_LONGNAME_SUPPORT
13072     lff_flags = LIB$M_FIL_LONG_NAMES;
13073 #endif
13074     /* The Newx macro will not allow me to assign a smaller array
13075      * to the rslt pointer, so we will assign it to the begin char pointer
13076      * and then copy the value into the rslt pointer.
13077      */
13078     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13079     rslt = (struct vs_str_st *)begin;
13080     rslt->length = 0;
13081     rstr = &rslt->str[0];
13082     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13083     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13084     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13085     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13086
13087     Newx(vmsspec, VMS_MAXRSS, char);
13088
13089         /* We could find out if there's an explicit dev/dir or version
13090            by peeking into lib$find_file's internal context at
13091            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13092            but that's unsupported, so I don't want to do it now and
13093            have it bite someone in the future. */
13094         /* Fix-me: vms_split_path() is the only way to do this, the
13095            existing method will fail with many legal EFS or UNIX specifications
13096          */
13097
13098     cp = SvPV(tmpglob,i);
13099
13100     for (; i; i--) {
13101         if (cp[i] == ';') hasver = 1;
13102         if (cp[i] == '.') {
13103             if (sts) hasver = 1;
13104             else sts = 1;
13105         }
13106         if (cp[i] == '/') {
13107             hasdir = isunix = 1;
13108             break;
13109         }
13110         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13111             hasdir = 1;
13112             break;
13113         }
13114     }
13115
13116     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13117     if ((hasdir == 0) && decc_filename_unix_report) {
13118         isunix = 1;
13119     }
13120
13121     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13122         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13123         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13124         int wildstar = 0;
13125         int wildquery = 0;
13126         int found = 0;
13127         Stat_t st;
13128         int stat_sts;
13129         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13130         if (!stat_sts && S_ISDIR(st.st_mode)) {
13131             char * vms_dir;
13132             const char * fname;
13133             STRLEN fname_len;
13134
13135             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13136             /* path delimiter of ':>]', if so, then the old behavior has */
13137             /* obviously been specifically requested */
13138
13139             fname = SvPVX_const(tmpglob);
13140             fname_len = strlen(fname);
13141             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13142             if (vms_old_glob || (vms_dir != NULL)) {
13143                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13144                                             SvPVX(tmpglob),vmsspec,NULL);
13145                 ok = (wilddsc.dsc$a_pointer != NULL);
13146                 /* maybe passed 'foo' rather than '[.foo]', thus not
13147                    detected above */
13148                 hasdir = 1;
13149             } else {
13150                 /* Operate just on the directory, the special stat/fstat for */
13151                 /* leaves the fileified  specification in the st_devnam */
13152                 /* member. */
13153                 wilddsc.dsc$a_pointer = st.st_devnam;
13154                 ok = 1;
13155             }
13156         }
13157         else {
13158             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13159             ok = (wilddsc.dsc$a_pointer != NULL);
13160         }
13161         if (ok)
13162             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13163
13164         /* If not extended character set, replace ? with % */
13165         /* With extended character set, ? is a wildcard single character */
13166         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13167             if (*cp == '?') {
13168                 wildquery = 1;
13169                 if (!decc_efs_charset)
13170                     *cp = '%';
13171             } else if (*cp == '%') {
13172                 wildquery = 1;
13173             } else if (*cp == '*') {
13174                 wildstar = 1;
13175             }
13176         }
13177
13178         if (ok) {
13179             wv_sts = vms_split_path(
13180                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13181                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13182                 &wvs_spec, &wvs_len);
13183         } else {
13184             wn_spec = NULL;
13185             wn_len = 0;
13186             we_spec = NULL;
13187             we_len = 0;
13188         }
13189
13190         sts = SS$_NORMAL;
13191         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13192          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13193          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13194          int valid_find;
13195
13196             valid_find = 0;
13197             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13198                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13199             if (!$VMS_STATUS_SUCCESS(sts))
13200                 break;
13201
13202             /* with varying string, 1st word of buffer contains result length */
13203             rstr[rslt->length] = '\0';
13204
13205              /* Find where all the components are */
13206              v_sts = vms_split_path
13207                        (rstr,
13208                         &v_spec,
13209                         &v_len,
13210                         &r_spec,
13211                         &r_len,
13212                         &d_spec,
13213                         &d_len,
13214                         &n_spec,
13215                         &n_len,
13216                         &e_spec,
13217                         &e_len,
13218                         &vs_spec,
13219                         &vs_len);
13220
13221             /* If no version on input, truncate the version on output */
13222             if (!hasver && (vs_len > 0)) {
13223                 *vs_spec = '\0';
13224                 vs_len = 0;
13225             }
13226
13227             if (isunix) {
13228
13229                 /* In Unix report mode, remove the ".dir;1" from the name */
13230                 /* if it is a real directory */
13231                 if (decc_filename_unix_report && decc_efs_charset) {
13232                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13233                         Stat_t statbuf;
13234                         int ret_sts;
13235
13236                         ret_sts = flex_lstat(rstr, &statbuf);
13237                         if ((ret_sts == 0) &&
13238                             S_ISDIR(statbuf.st_mode)) {
13239                             e_len = 0;
13240                             e_spec[0] = 0;
13241                         }
13242                     }
13243                 }
13244
13245                 /* No version & a null extension on UNIX handling */
13246                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13247                     e_len = 0;
13248                     *e_spec = '\0';
13249                 }
13250             }
13251
13252             if (!decc_efs_case_preserve) {
13253                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13254             }
13255
13256             /* Find File treats a Null extension as return all extensions */
13257             /* This is contrary to Perl expectations */
13258
13259             if (wildstar || wildquery || vms_old_glob) {
13260                 /* really need to see if the returned file name matched */
13261                 /* but for now will assume that it matches */
13262                 valid_find = 1;
13263             } else {
13264                 /* Exact Match requested */
13265                 /* How are directories handled? - like a file */
13266                 if ((e_len == we_len) && (n_len == wn_len)) {
13267                     int t1;
13268                     t1 = e_len;
13269                     if (t1 > 0)
13270                         t1 = strncmp(e_spec, we_spec, e_len);
13271                     if (t1 == 0) {
13272                        t1 = n_len;
13273                        if (t1 > 0)
13274                            t1 = strncmp(n_spec, we_spec, n_len);
13275                        if (t1 == 0)
13276                            valid_find = 1;
13277                     }
13278                 }
13279             }
13280
13281             if (valid_find) {
13282                 found++;
13283
13284                 if (hasdir) {
13285                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13286                     begin = rstr;
13287                 }
13288                 else {
13289                     /* Start with the name */
13290                     begin = n_spec;
13291                 }
13292                 strcat(begin,"\n");
13293                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13294             }
13295         }
13296         if (cxt) (void)lib$find_file_end(&cxt);
13297
13298         if (!found) {
13299             /* Be POSIXish: return the input pattern when no matches */
13300             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13301             strcat(rstr,"\n");
13302             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13303         }
13304
13305         if (ok && sts != RMS$_NMF &&
13306             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13307         if (!ok) {
13308             if (!(sts & 1)) {
13309                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13310             }
13311             PerlIO_close(tmpfp);
13312             fp = NULL;
13313         }
13314         else {
13315             PerlIO_rewind(tmpfp);
13316             IoTYPE(io) = IoTYPE_RDONLY;
13317             IoIFP(io) = fp = tmpfp;
13318             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13319         }
13320     }
13321     Safefree(vmsspec);
13322     Safefree(rslt);
13323     return fp;
13324 }
13325
13326
13327 static char *
13328 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13329                    int *utf8_fl);
13330
13331 void
13332 unixrealpath_fromperl(pTHX_ CV *cv)
13333 {
13334     dXSARGS;
13335     char *fspec, *rslt_spec, *rslt;
13336     STRLEN n_a;
13337
13338     if (!items || items != 1)
13339         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13340
13341     fspec = SvPV(ST(0),n_a);
13342     if (!fspec || !*fspec) XSRETURN_UNDEF;
13343
13344     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13345     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13346
13347     ST(0) = sv_newmortal();
13348     if (rslt != NULL)
13349         sv_usepvn(ST(0),rslt,strlen(rslt));
13350     else
13351         Safefree(rslt_spec);
13352         XSRETURN(1);
13353 }
13354
13355 static char *
13356 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13357                    int *utf8_fl);
13358
13359 void
13360 vmsrealpath_fromperl(pTHX_ CV *cv)
13361 {
13362     dXSARGS;
13363     char *fspec, *rslt_spec, *rslt;
13364     STRLEN n_a;
13365
13366     if (!items || items != 1)
13367         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13368
13369     fspec = SvPV(ST(0),n_a);
13370     if (!fspec || !*fspec) XSRETURN_UNDEF;
13371
13372     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13373     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13374
13375     ST(0) = sv_newmortal();
13376     if (rslt != NULL)
13377         sv_usepvn(ST(0),rslt,strlen(rslt));
13378     else
13379         Safefree(rslt_spec);
13380         XSRETURN(1);
13381 }
13382
13383 #ifdef HAS_SYMLINK
13384 /*
13385  * A thin wrapper around decc$symlink to make sure we follow the
13386  * standard and do not create a symlink with a zero-length name,
13387  * and convert the target to Unix format, as the CRTL can't handle
13388  * targets in VMS format.
13389  */
13390 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13391 int
13392 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13393 {
13394     int sts;
13395     char * utarget;
13396
13397     if (!link_name || !*link_name) {
13398       SETERRNO(ENOENT, SS$_NOSUCHFILE);
13399       return -1;
13400     }
13401
13402     utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13403     /* An untranslatable filename should be passed through. */
13404     (void) int_tounixspec(contents, utarget, NULL);
13405     sts = symlink(utarget, link_name);
13406     PerlMem_free(utarget);
13407     return sts;
13408 }
13409 /*}}}*/
13410
13411 #endif /* HAS_SYMLINK */
13412
13413 int do_vms_case_tolerant(void);
13414
13415 void
13416 case_tolerant_process_fromperl(pTHX_ CV *cv)
13417 {
13418   dXSARGS;
13419   ST(0) = boolSV(do_vms_case_tolerant());
13420   XSRETURN(1);
13421 }
13422
13423 #ifdef USE_ITHREADS
13424
13425 void
13426 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13427                           struct interp_intern *dst)
13428 {
13429     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13430
13431     memcpy(dst,src,sizeof(struct interp_intern));
13432 }
13433
13434 #endif
13435
13436 void
13437 Perl_sys_intern_clear(pTHX)
13438 {
13439 }
13440
13441 void
13442 Perl_sys_intern_init(pTHX)
13443 {
13444     unsigned int ix = RAND_MAX;
13445     double x;
13446
13447     VMSISH_HUSHED = 0;
13448
13449     MY_POSIX_EXIT = vms_posix_exit;
13450
13451     x = (float)ix;
13452     MY_INV_RAND_MAX = 1./x;
13453 }
13454
13455 void
13456 init_os_extras(void)
13457 {
13458   dTHX;
13459   char* file = __FILE__;
13460   if (decc_disable_to_vms_logname_translation) {
13461     no_translate_barewords = TRUE;
13462   } else {
13463     no_translate_barewords = FALSE;
13464   }
13465
13466   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13467   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13468   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13469   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13470   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13471   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13472   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13473   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13474   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13475   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13476   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13477   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13478   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13479   newXSproto("VMS::Filespec::case_tolerant_process",
13480       case_tolerant_process_fromperl,file,"");
13481
13482   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13483
13484   return;
13485 }
13486
13487 #if __CRTL_VER == 80200000
13488 /* This missed getting in to the DECC SDK for 8.2 */
13489 char *realpath(const char *file_name, char * resolved_name, ...);
13490 #endif
13491
13492 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13493 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13494  * The perl fallback routine to provide realpath() is not as efficient
13495  * on OpenVMS.
13496  */
13497
13498 #ifdef __cplusplus
13499 extern "C" {
13500 #endif
13501
13502 /* Hack, use old stat() as fastest way of getting ino_t and device */
13503 int decc$stat(const char *name, void * statbuf);
13504 #if !defined(__VAX) && __CRTL_VER >= 80200000
13505 int decc$lstat(const char *name, void * statbuf);
13506 #else
13507 #define decc$lstat decc$stat
13508 #endif
13509
13510 #ifdef __cplusplus
13511 }
13512 #endif
13513
13514
13515 /* Realpath is fragile.  In 8.3 it does not work if the feature
13516  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13517  * links are implemented in RMS, not the CRTL. It also can fail if the
13518  * user does not have read/execute access to some of the directories.
13519  * So in order for Do What I Mean mode to work, if realpath() fails,
13520  * fall back to looking up the filename by the device name and FID.
13521  */
13522
13523 int vms_fid_to_name(char * outname, int outlen,
13524                     const char * name, int lstat_flag, mode_t * mode)
13525 {
13526 #pragma message save
13527 #pragma message disable MISALGNDSTRCT
13528 #pragma message disable MISALGNDMEM
13529 #pragma member_alignment save
13530 #pragma nomember_alignment
13531 struct statbuf_t {
13532     char           * st_dev;
13533     unsigned short st_ino[3];
13534     unsigned short old_st_mode;
13535     unsigned long  padl[30];  /* plenty of room */
13536 } statbuf;
13537 #pragma message restore
13538 #pragma member_alignment restore
13539
13540     int sts;
13541     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13542     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13543     char *fileified;
13544     char *temp_fspec;
13545     char *ret_spec;
13546
13547     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13548      * unexpected answers
13549      */
13550
13551     fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13552     if (fileified == NULL)
13553         _ckvmssts_noperl(SS$_INSFMEM);
13554
13555     temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13556     if (temp_fspec == NULL)
13557         _ckvmssts_noperl(SS$_INSFMEM);
13558
13559     sts = -1;
13560     /* First need to try as a directory */
13561     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13562     if (ret_spec != NULL) {
13563         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13564         if (ret_spec != NULL) {
13565             if (lstat_flag == 0)
13566                 sts = decc$stat(fileified, &statbuf);
13567             else
13568                 sts = decc$lstat(fileified, &statbuf);
13569         }
13570     }
13571
13572     /* Then as a VMS file spec */
13573     if (sts != 0) {
13574         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13575         if (ret_spec != NULL) {
13576             if (lstat_flag == 0) {
13577                 sts = decc$stat(temp_fspec, &statbuf);
13578             } else {
13579                 sts = decc$lstat(temp_fspec, &statbuf);
13580             }
13581         }
13582     }
13583
13584     if (sts) {
13585         /* Next try - allow multiple dots with out EFS CHARSET */
13586         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13587          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13588          * enable it if it isn't already.
13589          */
13590 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13591         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13592             decc$feature_set_value(decc_efs_charset_index, 1, 1);
13593 #endif
13594         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13595         if (lstat_flag == 0) {
13596             sts = decc$stat(name, &statbuf);
13597         } else {
13598             sts = decc$lstat(name, &statbuf);
13599         }
13600 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13601         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13602             decc$feature_set_value(decc_efs_charset_index, 1, 0);
13603 #endif
13604     }
13605
13606
13607     /* and then because the Perl Unix to VMS conversion is not perfect */
13608     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13609     /* characters from filenames so we need to try it as-is */
13610     if (sts) {
13611         if (lstat_flag == 0) {
13612             sts = decc$stat(name, &statbuf);
13613         } else {
13614             sts = decc$lstat(name, &statbuf);
13615         }
13616     }
13617
13618     if (sts == 0) {
13619         int vms_sts;
13620
13621         dvidsc.dsc$a_pointer=statbuf.st_dev;
13622         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13623
13624         specdsc.dsc$a_pointer = outname;
13625         specdsc.dsc$w_length = outlen-1;
13626
13627         vms_sts = lib$fid_to_name
13628             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13629         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13630             outname[specdsc.dsc$w_length] = 0;
13631
13632             /* Return the mode */
13633             if (mode) {
13634                 *mode = statbuf.old_st_mode;
13635             }
13636         }
13637     }
13638     PerlMem_free(temp_fspec);
13639     PerlMem_free(fileified);
13640     return sts;
13641 }
13642
13643
13644
13645 static char *
13646 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13647                    int *utf8_fl)
13648 {
13649     char * rslt = NULL;
13650
13651 #ifdef HAS_SYMLINK
13652     if (decc_posix_compliant_pathnames > 0 ) {
13653         /* realpath currently only works if posix compliant pathnames are
13654          * enabled.  It may start working when they are not, but in that
13655          * case we still want the fallback behavior for backwards compatibility
13656          */
13657         rslt = realpath(filespec, outbuf);
13658     }
13659 #endif
13660
13661     if (rslt == NULL) {
13662         char * vms_spec;
13663         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13664         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13665         mode_t my_mode;
13666
13667         /* Fall back to fid_to_name */
13668
13669         Newx(vms_spec, VMS_MAXRSS + 1, char);
13670
13671         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13672         if (sts == 0) {
13673
13674
13675             /* Now need to trim the version off */
13676             sts = vms_split_path
13677                   (vms_spec,
13678                    &v_spec,
13679                    &v_len,
13680                    &r_spec,
13681                    &r_len,
13682                    &d_spec,
13683                    &d_len,
13684                    &n_spec,
13685                    &n_len,
13686                    &e_spec,
13687                    &e_len,
13688                    &vs_spec,
13689                    &vs_len);
13690
13691
13692                 if (sts == 0) {
13693                     int haslower = 0;
13694                     const char *cp;
13695
13696                     /* Trim off the version */
13697                     int file_len = v_len + r_len + d_len + n_len + e_len;
13698                     vms_spec[file_len] = 0;
13699
13700                     /* Trim off the .DIR if this is a directory */
13701                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13702                         if (S_ISDIR(my_mode)) {
13703                             e_len = 0;
13704                             e_spec[0] = 0;
13705                         }
13706                     }
13707
13708                     /* Drop NULL extensions on UNIX file specification */
13709                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
13710                         e_len = 0;
13711                         e_spec[0] = '\0';
13712                     }
13713
13714                     /* The result is expected to be in UNIX format */
13715                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13716
13717                     /* Downcase if input had any lower case letters and
13718                      * case preservation is not in effect.
13719                      */
13720                     if (!decc_efs_case_preserve) {
13721                         for (cp = filespec; *cp; cp++)
13722                             if (islower(*cp)) { haslower = 1; break; }
13723
13724                         if (haslower) __mystrtolower(rslt);
13725                     }
13726                 }
13727         } else {
13728
13729             /* Now for some hacks to deal with backwards and forward */
13730             /* compatibility */
13731             if (!decc_efs_charset) {
13732
13733                 /* 1. ODS-2 mode wants to do a syntax only translation */
13734                 rslt = int_rmsexpand(filespec, outbuf,
13735                                     NULL, 0, NULL, utf8_fl);
13736
13737             } else {
13738                 if (decc_filename_unix_report) {
13739                     char * dir_name;
13740                     char * vms_dir_name;
13741                     char * file_name;
13742
13743                     /* 2. ODS-5 / UNIX report mode should return a failure */
13744                     /*    if the parent directory also does not exist */
13745                     /*    Otherwise, get the real path for the parent */
13746                     /*    and add the child to it. */
13747
13748                     /* basename / dirname only available for VMS 7.0+ */
13749                     /* So we may need to implement them as common routines */
13750
13751                     Newx(dir_name, VMS_MAXRSS + 1, char);
13752                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13753                     dir_name[0] = '\0';
13754                     file_name = NULL;
13755
13756                     /* First try a VMS parse */
13757                     sts = vms_split_path
13758                           (filespec,
13759                            &v_spec,
13760                            &v_len,
13761                            &r_spec,
13762                            &r_len,
13763                            &d_spec,
13764                            &d_len,
13765                            &n_spec,
13766                            &n_len,
13767                            &e_spec,
13768                            &e_len,
13769                            &vs_spec,
13770                            &vs_len);
13771
13772                     if (sts == 0) {
13773                         /* This is VMS */
13774
13775                         int dir_len = v_len + r_len + d_len + n_len;
13776                         if (dir_len > 0) {
13777                            memcpy(dir_name, filespec, dir_len);
13778                            dir_name[dir_len] = '\0';
13779                            file_name = (char *)&filespec[dir_len + 1];
13780                         }
13781                     } else {
13782                         /* This must be UNIX */
13783                         char * tchar;
13784
13785                         tchar = strrchr(filespec, '/');
13786
13787                         if (tchar != NULL) {
13788                             int dir_len = tchar - filespec;
13789                             memcpy(dir_name, filespec, dir_len);
13790                             dir_name[dir_len] = '\0';
13791                             file_name = (char *) &filespec[dir_len + 1];
13792                         }
13793                     }
13794
13795                     /* Dir name is defaulted */
13796                     if (dir_name[0] == 0) {
13797                         dir_name[0] = '.';
13798                         dir_name[1] = '\0';
13799                     }
13800
13801                     /* Need realpath for the directory */
13802                     sts = vms_fid_to_name(vms_dir_name,
13803                                           VMS_MAXRSS + 1,
13804                                           dir_name, 0, NULL);
13805
13806                     if (sts == 0) {
13807                         /* Now need to pathify it. */
13808                         char *tdir = int_pathify_dirspec(vms_dir_name,
13809                                                          outbuf);
13810
13811                         /* And now add the original filespec to it */
13812                         if (file_name != NULL) {
13813                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13814                         }
13815                         return outbuf;
13816                     }
13817                     Safefree(vms_dir_name);
13818                     Safefree(dir_name);
13819                 }
13820             }
13821         }
13822         Safefree(vms_spec);
13823     }
13824     return rslt;
13825 }
13826
13827 static char *
13828 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13829                    int *utf8_fl)
13830 {
13831     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13832     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13833
13834     /* Fall back to fid_to_name */
13835
13836     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13837     if (sts != 0) {
13838         return NULL;
13839     }
13840     else {
13841
13842
13843         /* Now need to trim the version off */
13844         sts = vms_split_path
13845                   (outbuf,
13846                    &v_spec,
13847                    &v_len,
13848                    &r_spec,
13849                    &r_len,
13850                    &d_spec,
13851                    &d_len,
13852                    &n_spec,
13853                    &n_len,
13854                    &e_spec,
13855                    &e_len,
13856                    &vs_spec,
13857                    &vs_len);
13858
13859
13860         if (sts == 0) {
13861             int haslower = 0;
13862             const char *cp;
13863
13864             /* Trim off the version */
13865             int file_len = v_len + r_len + d_len + n_len + e_len;
13866             outbuf[file_len] = 0;
13867
13868             /* Downcase if input had any lower case letters and
13869              * case preservation is not in effect.
13870              */
13871             if (!decc_efs_case_preserve) {
13872                 for (cp = filespec; *cp; cp++)
13873                     if (islower(*cp)) { haslower = 1; break; }
13874
13875                 if (haslower) __mystrtolower(outbuf);
13876             }
13877         }
13878     }
13879     return outbuf;
13880 }
13881
13882
13883 /*}}}*/
13884 /* External entry points */
13885 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13886 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13887
13888 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13889 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13890
13891 /* case_tolerant */
13892
13893 /*{{{int do_vms_case_tolerant(void)*/
13894 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13895  * controlled by a process setting.
13896  */
13897 int do_vms_case_tolerant(void)
13898 {
13899     return vms_process_case_tolerant;
13900 }
13901 /*}}}*/
13902 /* External entry points */
13903 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13904 int Perl_vms_case_tolerant(void)
13905 { return do_vms_case_tolerant(); }
13906 #else
13907 int Perl_vms_case_tolerant(void)
13908 { return vms_process_case_tolerant; }
13909 #endif
13910
13911
13912  /* Start of DECC RTL Feature handling */
13913
13914 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13915
13916 static int
13917 set_feature_default(const char *name, int value)
13918 {
13919     int status;
13920     int index;
13921     char val_str[10];
13922
13923     /* If the feature has been explicitly disabled in the environment,
13924      * then don't enable it here.
13925      */
13926     if (value > 0) {
13927         status = simple_trnlnm(name, val_str, sizeof(val_str));
13928         if (status) {
13929             val_str[0] = _toupper(val_str[0]);
13930             if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
13931                 return 0;
13932         }
13933     }
13934
13935     index = decc$feature_get_index(name);
13936
13937     status = decc$feature_set_value(index, 1, value);
13938     if (index == -1 || (status == -1)) {
13939       return -1;
13940     }
13941
13942     status = decc$feature_get_value(index, 1);
13943     if (status != value) {
13944       return -1;
13945     }
13946
13947     /* Various things may check for an environment setting
13948      * rather than the feature directly, so set that too.
13949      */
13950     vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13951
13952     return 0;
13953 }
13954 #endif
13955
13956
13957 /* C RTL Feature settings */
13958
13959 #if defined(__DECC) || defined(__DECCXX)
13960
13961 #ifdef __cplusplus
13962 extern "C" {
13963 #endif
13964
13965 extern void
13966 vmsperl_set_features(void)
13967 {
13968     int status;
13969     int s;
13970     char val_str[10];
13971 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13972     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13973     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13974     unsigned long case_perm;
13975     unsigned long case_image;
13976 #endif
13977
13978     /* Allow an exception to bring Perl into the VMS debugger */
13979     vms_debug_on_exception = 0;
13980     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13981     if (status) {
13982        val_str[0] = _toupper(val_str[0]);
13983        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13984          vms_debug_on_exception = 1;
13985        else
13986          vms_debug_on_exception = 0;
13987     }
13988
13989     /* Debug unix/vms file translation routines */
13990     vms_debug_fileify = 0;
13991     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13992     if (status) {
13993         val_str[0] = _toupper(val_str[0]);
13994         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13995             vms_debug_fileify = 1;
13996         else
13997             vms_debug_fileify = 0;
13998     }
13999
14000
14001     /* Historically PERL has been doing vmsify / stat differently than */
14002     /* the CRTL.  In particular, under some conditions the CRTL will   */
14003     /* remove some illegal characters like spaces from filenames       */
14004     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14005     /* been reporting such file names as invalid and fails to stat them */
14006     /* fixing this bug so that stat()/lstat() accept these like the     */
14007     /* CRTL does will result in several tests failing.                  */
14008     /* This should really be fixed, but for now, set up a feature to    */
14009     /* enable it so that the impact can be studied.                     */
14010     vms_bug_stat_filename = 0;
14011     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14012     if (status) {
14013         val_str[0] = _toupper(val_str[0]);
14014         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14015             vms_bug_stat_filename = 1;
14016         else
14017             vms_bug_stat_filename = 0;
14018     }
14019
14020
14021     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14022     vms_vtf7_filenames = 0;
14023     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14024     if (status) {
14025        val_str[0] = _toupper(val_str[0]);
14026        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14027          vms_vtf7_filenames = 1;
14028        else
14029          vms_vtf7_filenames = 0;
14030     }
14031
14032     /* unlink all versions on unlink() or rename() */
14033     vms_unlink_all_versions = 0;
14034     status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14035     if (status) {
14036        val_str[0] = _toupper(val_str[0]);
14037        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14038          vms_unlink_all_versions = 1;
14039        else
14040          vms_unlink_all_versions = 0;
14041     }
14042
14043 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14044     /* Detect running under GNV Bash or other UNIX like shell */
14045     gnv_unix_shell = 0;
14046     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14047     if (status) {
14048          gnv_unix_shell = 1;
14049          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14050          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14051          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14052          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14053          vms_unlink_all_versions = 1;
14054          vms_posix_exit = 1;
14055          /* Reverse default ordering of PERL_ENV_TABLES. */
14056          defenv[0] = &crtlenvdsc;
14057          defenv[1] = &fildevdsc;
14058     }
14059     /* Some reasonable defaults that are not CRTL defaults */
14060     set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14061     set_feature_default("DECC$ARGV_PARSE_STYLE", 1);     /* Requires extended parse. */
14062     set_feature_default("DECC$EFS_CHARSET", 1);
14063 #endif
14064
14065     /* hacks to see if known bugs are still present for testing */
14066
14067     /* PCP mode requires creating /dev/null special device file */
14068     decc_bug_devnull = 0;
14069     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14070     if (status) {
14071        val_str[0] = _toupper(val_str[0]);
14072        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14073           decc_bug_devnull = 1;
14074        else
14075           decc_bug_devnull = 0;
14076     }
14077
14078 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14079     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14080     if (s >= 0) {
14081         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14082         if (decc_disable_to_vms_logname_translation < 0)
14083             decc_disable_to_vms_logname_translation = 0;
14084     }
14085
14086     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14087     if (s >= 0) {
14088         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14089         if (decc_efs_case_preserve < 0)
14090             decc_efs_case_preserve = 0;
14091     }
14092
14093     s = decc$feature_get_index("DECC$EFS_CHARSET");
14094     decc_efs_charset_index = s;
14095     if (s >= 0) {
14096         decc_efs_charset = decc$feature_get_value(s, 1);
14097         if (decc_efs_charset < 0)
14098             decc_efs_charset = 0;
14099     }
14100
14101     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14102     if (s >= 0) {
14103         decc_filename_unix_report = decc$feature_get_value(s, 1);
14104         if (decc_filename_unix_report > 0) {
14105             decc_filename_unix_report = 1;
14106             vms_posix_exit = 1;
14107         }
14108         else
14109             decc_filename_unix_report = 0;
14110     }
14111
14112     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14113     if (s >= 0) {
14114         decc_filename_unix_only = decc$feature_get_value(s, 1);
14115         if (decc_filename_unix_only > 0) {
14116             decc_filename_unix_only = 1;
14117         }
14118         else {
14119             decc_filename_unix_only = 0;
14120         }
14121     }
14122
14123     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14124     if (s >= 0) {
14125         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14126         if (decc_filename_unix_no_version < 0)
14127             decc_filename_unix_no_version = 0;
14128     }
14129
14130     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14131     if (s >= 0) {
14132         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14133         if (decc_readdir_dropdotnotype < 0)
14134             decc_readdir_dropdotnotype = 0;
14135     }
14136
14137 #if __CRTL_VER >= 80200000
14138     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14139     if (s >= 0) {
14140         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14141         if (decc_posix_compliant_pathnames < 0)
14142             decc_posix_compliant_pathnames = 0;
14143         if (decc_posix_compliant_pathnames > 4)
14144             decc_posix_compliant_pathnames = 0;
14145     }
14146
14147 #endif
14148 #else
14149     status = simple_trnlnm
14150         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14151     if (status) {
14152         val_str[0] = _toupper(val_str[0]);
14153         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14154            decc_disable_to_vms_logname_translation = 1;
14155         }
14156     }
14157
14158 #ifndef __VAX
14159     status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14160     if (status) {
14161         val_str[0] = _toupper(val_str[0]);
14162         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14163            decc_efs_case_preserve = 1;
14164         }
14165     }
14166 #endif
14167
14168     status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14169     if (status) {
14170         val_str[0] = _toupper(val_str[0]);
14171         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14172            decc_filename_unix_report = 1;
14173         }
14174     }
14175     status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14176     if (status) {
14177         val_str[0] = _toupper(val_str[0]);
14178         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14179            decc_filename_unix_only = 1;
14180            decc_filename_unix_report = 1;
14181         }
14182     }
14183     status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14184     if (status) {
14185         val_str[0] = _toupper(val_str[0]);
14186         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14187            decc_filename_unix_no_version = 1;
14188         }
14189     }
14190     status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14191     if (status) {
14192         val_str[0] = _toupper(val_str[0]);
14193         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14194            decc_readdir_dropdotnotype = 1;
14195         }
14196     }
14197 #endif
14198
14199 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14200
14201      /* Report true case tolerance */
14202     /*----------------------------*/
14203     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14204     if (!$VMS_STATUS_SUCCESS(status))
14205         case_perm = PPROP$K_CASE_BLIND;
14206     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14207     if (!$VMS_STATUS_SUCCESS(status))
14208         case_image = PPROP$K_CASE_BLIND;
14209     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14210         (case_image == PPROP$K_CASE_SENSITIVE))
14211         vms_process_case_tolerant = 0;
14212
14213 #endif
14214
14215     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14216     /* for strict backward compatibility */
14217     status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14218     if (status) {
14219        val_str[0] = _toupper(val_str[0]);
14220        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14221          vms_posix_exit = 1;
14222        else
14223          vms_posix_exit = 0;
14224     }
14225 }
14226
14227 /* Use 32-bit pointers because that's what the image activator
14228  * assumes for the LIB$INITIALZE psect.
14229  */
14230 #if __INITIAL_POINTER_SIZE
14231 #pragma pointer_size save
14232 #pragma pointer_size 32
14233 #endif
14234
14235 /* Create a reference to the LIB$INITIALIZE function. */
14236 extern void LIB$INITIALIZE(void);
14237 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14238
14239 /* Create an array of pointers to the init functions in the special
14240  * LIB$INITIALIZE section. In our case, the array only has one entry.
14241  */
14242 #pragma extern_model save
14243 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
14244 extern void (* const vmsperl_unused_global_2[])() =
14245 {
14246    vmsperl_set_features,
14247 };
14248 #pragma extern_model restore
14249
14250 #if __INITIAL_POINTER_SIZE
14251 #pragma pointer_size restore
14252 #endif
14253
14254 #ifdef __cplusplus
14255 }
14256 #endif
14257
14258 #endif /* defined(__DECC) || defined(__DECCXX) */
14259 /*  End of vms.c */