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 -- unescape it. */
7098         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added) - 1;
7099         cp1 += outchars_added;
7100     }
7101     else if (*cp2 == ':') {
7102       *(cp1++) = '/';
7103       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7104     }
7105     else if (*cp2 == ']' || *cp2 == '>') {
7106       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7107     }
7108     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7109       *(cp1++) = '/';
7110       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7111         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7112                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7113         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7114             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7115       }
7116       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7117         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7118         cp2 += 2;
7119       }
7120     }
7121     else if (*cp2 == '-') {
7122       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7123         while (*cp2 == '-') {
7124           cp2++;
7125           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7126         }
7127         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7128                                                          /* filespecs like */
7129           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7130           if (vms_debug_fileify) {
7131               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7132           }
7133           return NULL;
7134         }
7135       }
7136       else *(cp1++) = *cp2;
7137     }
7138     else *(cp1++) = *cp2;
7139   }
7140   /* Translate the rest of the filename. */
7141   while (*cp2) {
7142       int dot_seen = 0;
7143       switch(*cp2) {
7144       /* Fixme - for compatibility with the CRTL we should be removing */
7145       /* spaces from the file specifications, but this may show that */
7146       /* some tests that were appearing to pass are not really passing */
7147       case '%':
7148           cp2++;
7149           *(cp1++) = '?';
7150           break;
7151       case '^':
7152           cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7153           cp1 += outchars_added;
7154           break;
7155       case ';':
7156           if (decc_filename_unix_no_version) {
7157               /* Easy, drop the version */
7158               while (*cp2)
7159                   cp2++;
7160               break;
7161           } else {
7162               /* Punt - passing the version as a dot will probably */
7163               /* break perl in weird ways, but so did passing */
7164               /* through the ; as a version.  Follow the CRTL and */
7165               /* hope for the best. */
7166               cp2++;
7167               *(cp1++) = '.';
7168           }
7169           break;
7170       case '.':
7171           if (dot_seen) {
7172               /* We will need to fix this properly later */
7173               /* As Perl may be installed on an ODS-5 volume, but not */
7174               /* have the EFS_CHARSET enabled, it still may encounter */
7175               /* filenames with extra dots in them, and a precedent got */
7176               /* set which allowed them to work, that we will uphold here */
7177               /* If extra dots are present in a name and no ^ is on them */
7178               /* VMS assumes that the first one is the extension delimiter */
7179               /* the rest have an implied ^. */
7180
7181               /* this is also a conflict as the . is also a version */
7182               /* delimiter in VMS, */
7183
7184               *(cp1++) = *(cp2++);
7185               break;
7186           }
7187           dot_seen = 1;
7188           /* This is an extension */
7189           if (decc_readdir_dropdotnotype) {
7190               cp2++;
7191               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7192                   /* Drop the dot for the extension */
7193                   break;
7194               } else {
7195                   *(cp1++) = '.';
7196               }
7197               break;
7198           }
7199       default:
7200           *(cp1++) = *(cp2++);
7201       }
7202   }
7203   *cp1 = '\0';
7204
7205   /* This still leaves /000000/ when working with a
7206    * VMS device root or concealed root.
7207    */
7208   {
7209   int ulen;
7210   char * zeros;
7211
7212       ulen = strlen(rslt);
7213
7214       /* Get rid of "000000/ in rooted filespecs */
7215       if (ulen > 7) {
7216         zeros = strstr(rslt, "/000000/");
7217         if (zeros != NULL) {
7218           int mlen;
7219           mlen = ulen - (zeros - rslt) - 7;
7220           memmove(zeros, &zeros[7], mlen);
7221           ulen = ulen - 7;
7222           rslt[ulen] = '\0';
7223         }
7224       }
7225   }
7226
7227   if (vms_debug_fileify) {
7228       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7229   }
7230   return rslt;
7231
7232 }  /* end of int_tounixspec() */
7233
7234
7235 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7236 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7237 {
7238     static char __tounixspec_retbuf[VMS_MAXRSS];
7239     char * unixspec, *ret_spec, *ret_buf;
7240
7241     unixspec = NULL;
7242     ret_buf = buf;
7243     if (ret_buf == NULL) {
7244         if (ts) {
7245             Newx(unixspec, VMS_MAXRSS, char);
7246             if (unixspec == NULL)
7247                 _ckvmssts(SS$_INSFMEM);
7248             ret_buf = unixspec;
7249         } else {
7250             ret_buf = __tounixspec_retbuf;
7251         }
7252     }
7253
7254     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7255
7256     if (ret_spec == NULL) {
7257        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7258        if (unixspec)
7259            Safefree(unixspec);
7260     }
7261
7262     return ret_spec;
7263
7264 }  /* end of do_tounixspec() */
7265 /*}}}*/
7266 /* External entry points */
7267 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7268   { return do_tounixspec(spec,buf,0, NULL); }
7269 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7270   { return do_tounixspec(spec,buf,1, NULL); }
7271 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7272   { return do_tounixspec(spec,buf,0, utf8_fl); }
7273 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7274   { return do_tounixspec(spec,buf,1, utf8_fl); }
7275
7276 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7277
7278 /*
7279  This procedure is used to identify if a path is based in either
7280  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7281  it returns the OpenVMS format directory for it.
7282
7283  It is expecting specifications of only '/' or '/xxxx/'
7284
7285  If a posix root does not exist, or 'xxxx' is not a directory
7286  in the posix root, it returns a failure.
7287
7288  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7289
7290  It is used only internally by posix_to_vmsspec_hardway().
7291  */
7292
7293 static int posix_root_to_vms
7294   (char *vmspath, int vmspath_len,
7295    const char *unixpath,
7296    const int * utf8_fl)
7297 {
7298 int sts;
7299 struct FAB myfab = cc$rms_fab;
7300 rms_setup_nam(mynam);
7301 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7302 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7303 char * esa, * esal, * rsa, * rsal;
7304 int dir_flag;
7305 int unixlen;
7306
7307     dir_flag = 0;
7308     vmspath[0] = '\0';
7309     unixlen = strlen(unixpath);
7310     if (unixlen == 0) {
7311       return RMS$_FNF;
7312     }
7313
7314 #if __CRTL_VER >= 80200000
7315   /* If not a posix spec already, convert it */
7316   if (decc_posix_compliant_pathnames) {
7317     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7318       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7319     }
7320     else {
7321       /* This is already a VMS specification, no conversion */
7322       unixlen--;
7323       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7324     }
7325   }
7326   else
7327 #endif
7328   {
7329   int path_len;
7330   int i,j;
7331
7332      /* Check to see if this is under the POSIX root */
7333      if (decc_disable_posix_root) {
7334         return RMS$_FNF;
7335      }
7336
7337      /* Skip leading / */
7338      if (unixpath[0] == '/') {
7339         unixpath++;
7340         unixlen--;
7341      }
7342
7343
7344      strcpy(vmspath,"SYS$POSIX_ROOT:");
7345
7346      /* If this is only the / , or blank, then... */
7347      if (unixpath[0] == '\0') {
7348         /* by definition, this is the answer */
7349         return SS$_NORMAL;
7350      }
7351
7352      /* Need to look up a directory */
7353      vmspath[15] = '[';
7354      vmspath[16] = '\0';
7355
7356      /* Copy and add '^' escape characters as needed */
7357      j = 16;
7358      i = 0;
7359      while (unixpath[i] != 0) {
7360      int k;
7361
7362         j += copy_expand_unix_filename_escape
7363             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7364         i += k;
7365      }
7366
7367      path_len = strlen(vmspath);
7368      if (vmspath[path_len - 1] == '/')
7369         path_len--;
7370      vmspath[path_len] = ']';
7371      path_len++;
7372      vmspath[path_len] = '\0';
7373
7374   }
7375   vmspath[vmspath_len] = 0;
7376   if (unixpath[unixlen - 1] == '/')
7377   dir_flag = 1;
7378   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7379   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7380   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7381   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7382   rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7383   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7384   rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7385   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7386   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7387   rms_bind_fab_nam(myfab, mynam);
7388   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7389   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7390   if (decc_efs_case_preserve)
7391     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7392 #ifdef NAML$M_OPEN_SPECIAL
7393   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7394 #endif
7395
7396   /* Set up the remaining naml fields */
7397   sts = sys$parse(&myfab);
7398
7399   /* It failed! Try again as a UNIX filespec */
7400   if (!(sts & 1)) {
7401     PerlMem_free(esal);
7402     PerlMem_free(esa);
7403     PerlMem_free(rsal);
7404     PerlMem_free(rsa);
7405     return sts;
7406   }
7407
7408    /* get the Device ID and the FID */
7409    sts = sys$search(&myfab);
7410
7411    /* These are no longer needed */
7412    PerlMem_free(esa);
7413    PerlMem_free(rsal);
7414    PerlMem_free(rsa);
7415
7416    /* on any failure, returned the POSIX ^UP^ filespec */
7417    if (!(sts & 1)) {
7418       PerlMem_free(esal);
7419       return sts;
7420    }
7421    specdsc.dsc$a_pointer = vmspath;
7422    specdsc.dsc$w_length = vmspath_len;
7423
7424    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7425    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7426    sts = lib$fid_to_name
7427       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7428
7429   /* on any failure, returned the POSIX ^UP^ filespec */
7430   if (!(sts & 1)) {
7431      /* This can happen if user does not have permission to read directories */
7432      if (strncmp(unixpath,"\"^UP^",5) != 0)
7433        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7434      else
7435        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7436   }
7437   else {
7438     vmspath[specdsc.dsc$w_length] = 0;
7439
7440     /* Are we expecting a directory? */
7441     if (dir_flag != 0) {
7442     int i;
7443     char *eptr;
7444
7445       eptr = NULL;
7446
7447       i = specdsc.dsc$w_length - 1;
7448       while (i > 0) {
7449       int zercnt;
7450         zercnt = 0;
7451         /* Version must be '1' */
7452         if (vmspath[i--] != '1')
7453           break;
7454         /* Version delimiter is one of ".;" */
7455         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7456           break;
7457         i--;
7458         if (vmspath[i--] != 'R')
7459           break;
7460         if (vmspath[i--] != 'I')
7461           break;
7462         if (vmspath[i--] != 'D')
7463           break;
7464         if (vmspath[i--] != '.')
7465           break;
7466         eptr = &vmspath[i+1];
7467         while (i > 0) {
7468           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7469             if (vmspath[i-1] != '^') {
7470               if (zercnt != 6) {
7471                 *eptr = vmspath[i];
7472                 eptr[1] = '\0';
7473                 vmspath[i] = '.';
7474                 break;
7475               }
7476               else {
7477                 /* Get rid of 6 imaginary zero directory filename */
7478                 vmspath[i+1] = '\0';
7479               }
7480             }
7481           }
7482           if (vmspath[i] == '0')
7483             zercnt++;
7484           else
7485             zercnt = 10;
7486           i--;
7487         }
7488         break;
7489       }
7490     }
7491   }
7492   PerlMem_free(esal);
7493   return sts;
7494 }
7495
7496 /* /dev/mumble needs to be handled special.
7497    /dev/null becomes NLA0:, And there is the potential for other stuff
7498    like /dev/tty which may need to be mapped to something.
7499 */
7500
7501 static int
7502 slash_dev_special_to_vms
7503    (const char * unixptr,
7504     char * vmspath,
7505     int vmspath_len)
7506 {
7507 char * nextslash;
7508 int len;
7509 int cmp;
7510
7511     unixptr += 4;
7512     nextslash = strchr(unixptr, '/');
7513     len = strlen(unixptr);
7514     if (nextslash != NULL)
7515         len = nextslash - unixptr;
7516     cmp = strncmp("null", unixptr, 5);
7517     if (cmp == 0) {
7518         if (vmspath_len >= 6) {
7519             strcpy(vmspath, "_NLA0:");
7520             return SS$_NORMAL;
7521         }
7522     }
7523     return 0;
7524 }
7525
7526
7527 /* The built in routines do not understand perl's special needs, so
7528     doing a manual conversion from UNIX to VMS
7529
7530     If the utf8_fl is not null and points to a non-zero value, then
7531     treat 8 bit characters as UTF-8.
7532
7533     The sequence starting with '$(' and ending with ')' will be passed
7534     through with out interpretation instead of being escaped.
7535
7536   */
7537 static int posix_to_vmsspec_hardway
7538   (char *vmspath, int vmspath_len,
7539    const char *unixpath,
7540    int dir_flag,
7541    int * utf8_fl) {
7542
7543 char *esa;
7544 const char *unixptr;
7545 const char *unixend;
7546 char *vmsptr;
7547 const char *lastslash;
7548 const char *lastdot;
7549 int unixlen;
7550 int vmslen;
7551 int dir_start;
7552 int dir_dot;
7553 int quoted;
7554 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7555 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7556
7557   if (utf8_fl != NULL)
7558     *utf8_fl = 0;
7559
7560   unixptr = unixpath;
7561   dir_dot = 0;
7562
7563   /* Ignore leading "/" characters */
7564   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7565     unixptr++;
7566   }
7567   unixlen = strlen(unixptr);
7568
7569   /* Do nothing with blank paths */
7570   if (unixlen == 0) {
7571     vmspath[0] = '\0';
7572     return SS$_NORMAL;
7573   }
7574
7575   quoted = 0;
7576   /* This could have a "^UP^ on the front */
7577   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7578     quoted = 1;
7579     unixptr+= 5;
7580     unixlen-= 5;
7581   }
7582
7583   lastslash = strrchr(unixptr,'/');
7584   lastdot = strrchr(unixptr,'.');
7585   unixend = strrchr(unixptr,'\"');
7586   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7587     unixend = unixptr + unixlen;
7588   }
7589
7590   /* last dot is last dot or past end of string */
7591   if (lastdot == NULL)
7592     lastdot = unixptr + unixlen;
7593
7594   /* if no directories, set last slash to beginning of string */
7595   if (lastslash == NULL) {
7596     lastslash = unixptr;
7597   }
7598   else {
7599     /* Watch out for trailing "." after last slash, still a directory */
7600     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7601       lastslash = unixptr + unixlen;
7602     }
7603
7604     /* Watch out for trailing ".." after last slash, still a directory */
7605     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7606       lastslash = unixptr + unixlen;
7607     }
7608
7609     /* dots in directories are aways escaped */
7610     if (lastdot < lastslash)
7611       lastdot = unixptr + unixlen;
7612   }
7613
7614   /* if (unixptr < lastslash) then we are in a directory */
7615
7616   dir_start = 0;
7617
7618   vmsptr = vmspath;
7619   vmslen = 0;
7620
7621   /* Start with the UNIX path */
7622   if (*unixptr != '/') {
7623     /* relative paths */
7624
7625     /* If allowing logical names on relative pathnames, then handle here */
7626     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7627         !decc_posix_compliant_pathnames) {
7628     char * nextslash;
7629     int seg_len;
7630     char * trn;
7631     int islnm;
7632
7633         /* Find the next slash */
7634         nextslash = strchr(unixptr,'/');
7635
7636         esa = (char *)PerlMem_malloc(vmspath_len);
7637         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7638
7639         trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7640         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7641
7642         if (nextslash != NULL) {
7643
7644             seg_len = nextslash - unixptr;
7645             memcpy(esa, unixptr, seg_len);
7646             esa[seg_len] = 0;
7647         }
7648         else {
7649             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7650         }
7651         /* trnlnm(section) */
7652         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7653
7654         if (islnm) {
7655             /* Now fix up the directory */
7656
7657             /* Split up the path to find the components */
7658             sts = vms_split_path
7659                   (trn,
7660                    &v_spec,
7661                    &v_len,
7662                    &r_spec,
7663                    &r_len,
7664                    &d_spec,
7665                    &d_len,
7666                    &n_spec,
7667                    &n_len,
7668                    &e_spec,
7669                    &e_len,
7670                    &vs_spec,
7671                    &vs_len);
7672
7673             while (sts == 0) {
7674             int cmp;
7675
7676                 /* A logical name must be a directory  or the full
7677                    specification.  It is only a full specification if
7678                    it is the only component */
7679                 if ((unixptr[seg_len] == '\0') ||
7680                     (unixptr[seg_len+1] == '\0')) {
7681
7682                     /* Is a directory being required? */
7683                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7684                         /* Not a logical name */
7685                         break;
7686                     }
7687
7688
7689                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7690                         /* This must be a directory */
7691                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7692                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7693                             vmsptr[vmslen] = ':';
7694                             vmslen++;
7695                             vmsptr[vmslen] = '\0';
7696                             return SS$_NORMAL;
7697                         }
7698                     }
7699
7700                 }
7701
7702
7703                 /* must be dev/directory - ignore version */
7704                 if ((n_len + e_len) != 0)
7705                     break;
7706
7707                 /* transfer the volume */
7708                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7709                     memcpy(vmsptr, v_spec, v_len);
7710                     vmsptr += v_len;
7711                     vmsptr[0] = '\0';
7712                     vmslen += v_len;
7713                 }
7714
7715                 /* unroot the rooted directory */
7716                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7717                     r_spec[0] = '[';
7718                     r_spec[r_len - 1] = ']';
7719
7720                     /* This should not be there, but nothing is perfect */
7721                     if (r_len > 9) {
7722                         cmp = strcmp(&r_spec[1], "000000.");
7723                         if (cmp == 0) {
7724                             r_spec += 7;
7725                             r_spec[7] = '[';
7726                             r_len -= 7;
7727                             if (r_len == 2)
7728                                 r_len = 0;
7729                         }
7730                     }
7731                     if (r_len > 0) {
7732                         memcpy(vmsptr, r_spec, r_len);
7733                         vmsptr += r_len;
7734                         vmslen += r_len;
7735                         vmsptr[0] = '\0';
7736                     }
7737                 }
7738                 /* Bring over the directory. */
7739                 if ((d_len > 0) &&
7740                     ((d_len + vmslen) < vmspath_len)) {
7741                     d_spec[0] = '[';
7742                     d_spec[d_len - 1] = ']';
7743                     if (d_len > 9) {
7744                         cmp = strcmp(&d_spec[1], "000000.");
7745                         if (cmp == 0) {
7746                             d_spec += 7;
7747                             d_spec[7] = '[';
7748                             d_len -= 7;
7749                             if (d_len == 2)
7750                                 d_len = 0;
7751                         }
7752                     }
7753
7754                     if (r_len > 0) {
7755                         /* Remove the redundant root */
7756                         if (r_len > 0) {
7757                             /* remove the ][ */
7758                             vmsptr--;
7759                             vmslen--;
7760                             d_spec++;
7761                             d_len--;
7762                         }
7763                         memcpy(vmsptr, d_spec, d_len);
7764                             vmsptr += d_len;
7765                             vmslen += d_len;
7766                             vmsptr[0] = '\0';
7767                     }
7768                 }
7769                 break;
7770             }
7771         }
7772
7773         PerlMem_free(esa);
7774         PerlMem_free(trn);
7775     }
7776
7777     if (lastslash > unixptr) {
7778     int dotdir_seen;
7779
7780       /* skip leading ./ */
7781       dotdir_seen = 0;
7782       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7783         dotdir_seen = 1;
7784         unixptr++;
7785         unixptr++;
7786       }
7787
7788       /* Are we still in a directory? */
7789       if (unixptr <= lastslash) {
7790         *vmsptr++ = '[';
7791         vmslen = 1;
7792         dir_start = 1;
7793
7794         /* if not backing up, then it is relative forward. */
7795         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7796               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7797           *vmsptr++ = '.';
7798           vmslen++;
7799           dir_dot = 1;
7800           }
7801        }
7802        else {
7803          if (dotdir_seen) {
7804            /* Perl wants an empty directory here to tell the difference
7805             * between a DCL command and a filename
7806             */
7807           *vmsptr++ = '[';
7808           *vmsptr++ = ']';
7809           vmslen = 2;
7810         }
7811       }
7812     }
7813     else {
7814       /* Handle two special files . and .. */
7815       if (unixptr[0] == '.') {
7816         if (&unixptr[1] == unixend) {
7817           *vmsptr++ = '[';
7818           *vmsptr++ = ']';
7819           vmslen += 2;
7820           *vmsptr++ = '\0';
7821           return SS$_NORMAL;
7822         }
7823         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7824           *vmsptr++ = '[';
7825           *vmsptr++ = '-';
7826           *vmsptr++ = ']';
7827           vmslen += 3;
7828           *vmsptr++ = '\0';
7829           return SS$_NORMAL;
7830         }
7831       }
7832     }
7833   }
7834   else {        /* Absolute PATH handling */
7835   int sts;
7836   char * nextslash;
7837   int seg_len;
7838     /* Need to find out where root is */
7839
7840     /* In theory, this procedure should never get an absolute POSIX pathname
7841      * that can not be found on the POSIX root.
7842      * In practice, that can not be relied on, and things will show up
7843      * here that are a VMS device name or concealed logical name instead.
7844      * So to make things work, this procedure must be tolerant.
7845      */
7846     esa = (char *)PerlMem_malloc(vmspath_len);
7847     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7848
7849     sts = SS$_NORMAL;
7850     nextslash = strchr(&unixptr[1],'/');
7851     seg_len = 0;
7852     if (nextslash != NULL) {
7853       int cmp;
7854       seg_len = nextslash - &unixptr[1];
7855       my_strlcpy(vmspath, unixptr, seg_len + 2);
7856       cmp = 1;
7857       if (seg_len == 3) {
7858         cmp = strncmp(vmspath, "dev", 4);
7859         if (cmp == 0) {
7860             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7861             if (sts == SS$_NORMAL)
7862                 return SS$_NORMAL;
7863         }
7864       }
7865       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7866     }
7867
7868     if ($VMS_STATUS_SUCCESS(sts)) {
7869       /* This is verified to be a real path */
7870
7871       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7872       if ($VMS_STATUS_SUCCESS(sts)) {
7873         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
7874         vmsptr = vmspath + vmslen;
7875         unixptr++;
7876         if (unixptr < lastslash) {
7877         char * rptr;
7878           vmsptr--;
7879           *vmsptr++ = '.';
7880           dir_start = 1;
7881           dir_dot = 1;
7882           if (vmslen > 7) {
7883           int cmp;
7884             rptr = vmsptr - 7;
7885             cmp = strcmp(rptr,"000000.");
7886             if (cmp == 0) {
7887               vmslen -= 7;
7888               vmsptr -= 7;
7889               vmsptr[1] = '\0';
7890             } /* removing 6 zeros */
7891           } /* vmslen < 7, no 6 zeros possible */
7892         } /* Not in a directory */
7893       } /* Posix root found */
7894       else {
7895         /* No posix root, fall back to default directory */
7896         strcpy(vmspath, "SYS$DISK:[");
7897         vmsptr = &vmspath[10];
7898         vmslen = 10;
7899         if (unixptr > lastslash) {
7900            *vmsptr = ']';
7901            vmsptr++;
7902            vmslen++;
7903         }
7904         else {
7905            dir_start = 1;
7906         }
7907       }
7908     } /* end of verified real path handling */
7909     else {
7910     int add_6zero;
7911     int islnm;
7912
7913       /* Ok, we have a device or a concealed root that is not in POSIX
7914        * or we have garbage.  Make the best of it.
7915        */
7916
7917       /* Posix to VMS destroyed this, so copy it again */
7918       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
7919       vmslen = strlen(vmspath); /* We know we're truncating. */
7920       vmsptr = &vmsptr[vmslen];
7921       islnm = 0;
7922
7923       /* Now do we need to add the fake 6 zero directory to it? */
7924       add_6zero = 1;
7925       if ((*lastslash == '/') && (nextslash < lastslash)) {
7926         /* No there is another directory */
7927         add_6zero = 0;
7928       }
7929       else {
7930       int trnend;
7931       int cmp;
7932
7933         /* now we have foo:bar or foo:[000000]bar to decide from */
7934         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7935
7936         if (!islnm && !decc_posix_compliant_pathnames) {
7937
7938             cmp = strncmp("bin", vmspath, 4);
7939             if (cmp == 0) {
7940                 /* bin => SYS$SYSTEM: */
7941                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7942             }
7943             else {
7944                 /* tmp => SYS$SCRATCH: */
7945                 cmp = strncmp("tmp", vmspath, 4);
7946                 if (cmp == 0) {
7947                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7948                 }
7949             }
7950         }
7951
7952         trnend = islnm ? islnm - 1 : 0;
7953
7954         /* if this was a logical name, ']' or '>' must be present */
7955         /* if not a logical name, then assume a device and hope. */
7956         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7957
7958         /* if log name and trailing '.' then rooted - treat as device */
7959         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7960
7961         /* Fix me, if not a logical name, a device lookup should be
7962          * done to see if the device is file structured.  If the device
7963          * is not file structured, the 6 zeros should not be put on.
7964          *
7965          * As it is, perl is occasionally looking for dev:[000000]tty.
7966          * which looks a little strange.
7967          *
7968          * Not that easy to detect as "/dev" may be file structured with
7969          * special device files.
7970          */
7971
7972         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
7973             (&nextslash[1] == unixend)) {
7974           /* No real directory present */
7975           add_6zero = 1;
7976         }
7977       }
7978
7979       /* Put the device delimiter on */
7980       *vmsptr++ = ':';
7981       vmslen++;
7982       unixptr = nextslash;
7983       unixptr++;
7984
7985       /* Start directory if needed */
7986       if (!islnm || add_6zero) {
7987         *vmsptr++ = '[';
7988         vmslen++;
7989         dir_start = 1;
7990       }
7991
7992       /* add fake 000000] if needed */
7993       if (add_6zero) {
7994         *vmsptr++ = '0';
7995         *vmsptr++ = '0';
7996         *vmsptr++ = '0';
7997         *vmsptr++ = '0';
7998         *vmsptr++ = '0';
7999         *vmsptr++ = '0';
8000         *vmsptr++ = ']';
8001         vmslen += 7;
8002         dir_start = 0;
8003       }
8004
8005     } /* non-POSIX translation */
8006     PerlMem_free(esa);
8007   } /* End of relative/absolute path handling */
8008
8009   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8010   int dash_flag;
8011   int in_cnt;
8012   int out_cnt;
8013
8014     dash_flag = 0;
8015
8016     if (dir_start != 0) {
8017
8018       /* First characters in a directory are handled special */
8019       while ((*unixptr == '/') ||
8020              ((*unixptr == '.') &&
8021               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8022                 (&unixptr[1]==unixend)))) {
8023       int loop_flag;
8024
8025         loop_flag = 0;
8026
8027         /* Skip redundant / in specification */
8028         while ((*unixptr == '/') && (dir_start != 0)) {
8029           loop_flag = 1;
8030           unixptr++;
8031           if (unixptr == lastslash)
8032             break;
8033         }
8034         if (unixptr == lastslash)
8035           break;
8036
8037         /* Skip redundant ./ characters */
8038         while ((*unixptr == '.') &&
8039                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8040           loop_flag = 1;
8041           unixptr++;
8042           if (unixptr == lastslash)
8043             break;
8044           if (*unixptr == '/')
8045             unixptr++;
8046         }
8047         if (unixptr == lastslash)
8048           break;
8049
8050         /* Skip redundant ../ characters */
8051         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8052              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8053           /* Set the backing up flag */
8054           loop_flag = 1;
8055           dir_dot = 0;
8056           dash_flag = 1;
8057           *vmsptr++ = '-';
8058           vmslen++;
8059           unixptr++; /* first . */
8060           unixptr++; /* second . */
8061           if (unixptr == lastslash)
8062             break;
8063           if (*unixptr == '/') /* The slash */
8064             unixptr++;
8065         }
8066         if (unixptr == lastslash)
8067           break;
8068
8069         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8070         /* Not needed when VMS is pretending to be UNIX. */
8071
8072         /* Is this loop stuck because of too many dots? */
8073         if (loop_flag == 0) {
8074           /* Exit the loop and pass the rest through */
8075           break;
8076         }
8077       }
8078
8079       /* Are we done with directories yet? */
8080       if (unixptr >= lastslash) {
8081
8082         /* Watch out for trailing dots */
8083         if (dir_dot != 0) {
8084             vmslen --;
8085             vmsptr--;
8086         }
8087         *vmsptr++ = ']';
8088         vmslen++;
8089         dash_flag = 0;
8090         dir_start = 0;
8091         if (*unixptr == '/')
8092           unixptr++;
8093       }
8094       else {
8095         /* Have we stopped backing up? */
8096         if (dash_flag) {
8097           *vmsptr++ = '.';
8098           vmslen++;
8099           dash_flag = 0;
8100           /* dir_start continues to be = 1 */
8101         }
8102         if (*unixptr == '-') {
8103           *vmsptr++ = '^';
8104           *vmsptr++ = *unixptr++;
8105           vmslen += 2;
8106           dir_start = 0;
8107
8108           /* Now are we done with directories yet? */
8109           if (unixptr >= lastslash) {
8110
8111             /* Watch out for trailing dots */
8112             if (dir_dot != 0) {
8113               vmslen --;
8114               vmsptr--;
8115             }
8116
8117             *vmsptr++ = ']';
8118             vmslen++;
8119             dash_flag = 0;
8120             dir_start = 0;
8121           }
8122         }
8123       }
8124     }
8125
8126     /* All done? */
8127     if (unixptr >= unixend)
8128       break;
8129
8130     /* Normal characters - More EFS work probably needed */
8131     dir_start = 0;
8132     dir_dot = 0;
8133
8134     switch(*unixptr) {
8135     case '/':
8136         /* remove multiple / */
8137         while (unixptr[1] == '/') {
8138            unixptr++;
8139         }
8140         if (unixptr == lastslash) {
8141           /* Watch out for trailing dots */
8142           if (dir_dot != 0) {
8143             vmslen --;
8144             vmsptr--;
8145           }
8146           *vmsptr++ = ']';
8147         }
8148         else {
8149           dir_start = 1;
8150           *vmsptr++ = '.';
8151           dir_dot = 1;
8152
8153           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8154           /* Not needed when VMS is pretending to be UNIX. */
8155
8156         }
8157         dash_flag = 0;
8158         if (unixptr != unixend)
8159           unixptr++;
8160         vmslen++;
8161         break;
8162     case '.':
8163         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8164             (&unixptr[1] == unixend)) {
8165           *vmsptr++ = '^';
8166           *vmsptr++ = '.';
8167           vmslen += 2;
8168           unixptr++;
8169
8170           /* trailing dot ==> '^..' on VMS */
8171           if (unixptr == unixend) {
8172             *vmsptr++ = '.';
8173             vmslen++;
8174             unixptr++;
8175           }
8176           break;
8177         }
8178
8179         *vmsptr++ = *unixptr++;
8180         vmslen ++;
8181         break;
8182     case '"':
8183         if (quoted && (&unixptr[1] == unixend)) {
8184             unixptr++;
8185             break;
8186         }
8187         in_cnt = copy_expand_unix_filename_escape
8188                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8189         vmsptr += out_cnt;
8190         unixptr += in_cnt;
8191         break;
8192     case '~':
8193     case ';':
8194     case '\\':
8195     case '?':
8196     case ' ':
8197     default:
8198         in_cnt = copy_expand_unix_filename_escape
8199                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8200         vmsptr += out_cnt;
8201         unixptr += in_cnt;
8202         break;
8203     }
8204   }
8205
8206   /* Make sure directory is closed */
8207   if (unixptr == lastslash) {
8208     char *vmsptr2;
8209     vmsptr2 = vmsptr - 1;
8210
8211     if (*vmsptr2 != ']') {
8212       *vmsptr2--;
8213
8214       /* directories do not end in a dot bracket */
8215       if (*vmsptr2 == '.') {
8216         vmsptr2--;
8217
8218         /* ^. is allowed */
8219         if (*vmsptr2 != '^') {
8220           vmsptr--; /* back up over the dot */
8221         }
8222       }
8223       *vmsptr++ = ']';
8224     }
8225   }
8226   else {
8227     char *vmsptr2;
8228     /* Add a trailing dot if a file with no extension */
8229     vmsptr2 = vmsptr - 1;
8230     if ((vmslen > 1) &&
8231         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8232         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8233         *vmsptr++ = '.';
8234         vmslen++;
8235     }
8236   }
8237
8238   *vmsptr = '\0';
8239   return SS$_NORMAL;
8240 }
8241 #endif
8242
8243  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8244 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8245 {
8246 char * result;
8247 int utf8_flag;
8248
8249    /* If a UTF8 flag is being passed, honor it */
8250    utf8_flag = 0;
8251    if (utf8_fl != NULL) {
8252      utf8_flag = *utf8_fl;
8253     *utf8_fl = 0;
8254    }
8255
8256    if (utf8_flag) {
8257      /* If there is a possibility of UTF8, then if any UTF8 characters
8258         are present, then they must be converted to VTF-7
8259       */
8260      result = strcpy(rslt, path); /* FIX-ME */
8261    }
8262    else
8263      result = strcpy(rslt, path);
8264
8265    return result;
8266 }
8267
8268 /* A convenience macro for copying dots in filenames and escaping
8269  * them when they haven't already been escaped, with guards to
8270  * avoid checking before the start of the buffer or advancing
8271  * beyond the end of it (allowing room for the NUL terminator).
8272  */
8273 #define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
8274     if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8275           || ((vmsefsdot) == (vmsefsbuf))) \
8276          && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
8277        ) { \
8278         *((vmsefsdot)++) = '^'; \
8279     } \
8280     if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8281         *((vmsefsdot)++) = '.'; \
8282 } STMT_END
8283
8284 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8285 static char *int_tovmsspec
8286    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8287   char *dirend;
8288   char *lastdot;
8289   char *cp1;
8290   const char *cp2;
8291   unsigned long int infront = 0, hasdir = 1;
8292   int rslt_len;
8293   int no_type_seen;
8294   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8295   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8296
8297   if (vms_debug_fileify) {
8298       if (path == NULL)
8299           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8300       else
8301           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8302   }
8303
8304   if (path == NULL) {
8305       /* If we fail, we should be setting errno */
8306       set_errno(EINVAL);
8307       set_vaxc_errno(SS$_BADPARAM);
8308       return NULL;
8309   }
8310   rslt_len = VMS_MAXRSS-1;
8311
8312   /* '.' and '..' are "[]" and "[-]" for a quick check */
8313   if (path[0] == '.') {
8314     if (path[1] == '\0') {
8315       strcpy(rslt,"[]");
8316       if (utf8_flag != NULL)
8317         *utf8_flag = 0;
8318       return rslt;
8319     }
8320     else {
8321       if (path[1] == '.' && path[2] == '\0') {
8322         strcpy(rslt,"[-]");
8323         if (utf8_flag != NULL)
8324            *utf8_flag = 0;
8325         return rslt;
8326       }
8327     }
8328   }
8329
8330    /* Posix specifications are now a native VMS format */
8331   /*--------------------------------------------------*/
8332 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8333   if (decc_posix_compliant_pathnames) {
8334     if (strncmp(path,"\"^UP^",5) == 0) {
8335       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8336       return rslt;
8337     }
8338   }
8339 #endif
8340
8341   /* This is really the only way to see if this is already in VMS format */
8342   sts = vms_split_path
8343        (path,
8344         &v_spec,
8345         &v_len,
8346         &r_spec,
8347         &r_len,
8348         &d_spec,
8349         &d_len,
8350         &n_spec,
8351         &n_len,
8352         &e_spec,
8353         &e_len,
8354         &vs_spec,
8355         &vs_len);
8356   if (sts == 0) {
8357     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8358        replacement, because the above parse just took care of most of
8359        what is needed to do vmspath when the specification is already
8360        in VMS format.
8361
8362        And if it is not already, it is easier to do the conversion as
8363        part of this routine than to call this routine and then work on
8364        the result.
8365      */
8366
8367     /* If VMS punctuation was found, it is already VMS format */
8368     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8369       if (utf8_flag != NULL)
8370         *utf8_flag = 0;
8371       my_strlcpy(rslt, path, VMS_MAXRSS);
8372       if (vms_debug_fileify) {
8373           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8374       }
8375       return rslt;
8376     }
8377     /* Now, what to do with trailing "." cases where there is no
8378        extension?  If this is a UNIX specification, and EFS characters
8379        are enabled, then the trailing "." should be converted to a "^.".
8380        But if this was already a VMS specification, then it should be
8381        left alone.
8382
8383        So in the case of ambiguity, leave the specification alone.
8384      */
8385
8386
8387     /* If there is a possibility of UTF8, then if any UTF8 characters
8388         are present, then they must be converted to VTF-7
8389      */
8390     if (utf8_flag != NULL)
8391       *utf8_flag = 0;
8392     my_strlcpy(rslt, path, VMS_MAXRSS);
8393     if (vms_debug_fileify) {
8394         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8395     }
8396     return rslt;
8397   }
8398
8399   dirend = strrchr(path,'/');
8400
8401   if (dirend == NULL) {
8402      /* If we get here with no Unix directory delimiters, then this is an
8403       * ambiguous file specification, such as a Unix glob specification, a
8404       * shell or make macro, or a filespec that would be valid except for
8405       * unescaped extended characters.  The safest thing if it's a macro
8406       * is to pass it through as-is.
8407       */
8408       if (strstr(path, "$(")) {
8409           my_strlcpy(rslt, path, VMS_MAXRSS);
8410           if (vms_debug_fileify) {
8411               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8412           }
8413           return rslt;
8414       }
8415       hasdir = 0;
8416   }
8417   else if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8418     if (!*(dirend+2)) dirend +=2;
8419     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8420     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8421   }
8422
8423   cp1 = rslt;
8424   cp2 = path;
8425   lastdot = strrchr(cp2,'.');
8426   if (*cp2 == '/') {
8427     char *trndev;
8428     int islnm, rooted;
8429     STRLEN trnend;
8430
8431     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8432     if (!*(cp2+1)) {
8433       if (decc_disable_posix_root) {
8434         strcpy(rslt,"sys$disk:[000000]");
8435       }
8436       else {
8437         strcpy(rslt,"sys$posix_root:[000000]");
8438       }
8439       if (utf8_flag != NULL)
8440         *utf8_flag = 0;
8441       if (vms_debug_fileify) {
8442           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8443       }
8444       return rslt;
8445     }
8446     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8447     *cp1 = '\0';
8448     trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8449     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8450     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8451
8452      /* DECC special handling */
8453     if (!islnm) {
8454       if (strcmp(rslt,"bin") == 0) {
8455         strcpy(rslt,"sys$system");
8456         cp1 = rslt + 10;
8457         *cp1 = 0;
8458         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8459       }
8460       else if (strcmp(rslt,"tmp") == 0) {
8461         strcpy(rslt,"sys$scratch");
8462         cp1 = rslt + 11;
8463         *cp1 = 0;
8464         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8465       }
8466       else if (!decc_disable_posix_root) {
8467         strcpy(rslt, "sys$posix_root");
8468         cp1 = rslt + 14;
8469         *cp1 = 0;
8470         cp2 = path;
8471         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8472         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8473       }
8474       else if (strcmp(rslt,"dev") == 0) {
8475         if (strncmp(cp2,"/null", 5) == 0) {
8476           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8477             strcpy(rslt,"NLA0");
8478             cp1 = rslt + 4;
8479             *cp1 = 0;
8480             cp2 = cp2 + 5;
8481             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8482           }
8483         }
8484       }
8485     }
8486
8487     trnend = islnm ? strlen(trndev) - 1 : 0;
8488     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8489     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8490     /* If the first element of the path is a logical name, determine
8491      * whether it has to be translated so we can add more directories. */
8492     if (!islnm || rooted) {
8493       *(cp1++) = ':';
8494       *(cp1++) = '[';
8495       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8496       else cp2++;
8497     }
8498     else {
8499       if (cp2 != dirend) {
8500         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8501         cp1 = rslt + trnend;
8502         if (*cp2 != 0) {
8503           *(cp1++) = '.';
8504           cp2++;
8505         }
8506       }
8507       else {
8508         if (decc_disable_posix_root) {
8509           *(cp1++) = ':';
8510           hasdir = 0;
8511         }
8512       }
8513     }
8514     PerlMem_free(trndev);
8515   }
8516   else if (hasdir) {
8517     *(cp1++) = '[';
8518     if (*cp2 == '.') {
8519       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8520         cp2 += 2;         /* skip over "./" - it's redundant */
8521         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8522       }
8523       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8524         *(cp1++) = '-';                                 /* "../" --> "-" */
8525         cp2 += 3;
8526       }
8527       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8528                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8529         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8530         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8531         cp2 += 4;
8532       }
8533       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8534         /* Escape the extra dots in EFS file specifications */
8535         *(cp1++) = '^';
8536       }
8537       if (cp2 > dirend) cp2 = dirend;
8538     }
8539     else *(cp1++) = '.';
8540   }
8541   for (; cp2 < dirend; cp2++) {
8542     if (*cp2 == '/') {
8543       if (*(cp2-1) == '/') continue;
8544       if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
8545       infront = 0;
8546     }
8547     else if (!infront && *cp2 == '.') {
8548       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8549       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8550       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8551         if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
8552         else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
8553         else {
8554           *(cp1++) = '-';
8555         }
8556         cp2 += 2;
8557         if (cp2 == dirend) break;
8558       }
8559       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8560                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8561         if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8562         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8563         if (!*(cp2+3)) {
8564           *(cp1++) = '.';  /* Simulate trailing '/' */
8565           cp2 += 2;  /* for loop will incr this to == dirend */
8566         }
8567         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8568       }
8569       else {
8570         if (decc_efs_charset == 0) {
8571           if (cp1 > rslt && *(cp1-1) == '^')
8572             cp1--;         /* remove the escape, if any */
8573           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8574         }
8575         else {
8576           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8577         }
8578       }
8579     }
8580     else {
8581       if (!infront && cp1 > rslt && *(cp1-1) == '-')  *(cp1++) = '.';
8582       if (*cp2 == '.') {
8583         if (decc_efs_charset == 0) {
8584           if (cp1 > rslt && *(cp1-1) == '^')
8585             cp1--;         /* remove the escape, if any */
8586           *(cp1++) = '_';
8587         }
8588         else {
8589           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8590         }
8591       }
8592       else {
8593         int out_cnt;
8594         cp2 += copy_expand_unix_filename_escape(cp1, cp2, &out_cnt, utf8_flag);
8595         cp2--; /* we're in a loop that will increment this */
8596         cp1 += out_cnt;
8597       }
8598       infront = 1;
8599     }
8600   }
8601   if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8602   if (hasdir) *(cp1++) = ']';
8603   if (*cp2 && *cp2 == '/') cp2++;  /* check in case we ended with trailing '/' */
8604   no_type_seen = 0;
8605   if (cp2 > lastdot)
8606     no_type_seen = 1;
8607   while (*cp2) {
8608     switch(*cp2) {
8609     case '?':
8610         if (decc_efs_charset == 0)
8611           *(cp1++) = '%';
8612         else
8613           *(cp1++) = '?';
8614         cp2++;
8615     case ' ':
8616         if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
8617             *(cp1)++ = '^';
8618         *(cp1)++ = '_';
8619         cp2++;
8620         break;
8621     case '.':
8622         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8623             decc_readdir_dropdotnotype) {
8624           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8625           cp2++;
8626
8627           /* trailing dot ==> '^..' on VMS */
8628           if (*cp2 == '\0') {
8629             *(cp1++) = '.';
8630             no_type_seen = 0;
8631           }
8632         }
8633         else {
8634           *(cp1++) = *(cp2++);
8635           no_type_seen = 0;
8636         }
8637         break;
8638     case '$':
8639          /* This could be a macro to be passed through */
8640         *(cp1++) = *(cp2++);
8641         if (*cp2 == '(') {
8642         const char * save_cp2;
8643         char * save_cp1;
8644         int is_macro;
8645
8646             /* paranoid check */
8647             save_cp2 = cp2;
8648             save_cp1 = cp1;
8649             is_macro = 0;
8650
8651             /* Test through */
8652             *(cp1++) = *(cp2++);
8653             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8654                 *(cp1++) = *(cp2++);
8655                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8656                     *(cp1++) = *(cp2++);
8657                 }
8658                 if (*cp2 == ')') {
8659                     *(cp1++) = *(cp2++);
8660                     is_macro = 1;
8661                 }
8662             }
8663             if (is_macro == 0) {
8664                 /* Not really a macro - never mind */
8665                 cp2 = save_cp2;
8666                 cp1 = save_cp1;
8667             }
8668         }
8669         break;
8670     case '\"':
8671     case '~':
8672     case '`':
8673     case '!':
8674     case '#':
8675     case '%':
8676     case '^':
8677         /* Don't escape again if following character is
8678          * already something we escape.
8679          */
8680         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8681             *(cp1++) = *(cp2++);
8682             break;
8683         }
8684         /* But otherwise fall through and escape it. */
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     case '|':
8699     case '<':
8700     case '>':
8701         if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */
8702             *(cp1++) = '^';
8703         *(cp1++) = *(cp2++);
8704         break;
8705     case ';':
8706         /* If it doesn't look like the beginning of a version number,
8707          * or we've been promised there are no version numbers, then
8708          * escape it.
8709          */
8710         if (decc_filename_unix_no_version) {
8711           *(cp1++) = '^';
8712         }
8713         else {
8714           size_t all_nums = strspn(cp2+1, "0123456789");
8715           if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0')
8716             *(cp1++) = '^';
8717         }
8718         *(cp1++) = *(cp2++);
8719         break;
8720     default:
8721         *(cp1++) = *(cp2++);
8722     }
8723   }
8724   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8725   char *lcp1;
8726     lcp1 = cp1;
8727     lcp1--;
8728      /* Fix me for "^]", but that requires making sure that you do
8729       * not back up past the start of the filename
8730       */
8731     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8732       *cp1++ = '.';
8733   }
8734   *cp1 = '\0';
8735
8736   if (utf8_flag != NULL)
8737     *utf8_flag = 0;
8738   if (vms_debug_fileify) {
8739       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8740   }
8741   return rslt;
8742
8743 }  /* end of int_tovmsspec() */
8744
8745
8746 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8747 static char *mp_do_tovmsspec
8748    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8749   static char __tovmsspec_retbuf[VMS_MAXRSS];
8750     char * vmsspec, *ret_spec, *ret_buf;
8751
8752     vmsspec = NULL;
8753     ret_buf = buf;
8754     if (ret_buf == NULL) {
8755         if (ts) {
8756             Newx(vmsspec, VMS_MAXRSS, char);
8757             if (vmsspec == NULL)
8758                 _ckvmssts(SS$_INSFMEM);
8759             ret_buf = vmsspec;
8760         } else {
8761             ret_buf = __tovmsspec_retbuf;
8762         }
8763     }
8764
8765     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8766
8767     if (ret_spec == NULL) {
8768        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8769        if (vmsspec)
8770            Safefree(vmsspec);
8771     }
8772
8773     return ret_spec;
8774
8775 }  /* end of mp_do_tovmsspec() */
8776 /*}}}*/
8777 /* External entry points */
8778 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8779   { return do_tovmsspec(path,buf,0,NULL); }
8780 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8781   { return do_tovmsspec(path,buf,1,NULL); }
8782 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8783   { return do_tovmsspec(path,buf,0,utf8_fl); }
8784 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8785   { return do_tovmsspec(path,buf,1,utf8_fl); }
8786
8787 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8788 /* Internal routine for use with out an explicit context present */
8789 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
8790
8791     char * ret_spec, *pathified;
8792
8793     if (path == NULL)
8794         return NULL;
8795
8796     pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8797     if (pathified == NULL)
8798         _ckvmssts_noperl(SS$_INSFMEM);
8799
8800     ret_spec = int_pathify_dirspec(path, pathified);
8801
8802     if (ret_spec == NULL) {
8803         PerlMem_free(pathified);
8804         return NULL;
8805     }
8806
8807     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8808
8809     PerlMem_free(pathified);
8810     return ret_spec;
8811
8812 }
8813
8814 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8815 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8816   static char __tovmspath_retbuf[VMS_MAXRSS];
8817   int vmslen;
8818   char *pathified, *vmsified, *cp;
8819
8820   if (path == NULL) return NULL;
8821   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8822   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8823   if (int_pathify_dirspec(path, pathified) == NULL) {
8824     PerlMem_free(pathified);
8825     return NULL;
8826   }
8827
8828   vmsified = NULL;
8829   if (buf == NULL)
8830      Newx(vmsified, VMS_MAXRSS, char);
8831   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8832     PerlMem_free(pathified);
8833     if (vmsified) Safefree(vmsified);
8834     return NULL;
8835   }
8836   PerlMem_free(pathified);
8837   if (buf) {
8838     return buf;
8839   }
8840   else if (ts) {
8841     vmslen = strlen(vmsified);
8842     Newx(cp,vmslen+1,char);
8843     memcpy(cp,vmsified,vmslen);
8844     cp[vmslen] = '\0';
8845     Safefree(vmsified);
8846     return cp;
8847   }
8848   else {
8849     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8850     Safefree(vmsified);
8851     return __tovmspath_retbuf;
8852   }
8853
8854 }  /* end of do_tovmspath() */
8855 /*}}}*/
8856 /* External entry points */
8857 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8858   { return do_tovmspath(path,buf,0, NULL); }
8859 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8860   { return do_tovmspath(path,buf,1, NULL); }
8861 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8862   { return do_tovmspath(path,buf,0,utf8_fl); }
8863 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8864   { return do_tovmspath(path,buf,1,utf8_fl); }
8865
8866
8867 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8868 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8869   static char __tounixpath_retbuf[VMS_MAXRSS];
8870   int unixlen;
8871   char *pathified, *unixified, *cp;
8872
8873   if (path == NULL) return NULL;
8874   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8875   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8876   if (int_pathify_dirspec(path, pathified) == NULL) {
8877     PerlMem_free(pathified);
8878     return NULL;
8879   }
8880
8881   unixified = NULL;
8882   if (buf == NULL) {
8883       Newx(unixified, VMS_MAXRSS, char);
8884   }
8885   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8886     PerlMem_free(pathified);
8887     if (unixified) Safefree(unixified);
8888     return NULL;
8889   }
8890   PerlMem_free(pathified);
8891   if (buf) {
8892     return buf;
8893   }
8894   else if (ts) {
8895     unixlen = strlen(unixified);
8896     Newx(cp,unixlen+1,char);
8897     memcpy(cp,unixified,unixlen);
8898     cp[unixlen] = '\0';
8899     Safefree(unixified);
8900     return cp;
8901   }
8902   else {
8903     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
8904     Safefree(unixified);
8905     return __tounixpath_retbuf;
8906   }
8907
8908 }  /* end of do_tounixpath() */
8909 /*}}}*/
8910 /* External entry points */
8911 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8912   { return do_tounixpath(path,buf,0,NULL); }
8913 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8914   { return do_tounixpath(path,buf,1,NULL); }
8915 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8916   { return do_tounixpath(path,buf,0,utf8_fl); }
8917 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8918   { return do_tounixpath(path,buf,1,utf8_fl); }
8919
8920 /*
8921  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8922  *
8923  *****************************************************************************
8924  *                                                                           *
8925  *  Copyright (C) 1989-1994, 2007 by                                         *
8926  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8927  *                                                                           *
8928  *  Permission is hereby granted for the reproduction of this software       *
8929  *  on condition that this copyright notice is included in source            *
8930  *  distributions of the software.  The code may be modified and             *
8931  *  distributed under the same terms as Perl itself.                         *
8932  *                                                                           *
8933  *  27-Aug-1994 Modified for inclusion in perl5                              *
8934  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8935  *****************************************************************************
8936  */
8937
8938 /*
8939  * getredirection() is intended to aid in porting C programs
8940  * to VMS (Vax-11 C).  The native VMS environment does not support
8941  * '>' and '<' I/O redirection, or command line wild card expansion,
8942  * or a command line pipe mechanism using the '|' AND background
8943  * command execution '&'.  All of these capabilities are provided to any
8944  * C program which calls this procedure as the first thing in the
8945  * main program.
8946  * The piping mechanism will probably work with almost any 'filter' type
8947  * of program.  With suitable modification, it may useful for other
8948  * portability problems as well.
8949  *
8950  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8951  */
8952 struct list_item
8953     {
8954     struct list_item *next;
8955     char *value;
8956     };
8957
8958 static void add_item(struct list_item **head,
8959                      struct list_item **tail,
8960                      char *value,
8961                      int *count);
8962
8963 static void mp_expand_wild_cards(pTHX_ char *item,
8964                                 struct list_item **head,
8965                                 struct list_item **tail,
8966                                 int *count);
8967
8968 static int background_process(pTHX_ int argc, char **argv);
8969
8970 static void pipe_and_fork(pTHX_ char **cmargv);
8971
8972 /*{{{ void getredirection(int *ac, char ***av)*/
8973 static void
8974 mp_getredirection(pTHX_ int *ac, char ***av)
8975 /*
8976  * Process vms redirection arg's.  Exit if any error is seen.
8977  * If getredirection() processes an argument, it is erased
8978  * from the vector.  getredirection() returns a new argc and argv value.
8979  * In the event that a background command is requested (by a trailing "&"),
8980  * this routine creates a background subprocess, and simply exits the program.
8981  *
8982  * Warning: do not try to simplify the code for vms.  The code
8983  * presupposes that getredirection() is called before any data is
8984  * read from stdin or written to stdout.
8985  *
8986  * Normal usage is as follows:
8987  *
8988  *      main(argc, argv)
8989  *      int             argc;
8990  *      char            *argv[];
8991  *      {
8992  *              getredirection(&argc, &argv);
8993  *      }
8994  */
8995 {
8996     int                 argc = *ac;     /* Argument Count         */
8997     char                **argv = *av;   /* Argument Vector        */
8998     char                *ap;            /* Argument pointer       */
8999     int                 j;              /* argv[] index           */
9000     int                 item_count = 0; /* Count of Items in List */
9001     struct list_item    *list_head = 0; /* First Item in List       */
9002     struct list_item    *list_tail;     /* Last Item in List        */
9003     char                *in = NULL;     /* Input File Name          */
9004     char                *out = NULL;    /* Output File Name         */
9005     char                *outmode = "w"; /* Mode to Open Output File */
9006     char                *err = NULL;    /* Error File Name          */
9007     char                *errmode = "w"; /* Mode to Open Error File  */
9008     int                 cmargc = 0;     /* Piped Command Arg Count  */
9009     char                **cmargv = NULL;/* Piped Command Arg Vector */
9010
9011     /*
9012      * First handle the case where the last thing on the line ends with
9013      * a '&'.  This indicates the desire for the command to be run in a
9014      * subprocess, so we satisfy that desire.
9015      */
9016     ap = argv[argc-1];
9017     if (0 == strcmp("&", ap))
9018        exit(background_process(aTHX_ --argc, argv));
9019     if (*ap && '&' == ap[strlen(ap)-1])
9020         {
9021         ap[strlen(ap)-1] = '\0';
9022        exit(background_process(aTHX_ argc, argv));
9023         }
9024     /*
9025      * Now we handle the general redirection cases that involve '>', '>>',
9026      * '<', and pipes '|'.
9027      */
9028     for (j = 0; j < argc; ++j)
9029         {
9030         if (0 == strcmp("<", argv[j]))
9031             {
9032             if (j+1 >= argc)
9033                 {
9034                 fprintf(stderr,"No input file after < on command line");
9035                 exit(LIB$_WRONUMARG);
9036                 }
9037             in = argv[++j];
9038             continue;
9039             }
9040         if ('<' == *(ap = argv[j]))
9041             {
9042             in = 1 + ap;
9043             continue;
9044             }
9045         if (0 == strcmp(">", ap))
9046             {
9047             if (j+1 >= argc)
9048                 {
9049                 fprintf(stderr,"No output file after > on command line");
9050                 exit(LIB$_WRONUMARG);
9051                 }
9052             out = argv[++j];
9053             continue;
9054             }
9055         if ('>' == *ap)
9056             {
9057             if ('>' == ap[1])
9058                 {
9059                 outmode = "a";
9060                 if ('\0' == ap[2])
9061                     out = argv[++j];
9062                 else
9063                     out = 2 + ap;
9064                 }
9065             else
9066                 out = 1 + ap;
9067             if (j >= argc)
9068                 {
9069                 fprintf(stderr,"No output file after > or >> on command line");
9070                 exit(LIB$_WRONUMARG);
9071                 }
9072             continue;
9073             }
9074         if (('2' == *ap) && ('>' == ap[1]))
9075             {
9076             if ('>' == ap[2])
9077                 {
9078                 errmode = "a";
9079                 if ('\0' == ap[3])
9080                     err = argv[++j];
9081                 else
9082                     err = 3 + ap;
9083                 }
9084             else
9085                 if ('\0' == ap[2])
9086                     err = argv[++j];
9087                 else
9088                     err = 2 + ap;
9089             if (j >= argc)
9090                 {
9091                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9092                 exit(LIB$_WRONUMARG);
9093                 }
9094             continue;
9095             }
9096         if (0 == strcmp("|", argv[j]))
9097             {
9098             if (j+1 >= argc)
9099                 {
9100                 fprintf(stderr,"No command into which to pipe on command line");
9101                 exit(LIB$_WRONUMARG);
9102                 }
9103             cmargc = argc-(j+1);
9104             cmargv = &argv[j+1];
9105             argc = j;
9106             continue;
9107             }
9108         if ('|' == *(ap = argv[j]))
9109             {
9110             ++argv[j];
9111             cmargc = argc-j;
9112             cmargv = &argv[j];
9113             argc = j;
9114             continue;
9115             }
9116         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9117         }
9118     /*
9119      * Allocate and fill in the new argument vector, Some Unix's terminate
9120      * the list with an extra null pointer.
9121      */
9122     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9123     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9124     *av = argv;
9125     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9126         argv[j] = list_head->value;
9127     *ac = item_count;
9128     if (cmargv != NULL)
9129         {
9130         if (out != NULL)
9131             {
9132             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9133             exit(LIB$_INVARGORD);
9134             }
9135         pipe_and_fork(aTHX_ cmargv);
9136         }
9137
9138     /* Check for input from a pipe (mailbox) */
9139
9140     if (in == NULL && 1 == isapipe(0))
9141         {
9142         char mbxname[L_tmpnam];
9143         long int bufsize;
9144         long int dvi_item = DVI$_DEVBUFSIZ;
9145         $DESCRIPTOR(mbxnam, "");
9146         $DESCRIPTOR(mbxdevnam, "");
9147
9148         /* Input from a pipe, reopen it in binary mode to disable       */
9149         /* carriage control processing.                                 */
9150
9151         fgetname(stdin, mbxname, 1);
9152         mbxnam.dsc$a_pointer = mbxname;
9153         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9154         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9155         mbxdevnam.dsc$a_pointer = mbxname;
9156         mbxdevnam.dsc$w_length = sizeof(mbxname);
9157         dvi_item = DVI$_DEVNAM;
9158         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9159         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9160         set_errno(0);
9161         set_vaxc_errno(1);
9162         freopen(mbxname, "rb", stdin);
9163         if (errno != 0)
9164             {
9165             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9166             exit(vaxc$errno);
9167             }
9168         }
9169     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9170         {
9171         fprintf(stderr,"Can't open input file %s as stdin",in);
9172         exit(vaxc$errno);
9173         }
9174     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9175         {
9176         fprintf(stderr,"Can't open output file %s as stdout",out);
9177         exit(vaxc$errno);
9178         }
9179         if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
9180
9181     if (err != NULL) {
9182         if (strcmp(err,"&1") == 0) {
9183             dup2(fileno(stdout), fileno(stderr));
9184             vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
9185         } else {
9186         FILE *tmperr;
9187         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9188             {
9189             fprintf(stderr,"Can't open error file %s as stderr",err);
9190             exit(vaxc$errno);
9191             }
9192             fclose(tmperr);
9193            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9194                 {
9195                 exit(vaxc$errno);
9196                 }
9197             vmssetuserlnm("SYS$ERROR", err);
9198         }
9199         }
9200 #ifdef ARGPROC_DEBUG
9201     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9202     for (j = 0; j < *ac;  ++j)
9203         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9204 #endif
9205    /* Clear errors we may have hit expanding wildcards, so they don't
9206       show up in Perl's $! later */
9207    set_errno(0); set_vaxc_errno(1);
9208 }  /* end of getredirection() */
9209 /*}}}*/
9210
9211 static void add_item(struct list_item **head,
9212                      struct list_item **tail,
9213                      char *value,
9214                      int *count)
9215 {
9216     if (*head == 0)
9217         {
9218         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9219         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9220         *tail = *head;
9221         }
9222     else {
9223         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9224         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9225         *tail = (*tail)->next;
9226         }
9227     (*tail)->value = value;
9228     ++(*count);
9229 }
9230
9231 static void mp_expand_wild_cards(pTHX_ char *item,
9232                               struct list_item **head,
9233                               struct list_item **tail,
9234                               int *count)
9235 {
9236 int expcount = 0;
9237 unsigned long int context = 0;
9238 int isunix = 0;
9239 int item_len = 0;
9240 char *had_version;
9241 char *had_device;
9242 int had_directory;
9243 char *devdir,*cp;
9244 char *vmsspec;
9245 $DESCRIPTOR(filespec, "");
9246 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9247 $DESCRIPTOR(resultspec, "");
9248 unsigned long int lff_flags = 0;
9249 int sts;
9250 int rms_sts;
9251
9252 #ifdef VMS_LONGNAME_SUPPORT
9253     lff_flags = LIB$M_FIL_LONG_NAMES;
9254 #endif
9255
9256     for (cp = item; *cp; cp++) {
9257         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9258         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9259     }
9260     if (!*cp || isspace(*cp))
9261         {
9262         add_item(head, tail, item, count);
9263         return;
9264         }
9265     else
9266         {
9267      /* "double quoted" wild card expressions pass as is */
9268      /* From DCL that means using e.g.:                  */
9269      /* perl program """perl.*"""                        */
9270      item_len = strlen(item);
9271      if ( '"' == *item && '"' == item[item_len-1] )
9272        {
9273        item++;
9274        item[item_len-2] = '\0';
9275        add_item(head, tail, item, count);
9276        return;
9277        }
9278      }
9279     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9280     resultspec.dsc$b_class = DSC$K_CLASS_D;
9281     resultspec.dsc$a_pointer = NULL;
9282     vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9283     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9284     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9285       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9286     if (!isunix || !filespec.dsc$a_pointer)
9287       filespec.dsc$a_pointer = item;
9288     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9289     /*
9290      * Only return version specs, if the caller specified a version
9291      */
9292     had_version = strchr(item, ';');
9293     /*
9294      * Only return device and directory specs, if the caller specified either.
9295      */
9296     had_device = strchr(item, ':');
9297     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9298
9299     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9300                                  (&filespec, &resultspec, &context,
9301                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9302         {
9303         char *string;
9304         char *c;
9305
9306         string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9307         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9308         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9309         if (NULL == had_version)
9310             *(strrchr(string, ';')) = '\0';
9311         if ((!had_directory) && (had_device == NULL))
9312             {
9313             if (NULL == (devdir = strrchr(string, ']')))
9314                 devdir = strrchr(string, '>');
9315             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9316             }
9317         /*
9318          * Be consistent with what the C RTL has already done to the rest of
9319          * the argv items and lowercase all of these names.
9320          */
9321         if (!decc_efs_case_preserve) {
9322             for (c = string; *c; ++c)
9323             if (isupper(*c))
9324                 *c = tolower(*c);
9325         }
9326         if (isunix) trim_unixpath(string,item,1);
9327         add_item(head, tail, string, count);
9328         ++expcount;
9329     }
9330     PerlMem_free(vmsspec);
9331     if (sts != RMS$_NMF)
9332         {
9333         set_vaxc_errno(sts);
9334         switch (sts)
9335             {
9336             case RMS$_FNF: case RMS$_DNF:
9337                 set_errno(ENOENT); break;
9338             case RMS$_DIR:
9339                 set_errno(ENOTDIR); break;
9340             case RMS$_DEV:
9341                 set_errno(ENODEV); break;
9342             case RMS$_FNM: case RMS$_SYN:
9343                 set_errno(EINVAL); break;
9344             case RMS$_PRV:
9345                 set_errno(EACCES); break;
9346             default:
9347                 _ckvmssts_noperl(sts);
9348             }
9349         }
9350     if (expcount == 0)
9351         add_item(head, tail, item, count);
9352     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9353     _ckvmssts_noperl(lib$find_file_end(&context));
9354 }
9355
9356
9357 static void
9358 pipe_and_fork(pTHX_ char **cmargv)
9359 {
9360     PerlIO *fp;
9361     struct dsc$descriptor_s *vmscmd;
9362     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9363     int sts, j, l, ismcr, quote, tquote = 0;
9364
9365     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9366     vms_execfree(vmscmd);
9367
9368     j = l = 0;
9369     p = subcmd;
9370     q = cmargv[0];
9371     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9372               && toupper(*(q+2)) == 'R' && !*(q+3);
9373
9374     while (q && l < MAX_DCL_LINE_LENGTH) {
9375         if (!*q) {
9376             if (j > 0 && quote) {
9377                 *p++ = '"';
9378                 l++;
9379             }
9380             q = cmargv[++j];
9381             if (q) {
9382                 if (ismcr && j > 1) quote = 1;
9383                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9384                 *p++ = ' ';
9385                 l++;
9386                 if (quote || tquote) {
9387                     *p++ = '"';
9388                     l++;
9389                 }
9390             }
9391         } else {
9392             if ((quote||tquote) && *q == '"') {
9393                 *p++ = '"';
9394                 l++;
9395             }
9396             *p++ = *q++;
9397             l++;
9398         }
9399     }
9400     *p = '\0';
9401
9402     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9403     if (fp == NULL) {
9404         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9405     }
9406 }
9407
9408 static int background_process(pTHX_ int argc, char **argv)
9409 {
9410 char command[MAX_DCL_SYMBOL + 1] = "$";
9411 $DESCRIPTOR(value, "");
9412 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9413 static $DESCRIPTOR(null, "NLA0:");
9414 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9415 char pidstring[80];
9416 $DESCRIPTOR(pidstr, "");
9417 int pid;
9418 unsigned long int flags = 17, one = 1, retsts;
9419 int len;
9420
9421     len = my_strlcat(command, argv[0], sizeof(command));
9422     while (--argc && (len < MAX_DCL_SYMBOL))
9423         {
9424         my_strlcat(command, " \"", sizeof(command));
9425         my_strlcat(command, *(++argv), sizeof(command));
9426         len = my_strlcat(command, "\"", sizeof(command));
9427         }
9428     value.dsc$a_pointer = command;
9429     value.dsc$w_length = strlen(value.dsc$a_pointer);
9430     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9431     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9432     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9433         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9434     }
9435     else {
9436         _ckvmssts_noperl(retsts);
9437     }
9438 #ifdef ARGPROC_DEBUG
9439     PerlIO_printf(Perl_debug_log, "%s\n", command);
9440 #endif
9441     sprintf(pidstring, "%08X", pid);
9442     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9443     pidstr.dsc$a_pointer = pidstring;
9444     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9445     lib$set_symbol(&pidsymbol, &pidstr);
9446     return(SS$_NORMAL);
9447 }
9448 /*}}}*/
9449 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9450
9451
9452 /* OS-specific initialization at image activation (not thread startup) */
9453 /* Older VAXC header files lack these constants */
9454 #ifndef JPI$_RIGHTS_SIZE
9455 #  define JPI$_RIGHTS_SIZE 817
9456 #endif
9457 #ifndef KGB$M_SUBSYSTEM
9458 #  define KGB$M_SUBSYSTEM 0x8
9459 #endif
9460
9461 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9462
9463 /*{{{void vms_image_init(int *, char ***)*/
9464 void
9465 vms_image_init(int *argcp, char ***argvp)
9466 {
9467   int status;
9468   char eqv[LNM$C_NAMLENGTH+1] = "";
9469   unsigned int len, tabct = 8, tabidx = 0;
9470   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9471   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9472   unsigned short int dummy, rlen;
9473   struct dsc$descriptor_s **tabvec;
9474 #if defined(PERL_IMPLICIT_CONTEXT)
9475   pTHX = NULL;
9476 #endif
9477   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9478                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9479                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9480                                  {          0,                0,    0,      0} };
9481
9482 #ifdef KILL_BY_SIGPRC
9483     Perl_csighandler_init();
9484 #endif
9485
9486 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9487     /* This was moved from the pre-image init handler because on threaded */
9488     /* Perl it was always returning 0 for the default value. */
9489     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9490     if (status > 0) {
9491         int s;
9492         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9493         if (s > 0) {
9494             int initial;
9495             initial = decc$feature_get_value(s, 4);
9496             if (initial > 0) {
9497                 /* initial is: 0 if nothing has set the feature */
9498                 /*            -1 if initialized to default */
9499                 /*             1 if set by logical name */
9500                 /*             2 if set by decc$feature_set_value */
9501                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9502
9503                 /* If the value is not valid, force the feature off */
9504                 if (decc_disable_posix_root < 0) {
9505                     decc$feature_set_value(s, 1, 1);
9506                     decc_disable_posix_root = 1;
9507                 }
9508             }
9509             else {
9510                 /* Nothing has asked for it explicitly, so use our own default. */
9511                 decc_disable_posix_root = 1;
9512                 decc$feature_set_value(s, 1, 1);
9513             }
9514         }
9515     }
9516 #endif
9517
9518   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9519   _ckvmssts_noperl(iosb[0]);
9520   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9521     if (iprv[i]) {           /* Running image installed with privs? */
9522       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9523       will_taint = TRUE;
9524       break;
9525     }
9526   }
9527   /* Rights identifiers might trigger tainting as well. */
9528   if (!will_taint && (rlen || rsz)) {
9529     while (rlen < rsz) {
9530       /* We didn't get all the identifiers on the first pass.  Allocate a
9531        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9532        * were needed to hold all identifiers at time of last call; we'll
9533        * allocate that many unsigned long ints), and go back and get 'em.
9534        * If it gave us less than it wanted to despite ample buffer space,
9535        * something's broken.  Is your system missing a system identifier?
9536        */
9537       if (rsz <= jpilist[1].buflen) {
9538          /* Perl_croak accvios when used this early in startup. */
9539          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9540                          rsz, (unsigned long) jpilist[1].buflen,
9541                          "Check your rights database for corruption.\n");
9542          exit(SS$_ABORT);
9543       }
9544       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9545       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9546       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9547       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9548       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9549       _ckvmssts_noperl(iosb[0]);
9550     }
9551     mask = (unsigned long int *)jpilist[1].bufadr;
9552     /* Check attribute flags for each identifier (2nd longword); protected
9553      * subsystem identifiers trigger tainting.
9554      */
9555     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9556       if (mask[i] & KGB$M_SUBSYSTEM) {
9557         will_taint = TRUE;
9558         break;
9559       }
9560     }
9561     if (mask != rlst) PerlMem_free(mask);
9562   }
9563
9564   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9565    * logical, some versions of the CRTL will add a phanthom /000000/
9566    * directory.  This needs to be removed.
9567    */
9568   if (decc_filename_unix_report) {
9569   char * zeros;
9570   int ulen;
9571     ulen = strlen(argvp[0][0]);
9572     if (ulen > 7) {
9573       zeros = strstr(argvp[0][0], "/000000/");
9574       if (zeros != NULL) {
9575         int mlen;
9576         mlen = ulen - (zeros - argvp[0][0]) - 7;
9577         memmove(zeros, &zeros[7], mlen);
9578         ulen = ulen - 7;
9579         argvp[0][0][ulen] = '\0';
9580       }
9581     }
9582     /* It also may have a trailing dot that needs to be removed otherwise
9583      * it will be converted to VMS mode incorrectly.
9584      */
9585     ulen--;
9586     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9587       argvp[0][0][ulen] = '\0';
9588   }
9589
9590   /* We need to use this hack to tell Perl it should run with tainting,
9591    * since its tainting flag may be part of the PL_curinterp struct, which
9592    * hasn't been allocated when vms_image_init() is called.
9593    */
9594   if (will_taint) {
9595     char **newargv, **oldargv;
9596     oldargv = *argvp;
9597     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9598     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9599     newargv[0] = oldargv[0];
9600     newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9601     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9602     strcpy(newargv[1], "-T");
9603     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9604     (*argcp)++;
9605     newargv[*argcp] = NULL;
9606     /* We orphan the old argv, since we don't know where it's come from,
9607      * so we don't know how to free it.
9608      */
9609     *argvp = newargv;
9610   }
9611   else {  /* Did user explicitly request tainting? */
9612     int i;
9613     char *cp, **av = *argvp;
9614     for (i = 1; i < *argcp; i++) {
9615       if (*av[i] != '-') break;
9616       for (cp = av[i]+1; *cp; cp++) {
9617         if (*cp == 'T') { will_taint = 1; break; }
9618         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9619                   strchr("DFIiMmx",*cp)) break;
9620       }
9621       if (will_taint) break;
9622     }
9623   }
9624
9625   for (tabidx = 0;
9626        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9627        tabidx++) {
9628     if (!tabidx) {
9629       tabvec = (struct dsc$descriptor_s **)
9630             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9631       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9632     }
9633     else if (tabidx >= tabct) {
9634       tabct += 8;
9635       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9636       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9637     }
9638     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9639     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9640     tabvec[tabidx]->dsc$w_length  = len;
9641     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9642     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_S;
9643     tabvec[tabidx]->dsc$a_pointer = (char *)PerlMem_malloc(len + 1);
9644     if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9645     my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
9646   }
9647   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9648
9649   getredirection(argcp,argvp);
9650 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9651   {
9652 # include <reentrancy.h>
9653   decc$set_reentrancy(C$C_MULTITHREAD);
9654   }
9655 #endif
9656   return;
9657 }
9658 /*}}}*/
9659
9660
9661 /* trim_unixpath()
9662  * Trim Unix-style prefix off filespec, so it looks like what a shell
9663  * glob expansion would return (i.e. from specified prefix on, not
9664  * full path).  Note that returned filespec is Unix-style, regardless
9665  * of whether input filespec was VMS-style or Unix-style.
9666  *
9667  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9668  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9669  * vector of options; at present, only bit 0 is used, and if set tells
9670  * trim unixpath to try the current default directory as a prefix when
9671  * presented with a possibly ambiguous ... wildcard.
9672  *
9673  * Returns !=0 on success, with trimmed filespec replacing contents of
9674  * fspec, and 0 on failure, with contents of fpsec unchanged.
9675  */
9676 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9677 int
9678 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9679 {
9680   char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9681   int tmplen, reslen = 0, dirs = 0;
9682
9683   if (!wildspec || !fspec) return 0;
9684
9685   unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9686   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9687   tplate = unixwild;
9688   if (strpbrk(wildspec,"]>:") != NULL) {
9689     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9690         PerlMem_free(unixwild);
9691         return 0;
9692     }
9693   }
9694   else {
9695     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9696   }
9697   unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9698   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9699   if (strpbrk(fspec,"]>:") != NULL) {
9700     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9701         PerlMem_free(unixwild);
9702         PerlMem_free(unixified);
9703         return 0;
9704     }
9705     else base = unixified;
9706     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9707      * check to see that final result fits into (isn't longer than) fspec */
9708     reslen = strlen(fspec);
9709   }
9710   else base = fspec;
9711
9712   /* No prefix or absolute path on wildcard, so nothing to remove */
9713   if (!*tplate || *tplate == '/') {
9714     PerlMem_free(unixwild);
9715     if (base == fspec) {
9716         PerlMem_free(unixified);
9717         return 1;
9718     }
9719     tmplen = strlen(unixified);
9720     if (tmplen > reslen) {
9721         PerlMem_free(unixified);
9722         return 0;  /* not enough space */
9723     }
9724     /* Copy unixified resultant, including trailing NUL */
9725     memmove(fspec,unixified,tmplen+1);
9726     PerlMem_free(unixified);
9727     return 1;
9728   }
9729
9730   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9731   if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9732     for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9733     for (cp1 = end ;cp1 >= base; cp1--)
9734       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9735         { cp1++; break; }
9736     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9737     PerlMem_free(unixified);
9738     PerlMem_free(unixwild);
9739     return 1;
9740   }
9741   else {
9742     char *tpl, *lcres;
9743     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9744     int ells = 1, totells, segdirs, match;
9745     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9746                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9747
9748     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9749     totells = ells;
9750     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9751     tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9752     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9753     if (ellipsis == tplate && opts & 1) {
9754       /* Template begins with an ellipsis.  Since we can't tell how many
9755        * directory names at the front of the resultant to keep for an
9756        * arbitrary starting point, we arbitrarily choose the current
9757        * default directory as a starting point.  If it's there as a prefix,
9758        * clip it off.  If not, fall through and act as if the leading
9759        * ellipsis weren't there (i.e. return shortest possible path that
9760        * could match template).
9761        */
9762       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9763           PerlMem_free(tpl);
9764           PerlMem_free(unixified);
9765           PerlMem_free(unixwild);
9766           return 0;
9767       }
9768       if (!decc_efs_case_preserve) {
9769         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9770           if (_tolower(*cp1) != _tolower(*cp2)) break;
9771       }
9772       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9773       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9774       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9775         memmove(fspec,cp2+1,end - cp2);
9776         PerlMem_free(tpl);
9777         PerlMem_free(unixified);
9778         PerlMem_free(unixwild);
9779         return 1;
9780       }
9781     }
9782     /* First off, back up over constant elements at end of path */
9783     if (dirs) {
9784       for (front = end ; front >= base; front--)
9785          if (*front == '/' && !dirs--) { front++; break; }
9786     }
9787     lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9788     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9789     for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9790          cp1++,cp2++) {
9791             if (!decc_efs_case_preserve) {
9792                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9793             }
9794             else {
9795                 *cp2 = *cp1;
9796             }
9797     }
9798     if (cp1 != '\0') {
9799         PerlMem_free(tpl);
9800         PerlMem_free(unixified);
9801         PerlMem_free(unixwild);
9802         PerlMem_free(lcres);
9803         return 0;  /* Path too long. */
9804     }
9805     lcend = cp2;
9806     *cp2 = '\0';  /* Pick up with memcpy later */
9807     lcfront = lcres + (front - base);
9808     /* Now skip over each ellipsis and try to match the path in front of it. */
9809     while (ells--) {
9810       for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9811         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9812             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9813       if (cp1 < tplate) break; /* template started with an ellipsis */
9814       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9815         ellipsis = cp1; continue;
9816       }
9817       wilddsc.dsc$a_pointer = tpl;
9818       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9819       nextell = cp1;
9820       for (segdirs = 0, cp2 = tpl;
9821            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9822            cp1++, cp2++) {
9823          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9824          else {
9825             if (!decc_efs_case_preserve) {
9826               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9827             }
9828             else {
9829               *cp2 = *cp1;  /* else preserve case for match */
9830             }
9831          }
9832          if (*cp2 == '/') segdirs++;
9833       }
9834       if (cp1 != ellipsis - 1) {
9835           PerlMem_free(tpl);
9836           PerlMem_free(unixified);
9837           PerlMem_free(unixwild);
9838           PerlMem_free(lcres);
9839           return 0; /* Path too long */
9840       }
9841       /* Back up at least as many dirs as in template before matching */
9842       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9843         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9844       for (match = 0; cp1 > lcres;) {
9845         resdsc.dsc$a_pointer = cp1;
9846         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9847           match++;
9848           if (match == 1) lcfront = cp1;
9849         }
9850         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9851       }
9852       if (!match) {
9853         PerlMem_free(tpl);
9854         PerlMem_free(unixified);
9855         PerlMem_free(unixwild);
9856         PerlMem_free(lcres);
9857         return 0;  /* Can't find prefix ??? */
9858       }
9859       if (match > 1 && opts & 1) {
9860         /* This ... wildcard could cover more than one set of dirs (i.e.
9861          * a set of similar dir names is repeated).  If the template
9862          * contains more than 1 ..., upstream elements could resolve the
9863          * ambiguity, but it's not worth a full backtracking setup here.
9864          * As a quick heuristic, clip off the current default directory
9865          * if it's present to find the trimmed spec, else use the
9866          * shortest string that this ... could cover.
9867          */
9868         char def[NAM$C_MAXRSS+1], *st;
9869
9870         if (getcwd(def, sizeof def,0) == NULL) {
9871             PerlMem_free(unixified);
9872             PerlMem_free(unixwild);
9873             PerlMem_free(lcres);
9874             PerlMem_free(tpl);
9875             return 0;
9876         }
9877         if (!decc_efs_case_preserve) {
9878           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9879             if (_tolower(*cp1) != _tolower(*cp2)) break;
9880         }
9881         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9882         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9883         if (*cp1 == '\0' && *cp2 == '/') {
9884           memmove(fspec,cp2+1,end - cp2);
9885           PerlMem_free(tpl);
9886           PerlMem_free(unixified);
9887           PerlMem_free(unixwild);
9888           PerlMem_free(lcres);
9889           return 1;
9890         }
9891         /* Nope -- stick with lcfront from above and keep going. */
9892       }
9893     }
9894     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9895     PerlMem_free(tpl);
9896     PerlMem_free(unixified);
9897     PerlMem_free(unixwild);
9898     PerlMem_free(lcres);
9899     return 1;
9900   }
9901
9902 }  /* end of trim_unixpath() */
9903 /*}}}*/
9904
9905
9906 /*
9907  *  VMS readdir() routines.
9908  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9909  *
9910  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9911  *  Minor modifications to original routines.
9912  */
9913
9914 /* readdir may have been redefined by reentr.h, so make sure we get
9915  * the local version for what we do here.
9916  */
9917 #ifdef readdir
9918 # undef readdir
9919 #endif
9920 #if !defined(PERL_IMPLICIT_CONTEXT)
9921 # define readdir Perl_readdir
9922 #else
9923 # define readdir(a) Perl_readdir(aTHX_ a)
9924 #endif
9925
9926     /* Number of elements in vms_versions array */
9927 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9928
9929 /*
9930  *  Open a directory, return a handle for later use.
9931  */
9932 /*{{{ DIR *opendir(char*name) */
9933 DIR *
9934 Perl_opendir(pTHX_ const char *name)
9935 {
9936     DIR *dd;
9937     char *dir;
9938     Stat_t sb;
9939
9940     Newx(dir, VMS_MAXRSS, char);
9941     if (int_tovmspath(name, dir, NULL) == NULL) {
9942       Safefree(dir);
9943       return NULL;
9944     }
9945     /* Check access before stat; otherwise stat does not
9946      * accurately report whether it's a directory.
9947      */
9948     if (!strstr(dir, "::") /* sys$check_access doesn't do remotes */
9949         && !cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9950       /* cando_by_name has already set errno */
9951       Safefree(dir);
9952       return NULL;
9953     }
9954     if (flex_stat(dir,&sb) == -1) return NULL;
9955     if (!S_ISDIR(sb.st_mode)) {
9956       Safefree(dir);
9957       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9958       return NULL;
9959     }
9960     /* Get memory for the handle, and the pattern. */
9961     Newx(dd,1,DIR);
9962     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9963
9964     /* Fill in the fields; mainly playing with the descriptor. */
9965     sprintf(dd->pattern, "%s*.*",dir);
9966     Safefree(dir);
9967     dd->context = 0;
9968     dd->count = 0;
9969     dd->flags = 0;
9970     /* By saying we want the result of readdir() in unix format, we are really
9971      * saying we want all the escapes removed, translating characters that
9972      * must be escaped in a VMS-format name to their unescaped form, which is
9973      * presumably allowed in a Unix-format name.
9974      */
9975     dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
9976     dd->pat.dsc$a_pointer = dd->pattern;
9977     dd->pat.dsc$w_length = strlen(dd->pattern);
9978     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9979     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9980 #if defined(USE_ITHREADS)
9981     Newx(dd->mutex,1,perl_mutex);
9982     MUTEX_INIT( (perl_mutex *) dd->mutex );
9983 #else
9984     dd->mutex = NULL;
9985 #endif
9986
9987     return dd;
9988 }  /* end of opendir() */
9989 /*}}}*/
9990
9991 /*
9992  *  Set the flag to indicate we want versions or not.
9993  */
9994 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9995 void
9996 vmsreaddirversions(DIR *dd, int flag)
9997 {
9998     if (flag)
9999         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10000     else
10001         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10002 }
10003 /*}}}*/
10004
10005 /*
10006  *  Free up an opened directory.
10007  */
10008 /*{{{ void closedir(DIR *dd)*/
10009 void
10010 Perl_closedir(DIR *dd)
10011 {
10012     int sts;
10013
10014     sts = lib$find_file_end(&dd->context);
10015     Safefree(dd->pattern);
10016 #if defined(USE_ITHREADS)
10017     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10018     Safefree(dd->mutex);
10019 #endif
10020     Safefree(dd);
10021 }
10022 /*}}}*/
10023
10024 /*
10025  *  Collect all the version numbers for the current file.
10026  */
10027 static void
10028 collectversions(pTHX_ DIR *dd)
10029 {
10030     struct dsc$descriptor_s     pat;
10031     struct dsc$descriptor_s     res;
10032     struct dirent *e;
10033     char *p, *text, *buff;
10034     int i;
10035     unsigned long context, tmpsts;
10036
10037     /* Convenient shorthand. */
10038     e = &dd->entry;
10039
10040     /* Add the version wildcard, ignoring the "*.*" put on before */
10041     i = strlen(dd->pattern);
10042     Newx(text,i + e->d_namlen + 3,char);
10043     my_strlcpy(text, dd->pattern, i + 1);
10044     sprintf(&text[i - 3], "%s;*", e->d_name);
10045
10046     /* Set up the pattern descriptor. */
10047     pat.dsc$a_pointer = text;
10048     pat.dsc$w_length = i + e->d_namlen - 1;
10049     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10050     pat.dsc$b_class = DSC$K_CLASS_S;
10051
10052     /* Set up result descriptor. */
10053     Newx(buff, VMS_MAXRSS, char);
10054     res.dsc$a_pointer = buff;
10055     res.dsc$w_length = VMS_MAXRSS - 1;
10056     res.dsc$b_dtype = DSC$K_DTYPE_T;
10057     res.dsc$b_class = DSC$K_CLASS_S;
10058
10059     /* Read files, collecting versions. */
10060     for (context = 0, e->vms_verscount = 0;
10061          e->vms_verscount < VERSIZE(e);
10062          e->vms_verscount++) {
10063         unsigned long rsts;
10064         unsigned long flags = 0;
10065
10066 #ifdef VMS_LONGNAME_SUPPORT
10067         flags = LIB$M_FIL_LONG_NAMES;
10068 #endif
10069         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10070         if (tmpsts == RMS$_NMF || context == 0) break;
10071         _ckvmssts(tmpsts);
10072         buff[VMS_MAXRSS - 1] = '\0';
10073         if ((p = strchr(buff, ';')))
10074             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10075         else
10076             e->vms_versions[e->vms_verscount] = -1;
10077     }
10078
10079     _ckvmssts(lib$find_file_end(&context));
10080     Safefree(text);
10081     Safefree(buff);
10082
10083 }  /* end of collectversions() */
10084
10085 /*
10086  *  Read the next entry from the directory.
10087  */
10088 /*{{{ struct dirent *readdir(DIR *dd)*/
10089 struct dirent *
10090 Perl_readdir(pTHX_ DIR *dd)
10091 {
10092     struct dsc$descriptor_s     res;
10093     char *p, *buff;
10094     unsigned long int tmpsts;
10095     unsigned long rsts;
10096     unsigned long flags = 0;
10097     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10098     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10099
10100     /* Set up result descriptor, and get next file. */
10101     Newx(buff, VMS_MAXRSS, char);
10102     res.dsc$a_pointer = buff;
10103     res.dsc$w_length = VMS_MAXRSS - 1;
10104     res.dsc$b_dtype = DSC$K_DTYPE_T;
10105     res.dsc$b_class = DSC$K_CLASS_S;
10106
10107 #ifdef VMS_LONGNAME_SUPPORT
10108     flags = LIB$M_FIL_LONG_NAMES;
10109 #endif
10110
10111     tmpsts = lib$find_file
10112         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10113     if (dd->context == 0)
10114         tmpsts = RMS$_NMF;  /* None left. (should be set, but make sure) */
10115
10116     if (!(tmpsts & 1)) {
10117       switch (tmpsts) {
10118         case RMS$_NMF:
10119           break;  /* no more files considered success */
10120         case RMS$_PRV:
10121           SETERRNO(EACCES, tmpsts); break;
10122         case RMS$_DEV:
10123           SETERRNO(ENODEV, tmpsts); break;
10124         case RMS$_DIR:
10125           SETERRNO(ENOTDIR, tmpsts); break;
10126         case RMS$_FNF: case RMS$_DNF:
10127           SETERRNO(ENOENT, tmpsts); break;
10128         default:
10129           SETERRNO(EVMSERR, tmpsts);
10130       }
10131       Safefree(buff);
10132       return NULL;
10133     }
10134     dd->count++;
10135     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10136     buff[res.dsc$w_length] = '\0';
10137     p = buff + res.dsc$w_length;
10138     while (--p >= buff) if (!isspace(*p)) break;
10139     *p = '\0';
10140     if (!decc_efs_case_preserve) {
10141       for (p = buff; *p; p++) *p = _tolower(*p);
10142     }
10143
10144     /* Skip any directory component and just copy the name. */
10145     sts = vms_split_path
10146        (buff,
10147         &v_spec,
10148         &v_len,
10149         &r_spec,
10150         &r_len,
10151         &d_spec,
10152         &d_len,
10153         &n_spec,
10154         &n_len,
10155         &e_spec,
10156         &e_len,
10157         &vs_spec,
10158         &vs_len);
10159
10160     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10161
10162         /* In Unix report mode, remove the ".dir;1" from the name */
10163         /* if it is a real directory. */
10164         if (decc_filename_unix_report && decc_efs_charset) {
10165             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10166                 Stat_t statbuf;
10167                 int ret_sts;
10168
10169                 ret_sts = flex_lstat(buff, &statbuf);
10170                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10171                     e_len = 0;
10172                     e_spec[0] = 0;
10173                 }
10174             }
10175         }
10176
10177         /* Drop NULL extensions on UNIX file specification */
10178         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10179             e_len = 0;
10180             e_spec[0] = '\0';
10181         }
10182     }
10183
10184     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10185     dd->entry.d_name[n_len + e_len] = '\0';
10186     dd->entry.d_namlen = n_len + e_len;
10187
10188     /* Convert the filename to UNIX format if needed */
10189     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10190
10191         /* Translate the encoded characters. */
10192         /* Fixme: Unicode handling could result in embedded 0 characters */
10193         if (strchr(dd->entry.d_name, '^') != NULL) {
10194             char new_name[256];
10195             char * q;
10196             p = dd->entry.d_name;
10197             q = new_name;
10198             while (*p != 0) {
10199                 int inchars_read, outchars_added;
10200                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10201                 p += inchars_read;
10202                 q += outchars_added;
10203                 /* fix-me */
10204                 /* if outchars_added > 1, then this is a wide file specification */
10205                 /* Wide file specifications need to be passed in Perl */
10206                 /* counted strings apparently with a Unicode flag */
10207             }
10208             *q = 0;
10209             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10210         }
10211     }
10212
10213     dd->entry.vms_verscount = 0;
10214     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10215     Safefree(buff);
10216     return &dd->entry;
10217
10218 }  /* end of readdir() */
10219 /*}}}*/
10220
10221 /*
10222  *  Read the next entry from the directory -- thread-safe version.
10223  */
10224 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10225 int
10226 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10227 {
10228     int retval;
10229
10230     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10231
10232     entry = readdir(dd);
10233     *result = entry;
10234     retval = ( *result == NULL ? errno : 0 );
10235
10236     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10237
10238     return retval;
10239
10240 }  /* end of readdir_r() */
10241 /*}}}*/
10242
10243 /*
10244  *  Return something that can be used in a seekdir later.
10245  */
10246 /*{{{ long telldir(DIR *dd)*/
10247 long
10248 Perl_telldir(DIR *dd)
10249 {
10250     return dd->count;
10251 }
10252 /*}}}*/
10253
10254 /*
10255  *  Return to a spot where we used to be.  Brute force.
10256  */
10257 /*{{{ void seekdir(DIR *dd,long count)*/
10258 void
10259 Perl_seekdir(pTHX_ DIR *dd, long count)
10260 {
10261     int old_flags;
10262
10263     /* If we haven't done anything yet... */
10264     if (dd->count == 0)
10265         return;
10266
10267     /* Remember some state, and clear it. */
10268     old_flags = dd->flags;
10269     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10270     _ckvmssts(lib$find_file_end(&dd->context));
10271     dd->context = 0;
10272
10273     /* The increment is in readdir(). */
10274     for (dd->count = 0; dd->count < count; )
10275         readdir(dd);
10276
10277     dd->flags = old_flags;
10278
10279 }  /* end of seekdir() */
10280 /*}}}*/
10281
10282 /* VMS subprocess management
10283  *
10284  * my_vfork() - just a vfork(), after setting a flag to record that
10285  * the current script is trying a Unix-style fork/exec.
10286  *
10287  * vms_do_aexec() and vms_do_exec() are called in response to the
10288  * perl 'exec' function.  If this follows a vfork call, then they
10289  * call out the regular perl routines in doio.c which do an
10290  * execvp (for those who really want to try this under VMS).
10291  * Otherwise, they do exactly what the perl docs say exec should
10292  * do - terminate the current script and invoke a new command
10293  * (See below for notes on command syntax.)
10294  *
10295  * do_aspawn() and do_spawn() implement the VMS side of the perl
10296  * 'system' function.
10297  *
10298  * Note on command arguments to perl 'exec' and 'system': When handled
10299  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10300  * are concatenated to form a DCL command string.  If the first non-numeric
10301  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10302  * the command string is handed off to DCL directly.  Otherwise,
10303  * the first token of the command is taken as the filespec of an image
10304  * to run.  The filespec is expanded using a default type of '.EXE' and
10305  * the process defaults for device, directory, etc., and if found, the resultant
10306  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10307  * the command string as parameters.  This is perhaps a bit complicated,
10308  * but I hope it will form a happy medium between what VMS folks expect
10309  * from lib$spawn and what Unix folks expect from exec.
10310  */
10311
10312 static int vfork_called;
10313
10314 /*{{{int my_vfork(void)*/
10315 int
10316 my_vfork(void)
10317 {
10318   vfork_called++;
10319   return vfork();
10320 }
10321 /*}}}*/
10322
10323
10324 static void
10325 vms_execfree(struct dsc$descriptor_s *vmscmd)
10326 {
10327   if (vmscmd) {
10328       if (vmscmd->dsc$a_pointer) {
10329           PerlMem_free(vmscmd->dsc$a_pointer);
10330       }
10331       PerlMem_free(vmscmd);
10332   }
10333 }
10334
10335 static char *
10336 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10337 {
10338   char *junk, *tmps = NULL;
10339   size_t cmdlen = 0;
10340   size_t rlen;
10341   SV **idx;
10342   STRLEN n_a;
10343
10344   idx = mark;
10345   if (really) {
10346     tmps = SvPV(really,rlen);
10347     if (*tmps) {
10348       cmdlen += rlen + 1;
10349       idx++;
10350     }
10351   }
10352
10353   for (idx++; idx <= sp; idx++) {
10354     if (*idx) {
10355       junk = SvPVx(*idx,rlen);
10356       cmdlen += rlen ? rlen + 1 : 0;
10357     }
10358   }
10359   Newx(PL_Cmd, cmdlen+1, char);
10360
10361   if (tmps && *tmps) {
10362     my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10363     mark++;
10364   }
10365   else *PL_Cmd = '\0';
10366   while (++mark <= sp) {
10367     if (*mark) {
10368       char *s = SvPVx(*mark,n_a);
10369       if (!*s) continue;
10370       if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10371       my_strlcat(PL_Cmd, s, cmdlen+1);
10372     }
10373   }
10374   return PL_Cmd;
10375
10376 }  /* end of setup_argstr() */
10377
10378
10379 static unsigned long int
10380 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10381                    struct dsc$descriptor_s **pvmscmd)
10382 {
10383   char * vmsspec;
10384   char * resspec;
10385   char image_name[NAM$C_MAXRSS+1];
10386   char image_argv[NAM$C_MAXRSS+1];
10387   $DESCRIPTOR(defdsc,".EXE");
10388   $DESCRIPTOR(defdsc2,".");
10389   struct dsc$descriptor_s resdsc;
10390   struct dsc$descriptor_s *vmscmd;
10391   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10392   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10393   char *s, *rest, *cp, *wordbreak;
10394   char * cmd;
10395   int cmdlen;
10396   int isdcl;
10397
10398   vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10399   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10400
10401   /* vmsspec is a DCL command buffer, not just a filename */
10402   vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10403   if (vmsspec == NULL)
10404       _ckvmssts_noperl(SS$_INSFMEM);
10405
10406   resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10407   if (resspec == NULL)
10408       _ckvmssts_noperl(SS$_INSFMEM);
10409
10410   /* Make a copy for modification */
10411   cmdlen = strlen(incmd);
10412   cmd = (char *)PerlMem_malloc(cmdlen+1);
10413   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10414   my_strlcpy(cmd, incmd, cmdlen + 1);
10415   image_name[0] = 0;
10416   image_argv[0] = 0;
10417
10418   resdsc.dsc$a_pointer = resspec;
10419   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10420   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10421   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10422
10423   vmscmd->dsc$a_pointer = NULL;
10424   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10425   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10426   vmscmd->dsc$w_length = 0;
10427   if (pvmscmd) *pvmscmd = vmscmd;
10428
10429   if (suggest_quote) *suggest_quote = 0;
10430
10431   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10432     PerlMem_free(cmd);
10433     PerlMem_free(vmsspec);
10434     PerlMem_free(resspec);
10435     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10436   }
10437
10438   s = cmd;
10439
10440   while (*s && isspace(*s)) s++;
10441
10442   if (*s == '@' || *s == '$') {
10443     vmsspec[0] = *s;  rest = s + 1;
10444     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10445   }
10446   else { cp = vmsspec; rest = s; }
10447
10448   /* If the first word is quoted, then we need to unquote it and
10449    * escape spaces within it.  We'll expand into the resspec buffer,
10450    * then copy back into the cmd buffer, expanding the latter if
10451    * necessary.
10452    */
10453   if (*rest == '"') {
10454     char *cp2;
10455     char *r = rest;
10456     bool in_quote = 0;
10457     int clen = cmdlen;
10458     int soff = s - cmd;
10459
10460     for (cp2 = resspec;
10461          *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10462          rest++) {
10463
10464       if (*rest == ' ') {    /* Escape ' ' to '^_'. */
10465         *cp2 = '^';
10466         *(++cp2) = '_';
10467         cp2++;
10468         clen++;
10469       }
10470       else if (*rest == '"') {
10471         clen--;
10472         if (in_quote) {     /* Must be closing quote. */
10473           rest++;
10474           break;
10475         }
10476         in_quote = 1;
10477       }
10478       else {
10479         *cp2 = *rest;
10480         cp2++;
10481       }
10482     }
10483     *cp2 = '\0';
10484
10485     /* Expand the command buffer if necessary. */
10486     if (clen > cmdlen) {
10487       cmd = (char *)PerlMem_realloc(cmd, clen);
10488       if (cmd == NULL)
10489         _ckvmssts_noperl(SS$_INSFMEM);
10490       /* Where we are may have changed, so recompute offsets */
10491       r = cmd + (r - s - soff);
10492       rest = cmd + (rest - s - soff);
10493       s = cmd + soff;
10494     }
10495
10496     /* Shift the non-verb portion of the command (if any) up or
10497      * down as necessary.
10498      */
10499     if (*rest)
10500       memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10501
10502     /* Copy the unquoted and escaped command verb into place. */
10503     memcpy(r, resspec, cp2 - resspec);
10504     cmd[clen] = '\0';
10505     cmdlen = clen;
10506     rest = r;         /* Rewind for subsequent operations. */
10507   }
10508
10509   if (*rest == '.' || *rest == '/') {
10510     char *cp2;
10511     for (cp2 = resspec;
10512          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10513          rest++, cp2++) *cp2 = *rest;
10514     *cp2 = '\0';
10515     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10516       s = vmsspec;
10517
10518       /* When a UNIX spec with no file type is translated to VMS, */
10519       /* A trailing '.' is appended under ODS-5 rules.            */
10520       /* Here we do not want that trailing "." as it prevents     */
10521       /* Looking for a implied ".exe" type. */
10522       if (decc_efs_charset) {
10523           int i;
10524           i = strlen(vmsspec);
10525           if (vmsspec[i-1] == '.') {
10526               vmsspec[i-1] = '\0';
10527           }
10528       }
10529
10530       if (*rest) {
10531         for (cp2 = vmsspec + strlen(vmsspec);
10532              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10533              rest++, cp2++) *cp2 = *rest;
10534         *cp2 = '\0';
10535       }
10536     }
10537   }
10538   /* Intuit whether verb (first word of cmd) is a DCL command:
10539    *   - if first nonspace char is '@', it's a DCL indirection
10540    * otherwise
10541    *   - if verb contains a filespec separator, it's not a DCL command
10542    *   - if it doesn't, caller tells us whether to default to a DCL
10543    *     command, or to a local image unless told it's DCL (by leading '$')
10544    */
10545   if (*s == '@') {
10546       isdcl = 1;
10547       if (suggest_quote) *suggest_quote = 1;
10548   } else {
10549     char *filespec = strpbrk(s,":<[.;");
10550     rest = wordbreak = strpbrk(s," \"\t/");
10551     if (!wordbreak) wordbreak = s + strlen(s);
10552     if (*s == '$') check_img = 0;
10553     if (filespec && (filespec < wordbreak)) isdcl = 0;
10554     else isdcl = !check_img;
10555   }
10556
10557   if (!isdcl) {
10558     int rsts;
10559     imgdsc.dsc$a_pointer = s;
10560     imgdsc.dsc$w_length = wordbreak - s;
10561     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10562     if (!(retsts&1)) {
10563         _ckvmssts_noperl(lib$find_file_end(&cxt));
10564         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10565       if (!(retsts & 1) && *s == '$') {
10566         _ckvmssts_noperl(lib$find_file_end(&cxt));
10567         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10568         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10569         if (!(retsts&1)) {
10570           _ckvmssts_noperl(lib$find_file_end(&cxt));
10571           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10572         }
10573       }
10574     }
10575     _ckvmssts_noperl(lib$find_file_end(&cxt));
10576
10577     if (retsts & 1) {
10578       FILE *fp;
10579       s = resspec;
10580       while (*s && !isspace(*s)) s++;
10581       *s = '\0';
10582
10583       /* check that it's really not DCL with no file extension */
10584       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10585       if (fp) {
10586         char b[256] = {0,0,0,0};
10587         read(fileno(fp), b, 256);
10588         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10589         if (isdcl) {
10590           int shebang_len;
10591
10592           /* Check for script */
10593           shebang_len = 0;
10594           if ((b[0] == '#') && (b[1] == '!'))
10595              shebang_len = 2;
10596 #ifdef ALTERNATE_SHEBANG
10597           else {
10598             shebang_len = strlen(ALTERNATE_SHEBANG);
10599             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10600               char * perlstr;
10601                 perlstr = strstr("perl",b);
10602                 if (perlstr == NULL)
10603                   shebang_len = 0;
10604             }
10605             else
10606               shebang_len = 0;
10607           }
10608 #endif
10609
10610           if (shebang_len > 0) {
10611           int i;
10612           int j;
10613           char tmpspec[NAM$C_MAXRSS + 1];
10614
10615             i = shebang_len;
10616              /* Image is following after white space */
10617             /*--------------------------------------*/
10618             while (isprint(b[i]) && isspace(b[i]))
10619                 i++;
10620
10621             j = 0;
10622             while (isprint(b[i]) && !isspace(b[i])) {
10623                 tmpspec[j++] = b[i++];
10624                 if (j >= NAM$C_MAXRSS)
10625                    break;
10626             }
10627             tmpspec[j] = '\0';
10628
10629              /* There may be some default parameters to the image */
10630             /*---------------------------------------------------*/
10631             j = 0;
10632             while (isprint(b[i])) {
10633                 image_argv[j++] = b[i++];
10634                 if (j >= NAM$C_MAXRSS)
10635                    break;
10636             }
10637             while ((j > 0) && !isprint(image_argv[j-1]))
10638                 j--;
10639             image_argv[j] = 0;
10640
10641             /* It will need to be converted to VMS format and validated */
10642             if (tmpspec[0] != '\0') {
10643               char * iname;
10644
10645                /* Try to find the exact program requested to be run */
10646               /*---------------------------------------------------*/
10647               iname = int_rmsexpand
10648                  (tmpspec, image_name, ".exe",
10649                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10650               if (iname != NULL) {
10651                 if (cando_by_name_int
10652                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10653                   /* MCR prefix needed */
10654                   isdcl = 0;
10655                 }
10656                 else {
10657                    /* Try again with a null type */
10658                   /*----------------------------*/
10659                   iname = int_rmsexpand
10660                     (tmpspec, image_name, ".",
10661                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10662                   if (iname != NULL) {
10663                     if (cando_by_name_int
10664                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10665                       /* MCR prefix needed */
10666                       isdcl = 0;
10667                     }
10668                   }
10669                 }
10670
10671                  /* Did we find the image to run the script? */
10672                 /*------------------------------------------*/
10673                 if (isdcl) {
10674                   char *tchr;
10675
10676                    /* Assume DCL or foreign command exists */
10677                   /*--------------------------------------*/
10678                   tchr = strrchr(tmpspec, '/');
10679                   if (tchr != NULL) {
10680                     tchr++;
10681                   }
10682                   else {
10683                     tchr = tmpspec;
10684                   }
10685                   my_strlcpy(image_name, tchr, sizeof(image_name));
10686                 }
10687               }
10688             }
10689           }
10690         }
10691         fclose(fp);
10692       }
10693       if (check_img && isdcl) {
10694           PerlMem_free(cmd);
10695           PerlMem_free(resspec);
10696           PerlMem_free(vmsspec);
10697           return RMS$_FNF;
10698       }
10699
10700       if (cando_by_name(S_IXUSR,0,resspec)) {
10701         vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10702         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10703         if (!isdcl) {
10704             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10705             if (image_name[0] != 0) {
10706                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10707                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10708             }
10709         } else if (image_name[0] != 0) {
10710             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10711             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10712         } else {
10713             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10714         }
10715         if (suggest_quote) *suggest_quote = 1;
10716
10717         /* If there is an image name, use original command */
10718         if (image_name[0] == 0)
10719             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10720         else {
10721             rest = cmd;
10722             while (*rest && isspace(*rest)) rest++;
10723         }
10724
10725         if (image_argv[0] != 0) {
10726           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10727           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10728         }
10729         if (rest) {
10730            int rest_len;
10731            int vmscmd_len;
10732
10733            rest_len = strlen(rest);
10734            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10735            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10736               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10737            else
10738              retsts = CLI$_BUFOVF;
10739         }
10740         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10741         PerlMem_free(cmd);
10742         PerlMem_free(vmsspec);
10743         PerlMem_free(resspec);
10744         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10745       }
10746       else
10747         retsts = RMS$_PRV;
10748     }
10749   }
10750   /* It's either a DCL command or we couldn't find a suitable image */
10751   vmscmd->dsc$w_length = strlen(cmd);
10752
10753   vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10754   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10755
10756   PerlMem_free(cmd);
10757   PerlMem_free(resspec);
10758   PerlMem_free(vmsspec);
10759
10760   /* check if it's a symbol (for quoting purposes) */
10761   if (suggest_quote && !*suggest_quote) {
10762     int iss;
10763     char equiv[LNM$C_NAMLENGTH];
10764     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10765     eqvdsc.dsc$a_pointer = equiv;
10766
10767     iss = lib$get_symbol(vmscmd,&eqvdsc);
10768     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10769   }
10770   if (!(retsts & 1)) {
10771     /* just hand off status values likely to be due to user error */
10772     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10773         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10774        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10775     else { _ckvmssts_noperl(retsts); }
10776   }
10777
10778   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10779
10780 }  /* end of setup_cmddsc() */
10781
10782
10783 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10784 bool
10785 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10786 {
10787 bool exec_sts;
10788 char * cmd;
10789
10790   if (sp > mark) {
10791     if (vfork_called) {           /* this follows a vfork - act Unixish */
10792       vfork_called--;
10793       if (vfork_called < 0) {
10794         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10795         vfork_called = 0;
10796       }
10797       else return do_aexec(really,mark,sp);
10798     }
10799                                            /* no vfork - act VMSish */
10800     cmd = setup_argstr(aTHX_ really,mark,sp);
10801     exec_sts = vms_do_exec(cmd);
10802     Safefree(cmd);  /* Clean up from setup_argstr() */
10803     return exec_sts;
10804   }
10805
10806   return FALSE;
10807 }  /* end of vms_do_aexec() */
10808 /*}}}*/
10809
10810 /* {{{bool vms_do_exec(char *cmd) */
10811 bool
10812 Perl_vms_do_exec(pTHX_ const char *cmd)
10813 {
10814   struct dsc$descriptor_s *vmscmd;
10815
10816   if (vfork_called) {             /* this follows a vfork - act Unixish */
10817     vfork_called--;
10818     if (vfork_called < 0) {
10819       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10820       vfork_called = 0;
10821     }
10822     else return do_exec(cmd);
10823   }
10824
10825   {                               /* no vfork - act VMSish */
10826     unsigned long int retsts;
10827
10828     TAINT_ENV();
10829     TAINT_PROPER("exec");
10830     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10831       retsts = lib$do_command(vmscmd);
10832
10833     switch (retsts) {
10834       case RMS$_FNF: case RMS$_DNF:
10835         set_errno(ENOENT); break;
10836       case RMS$_DIR:
10837         set_errno(ENOTDIR); break;
10838       case RMS$_DEV:
10839         set_errno(ENODEV); break;
10840       case RMS$_PRV:
10841         set_errno(EACCES); break;
10842       case RMS$_SYN:
10843         set_errno(EINVAL); break;
10844       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10845         set_errno(E2BIG); break;
10846       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10847         _ckvmssts_noperl(retsts); /* fall through */
10848       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10849         set_errno(EVMSERR);
10850     }
10851     set_vaxc_errno(retsts);
10852     if (ckWARN(WARN_EXEC)) {
10853       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10854              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10855     }
10856     vms_execfree(vmscmd);
10857   }
10858
10859   return FALSE;
10860
10861 }  /* end of vms_do_exec() */
10862 /*}}}*/
10863
10864 int do_spawn2(pTHX_ const char *, int);
10865
10866 int
10867 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10868 {
10869 unsigned long int sts;
10870 char * cmd;
10871 int flags = 0;
10872
10873   if (sp > mark) {
10874
10875     /* We'll copy the (undocumented?) Win32 behavior and allow a
10876      * numeric first argument.  But the only value we'll support
10877      * through do_aspawn is a value of 1, which means spawn without
10878      * waiting for completion -- other values are ignored.
10879      */
10880     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10881         ++mark;
10882         flags = SvIVx(*mark);
10883     }
10884
10885     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10886         flags = CLI$M_NOWAIT;
10887     else
10888         flags = 0;
10889
10890     cmd = setup_argstr(aTHX_ really, mark, sp);
10891     sts = do_spawn2(aTHX_ cmd, flags);
10892     /* pp_sys will clean up cmd */
10893     return sts;
10894   }
10895   return SS$_ABORT;
10896 }  /* end of do_aspawn() */
10897 /*}}}*/
10898
10899
10900 /* {{{int do_spawn(char* cmd) */
10901 int
10902 Perl_do_spawn(pTHX_ char* cmd)
10903 {
10904     PERL_ARGS_ASSERT_DO_SPAWN;
10905
10906     return do_spawn2(aTHX_ cmd, 0);
10907 }
10908 /*}}}*/
10909
10910 /* {{{int do_spawn_nowait(char* cmd) */
10911 int
10912 Perl_do_spawn_nowait(pTHX_ char* cmd)
10913 {
10914     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10915
10916     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10917 }
10918 /*}}}*/
10919
10920 /* {{{int do_spawn2(char *cmd) */
10921 int
10922 do_spawn2(pTHX_ const char *cmd, int flags)
10923 {
10924   unsigned long int sts, substs;
10925
10926   /* The caller of this routine expects to Safefree(PL_Cmd) */
10927   Newx(PL_Cmd,10,char);
10928
10929   TAINT_ENV();
10930   TAINT_PROPER("spawn");
10931   if (!cmd || !*cmd) {
10932     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10933     if (!(sts & 1)) {
10934       switch (sts) {
10935         case RMS$_FNF:  case RMS$_DNF:
10936           set_errno(ENOENT); break;
10937         case RMS$_DIR:
10938           set_errno(ENOTDIR); break;
10939         case RMS$_DEV:
10940           set_errno(ENODEV); break;
10941         case RMS$_PRV:
10942           set_errno(EACCES); break;
10943         case RMS$_SYN:
10944           set_errno(EINVAL); break;
10945         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10946           set_errno(E2BIG); break;
10947         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10948           _ckvmssts_noperl(sts); /* fall through */
10949         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10950           set_errno(EVMSERR);
10951       }
10952       set_vaxc_errno(sts);
10953       if (ckWARN(WARN_EXEC)) {
10954         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10955                     Strerror(errno));
10956       }
10957     }
10958     sts = substs;
10959   }
10960   else {
10961     char mode[3];
10962     PerlIO * fp;
10963     if (flags & CLI$M_NOWAIT)
10964         strcpy(mode, "n");
10965     else
10966         strcpy(mode, "nW");
10967
10968     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10969     if (fp != NULL)
10970       my_pclose(fp);
10971     /* sts will be the pid in the nowait case */
10972   }
10973   return sts;
10974 }  /* end of do_spawn2() */
10975 /*}}}*/
10976
10977
10978 static unsigned int *sockflags, sockflagsize;
10979
10980 /*
10981  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10982  * routines found in some versions of the CRTL can't deal with sockets.
10983  * We don't shim the other file open routines since a socket isn't
10984  * likely to be opened by a name.
10985  */
10986 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10987 FILE *my_fdopen(int fd, const char *mode)
10988 {
10989   FILE *fp = fdopen(fd, mode);
10990
10991   if (fp) {
10992     unsigned int fdoff = fd / sizeof(unsigned int);
10993     Stat_t sbuf; /* native stat; we don't need flex_stat */
10994     if (!sockflagsize || fdoff > sockflagsize) {
10995       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10996       else           Newx  (sockflags,fdoff+2,unsigned int);
10997       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10998       sockflagsize = fdoff + 2;
10999     }
11000     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11001       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11002   }
11003   return fp;
11004
11005 }
11006 /*}}}*/
11007
11008
11009 /*
11010  * Clear the corresponding bit when the (possibly) socket stream is closed.
11011  * There still a small hole: we miss an implicit close which might occur
11012  * via freopen().  >> Todo
11013  */
11014 /*{{{ int my_fclose(FILE *fp)*/
11015 int my_fclose(FILE *fp) {
11016   if (fp) {
11017     unsigned int fd = fileno(fp);
11018     unsigned int fdoff = fd / sizeof(unsigned int);
11019
11020     if (sockflagsize && fdoff < sockflagsize)
11021       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11022   }
11023   return fclose(fp);
11024 }
11025 /*}}}*/
11026
11027
11028 /*
11029  * A simple fwrite replacement which outputs itmsz*nitm chars without
11030  * introducing record boundaries every itmsz chars.
11031  * We are using fputs, which depends on a terminating null.  We may
11032  * well be writing binary data, so we need to accommodate not only
11033  * data with nulls sprinkled in the middle but also data with no null
11034  * byte at the end.
11035  */
11036 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11037 int
11038 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11039 {
11040   char *cp, *end, *cpd;
11041   char *data;
11042   unsigned int fd = fileno(dest);
11043   unsigned int fdoff = fd / sizeof(unsigned int);
11044   int retval;
11045   int bufsize = itmsz * nitm + 1;
11046
11047   if (fdoff < sockflagsize &&
11048       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11049     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11050     return nitm;
11051   }
11052
11053   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11054   memcpy( data, src, itmsz*nitm );
11055   data[itmsz*nitm] = '\0';
11056
11057   end = data + itmsz * nitm;
11058   retval = (int) nitm; /* on success return # items written */
11059
11060   cpd = data;
11061   while (cpd <= end) {
11062     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11063     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11064     if (cp < end)
11065       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11066     cpd = cp + 1;
11067   }
11068
11069   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11070   return retval;
11071
11072 }  /* end of my_fwrite() */
11073 /*}}}*/
11074
11075 /*{{{ int my_flush(FILE *fp)*/
11076 int
11077 Perl_my_flush(pTHX_ FILE *fp)
11078 {
11079     int res;
11080     if ((res = fflush(fp)) == 0 && fp) {
11081 #ifdef VMS_DO_SOCKETS
11082         Stat_t s;
11083         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11084 #endif
11085             res = fsync(fileno(fp));
11086     }
11087 /*
11088  * If the flush succeeded but set end-of-file, we need to clear
11089  * the error because our caller may check ferror().  BTW, this
11090  * probably means we just flushed an empty file.
11091  */
11092     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11093
11094     return res;
11095 }
11096 /*}}}*/
11097
11098 /* fgetname() is not returning the correct file specifications when
11099  * decc_filename_unix_report mode is active.  So we have to have it
11100  * aways return filenames in VMS mode and convert it ourselves.
11101  */
11102
11103 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11104 char *
11105 Perl_my_fgetname(FILE *fp, char * buf) {
11106     char * retname;
11107     char * vms_name;
11108
11109     retname = fgetname(fp, buf, 1);
11110
11111     /* If we are in VMS mode, then we are done */
11112     if (!decc_filename_unix_report || (retname == NULL)) {
11113        return retname;
11114     }
11115
11116     /* Convert this to Unix format */
11117     vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11118     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11119     retname = int_tounixspec(vms_name, buf, NULL);
11120     PerlMem_free(vms_name);
11121
11122     return retname;
11123 }
11124 /*}}}*/
11125
11126 /*
11127  * Here are replacements for the following Unix routines in the VMS environment:
11128  *      getpwuid    Get information for a particular UIC or UID
11129  *      getpwnam    Get information for a named user
11130  *      getpwent    Get information for each user in the rights database
11131  *      setpwent    Reset search to the start of the rights database
11132  *      endpwent    Finish searching for users in the rights database
11133  *
11134  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11135  * (defined in pwd.h), which contains the following fields:-
11136  *      struct passwd {
11137  *              char        *pw_name;    Username (in lower case)
11138  *              char        *pw_passwd;  Hashed password
11139  *              unsigned int pw_uid;     UIC
11140  *              unsigned int pw_gid;     UIC group  number
11141  *              char        *pw_unixdir; Default device/directory (VMS-style)
11142  *              char        *pw_gecos;   Owner name
11143  *              char        *pw_dir;     Default device/directory (Unix-style)
11144  *              char        *pw_shell;   Default CLI name (eg. DCL)
11145  *      };
11146  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11147  *
11148  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11149  * not the UIC member number (eg. what's returned by getuid()),
11150  * getpwuid() can accept either as input (if uid is specified, the caller's
11151  * UIC group is used), though it won't recognise gid=0.
11152  *
11153  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11154  * information about other users in your group or in other groups, respectively.
11155  * If the required privilege is not available, then these routines fill only
11156  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11157  * string).
11158  *
11159  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11160  */
11161
11162 /* sizes of various UAF record fields */
11163 #define UAI$S_USERNAME 12
11164 #define UAI$S_IDENT    31
11165 #define UAI$S_OWNER    31
11166 #define UAI$S_DEFDEV   31
11167 #define UAI$S_DEFDIR   63
11168 #define UAI$S_DEFCLI   31
11169 #define UAI$S_PWD       8
11170
11171 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11172                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11173                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11174
11175 static char __empty[]= "";
11176 static struct passwd __passwd_empty=
11177     {(char *) __empty, (char *) __empty, 0, 0,
11178      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11179 static int contxt= 0;
11180 static struct passwd __pwdcache;
11181 static char __pw_namecache[UAI$S_IDENT+1];
11182
11183 /*
11184  * This routine does most of the work extracting the user information.
11185  */
11186 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11187 {
11188     static struct {
11189         unsigned char length;
11190         char pw_gecos[UAI$S_OWNER+1];
11191     } owner;
11192     static union uicdef uic;
11193     static struct {
11194         unsigned char length;
11195         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11196     } defdev;
11197     static struct {
11198         unsigned char length;
11199         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11200     } defdir;
11201     static struct {
11202         unsigned char length;
11203         char pw_shell[UAI$S_DEFCLI+1];
11204     } defcli;
11205     static char pw_passwd[UAI$S_PWD+1];
11206
11207     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11208     struct dsc$descriptor_s name_desc;
11209     unsigned long int sts;
11210
11211     static struct itmlst_3 itmlst[]= {
11212         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11213         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11214         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11215         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11216         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11217         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11218         {0,                0,           NULL,    NULL}};
11219
11220     name_desc.dsc$w_length=  strlen(name);
11221     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11222     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11223     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11224
11225 /*  Note that sys$getuai returns many fields as counted strings. */
11226     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11227     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11228       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11229     }
11230     else { _ckvmssts(sts); }
11231     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11232
11233     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11234     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11235     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11236     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11237     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11238     owner.pw_gecos[lowner]=            '\0';
11239     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11240     defcli.pw_shell[ldefcli]=          '\0';
11241     if (valid_uic(uic)) {
11242         pwd->pw_uid= uic.uic$l_uic;
11243         pwd->pw_gid= uic.uic$v_group;
11244     }
11245     else
11246       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11247     pwd->pw_passwd=  pw_passwd;
11248     pwd->pw_gecos=   owner.pw_gecos;
11249     pwd->pw_dir=     defdev.pw_dir;
11250     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11251     pwd->pw_shell=   defcli.pw_shell;
11252     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11253         int ldir;
11254         ldir= strlen(pwd->pw_unixdir) - 1;
11255         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11256     }
11257     else
11258         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11259     if (!decc_efs_case_preserve)
11260         __mystrtolower(pwd->pw_unixdir);
11261     return 1;
11262 }
11263
11264 /*
11265  * Get information for a named user.
11266 */
11267 /*{{{struct passwd *getpwnam(char *name)*/
11268 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11269 {
11270     struct dsc$descriptor_s name_desc;
11271     union uicdef uic;
11272     unsigned long int sts;
11273
11274     __pwdcache = __passwd_empty;
11275     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11276       /* We still may be able to determine pw_uid and pw_gid */
11277       name_desc.dsc$w_length=  strlen(name);
11278       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11279       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11280       name_desc.dsc$a_pointer= (char *) name;
11281       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11282         __pwdcache.pw_uid= uic.uic$l_uic;
11283         __pwdcache.pw_gid= uic.uic$v_group;
11284       }
11285       else {
11286         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11287           set_vaxc_errno(sts);
11288           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11289           return NULL;
11290         }
11291         else { _ckvmssts(sts); }
11292       }
11293     }
11294     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11295     __pwdcache.pw_name= __pw_namecache;
11296     return &__pwdcache;
11297 }  /* end of my_getpwnam() */
11298 /*}}}*/
11299
11300 /*
11301  * Get information for a particular UIC or UID.
11302  * Called by my_getpwent with uid=-1 to list all users.
11303 */
11304 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11305 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11306 {
11307     const $DESCRIPTOR(name_desc,__pw_namecache);
11308     unsigned short lname;
11309     union uicdef uic;
11310     unsigned long int status;
11311
11312     if (uid == (unsigned int) -1) {
11313       do {
11314         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11315         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11316           set_vaxc_errno(status);
11317           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11318           my_endpwent();
11319           return NULL;
11320         }
11321         else { _ckvmssts(status); }
11322       } while (!valid_uic (uic));
11323     }
11324     else {
11325       uic.uic$l_uic= uid;
11326       if (!uic.uic$v_group)
11327         uic.uic$v_group= PerlProc_getgid();
11328       if (valid_uic(uic))
11329         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11330       else status = SS$_IVIDENT;
11331       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11332           status == RMS$_PRV) {
11333         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11334         return NULL;
11335       }
11336       else { _ckvmssts(status); }
11337     }
11338     __pw_namecache[lname]= '\0';
11339     __mystrtolower(__pw_namecache);
11340
11341     __pwdcache = __passwd_empty;
11342     __pwdcache.pw_name = __pw_namecache;
11343
11344 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11345     The identifier's value is usually the UIC, but it doesn't have to be,
11346     so if we can, we let fillpasswd update this. */
11347     __pwdcache.pw_uid =  uic.uic$l_uic;
11348     __pwdcache.pw_gid =  uic.uic$v_group;
11349
11350     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11351     return &__pwdcache;
11352
11353 }  /* end of my_getpwuid() */
11354 /*}}}*/
11355
11356 /*
11357  * Get information for next user.
11358 */
11359 /*{{{struct passwd *my_getpwent()*/
11360 struct passwd *Perl_my_getpwent(pTHX)
11361 {
11362     return (my_getpwuid((unsigned int) -1));
11363 }
11364 /*}}}*/
11365
11366 /*
11367  * Finish searching rights database for users.
11368 */
11369 /*{{{void my_endpwent()*/
11370 void Perl_my_endpwent(pTHX)
11371 {
11372     if (contxt) {
11373       _ckvmssts(sys$finish_rdb(&contxt));
11374       contxt= 0;
11375     }
11376 }
11377 /*}}}*/
11378
11379 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11380  * my_utime(), and flex_stat(), all of which operate on UTC unless
11381  * VMSISH_TIMES is true.
11382  */
11383 /* method used to handle UTC conversions:
11384  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11385  */
11386 static int gmtime_emulation_type;
11387 /* number of secs to add to UTC POSIX-style time to get local time */
11388 static long int utc_offset_secs;
11389
11390 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11391  * in vmsish.h.  #undef them here so we can call the CRTL routines
11392  * directly.
11393  */
11394 #undef gmtime
11395 #undef localtime
11396 #undef time
11397
11398
11399 static time_t toutc_dst(time_t loc) {
11400   struct tm *rsltmp;
11401
11402   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11403   loc -= utc_offset_secs;
11404   if (rsltmp->tm_isdst) loc -= 3600;
11405   return loc;
11406 }
11407 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11408        ((gmtime_emulation_type || my_time(NULL)), \
11409        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11410        ((secs) - utc_offset_secs))))
11411
11412 static time_t toloc_dst(time_t utc) {
11413   struct tm *rsltmp;
11414
11415   utc += utc_offset_secs;
11416   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11417   if (rsltmp->tm_isdst) utc += 3600;
11418   return utc;
11419 }
11420 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11421        ((gmtime_emulation_type || my_time(NULL)), \
11422        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11423        ((secs) + utc_offset_secs))))
11424
11425 /* my_time(), my_localtime(), my_gmtime()
11426  * By default traffic in UTC time values, using CRTL gmtime() or
11427  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11428  * Note: We need to use these functions even when the CRTL has working
11429  * UTC support, since they also handle C<use vmsish qw(times);>
11430  *
11431  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11432  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11433  */
11434
11435 /*{{{time_t my_time(time_t *timep)*/
11436 time_t Perl_my_time(pTHX_ time_t *timep)
11437 {
11438   time_t when;
11439   struct tm *tm_p;
11440
11441   if (gmtime_emulation_type == 0) {
11442     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11443                               /* results of calls to gmtime() and localtime() */
11444                               /* for same &base */
11445
11446     gmtime_emulation_type++;
11447     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11448       char off[LNM$C_NAMLENGTH+1];;
11449
11450       gmtime_emulation_type++;
11451       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11452         gmtime_emulation_type++;
11453         utc_offset_secs = 0;
11454         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11455       }
11456       else { utc_offset_secs = atol(off); }
11457     }
11458     else { /* We've got a working gmtime() */
11459       struct tm gmt, local;
11460
11461       gmt = *tm_p;
11462       tm_p = localtime(&base);
11463       local = *tm_p;
11464       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11465       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11466       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11467       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11468     }
11469   }
11470
11471   when = time(NULL);
11472 # ifdef VMSISH_TIME
11473   if (VMSISH_TIME) when = _toloc(when);
11474 # endif
11475   if (timep != NULL) *timep = when;
11476   return when;
11477
11478 }  /* end of my_time() */
11479 /*}}}*/
11480
11481
11482 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11483 struct tm *
11484 Perl_my_gmtime(pTHX_ const time_t *timep)
11485 {
11486   time_t when;
11487   struct tm *rsltmp;
11488
11489   if (timep == NULL) {
11490     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11491     return NULL;
11492   }
11493   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11494
11495   when = *timep;
11496 # ifdef VMSISH_TIME
11497   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11498 #  endif
11499   return gmtime(&when);
11500 }  /* end of my_gmtime() */
11501 /*}}}*/
11502
11503
11504 /*{{{struct tm *my_localtime(const time_t *timep)*/
11505 struct tm *
11506 Perl_my_localtime(pTHX_ const time_t *timep)
11507 {
11508   time_t when;
11509
11510   if (timep == NULL) {
11511     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11512     return NULL;
11513   }
11514   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11515   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11516
11517   when = *timep;
11518 # ifdef VMSISH_TIME
11519   if (VMSISH_TIME) when = _toutc(when);
11520 # endif
11521   /* CRTL localtime() wants UTC as input, does tz correction itself */
11522   return localtime(&when);
11523 } /*  end of my_localtime() */
11524 /*}}}*/
11525
11526 /* Reset definitions for later calls */
11527 #define gmtime(t)    my_gmtime(t)
11528 #define localtime(t) my_localtime(t)
11529 #define time(t)      my_time(t)
11530
11531
11532 /* my_utime - update modification/access time of a file
11533  *
11534  * VMS 7.3 and later implementation
11535  * Only the UTC translation is home-grown. The rest is handled by the
11536  * CRTL utime(), which will take into account the relevant feature
11537  * logicals and ODS-5 volume characteristics for true access times.
11538  *
11539  * pre VMS 7.3 implementation:
11540  * The calling sequence is identical to POSIX utime(), but under
11541  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11542  * not maintain access times.  Restrictions differ from the POSIX
11543  * definition in that the time can be changed as long as the
11544  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11545  * no separate checks are made to insure that the caller is the
11546  * owner of the file or has special privs enabled.
11547  * Code here is based on Joe Meadows' FILE utility.
11548  *
11549  */
11550
11551 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11552  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11553  * in 100 ns intervals.
11554  */
11555 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11556
11557 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11558 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11559 {
11560 #if __CRTL_VER >= 70300000
11561   struct utimbuf utc_utimes, *utc_utimesp;
11562
11563   if (utimes != NULL) {
11564     utc_utimes.actime = utimes->actime;
11565     utc_utimes.modtime = utimes->modtime;
11566 # ifdef VMSISH_TIME
11567     /* If input was local; convert to UTC for sys svc */
11568     if (VMSISH_TIME) {
11569       utc_utimes.actime = _toutc(utimes->actime);
11570       utc_utimes.modtime = _toutc(utimes->modtime);
11571     }
11572 # endif
11573     utc_utimesp = &utc_utimes;
11574   }
11575   else {
11576     utc_utimesp = NULL;
11577   }
11578
11579   return utime(file, utc_utimesp);
11580
11581 #else /* __CRTL_VER < 70300000 */
11582
11583   int i;
11584   int sts;
11585   long int bintime[2], len = 2, lowbit, unixtime,
11586            secscale = 10000000; /* seconds --> 100 ns intervals */
11587   unsigned long int chan, iosb[2], retsts;
11588   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11589   struct FAB myfab = cc$rms_fab;
11590   struct NAM mynam = cc$rms_nam;
11591 #if defined (__DECC) && defined (__VAX)
11592   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11593    * at least through VMS V6.1, which causes a type-conversion warning.
11594    */
11595 #  pragma message save
11596 #  pragma message disable cvtdiftypes
11597 #endif
11598   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11599   struct fibdef myfib;
11600 #if defined (__DECC) && defined (__VAX)
11601   /* This should be right after the declaration of myatr, but due
11602    * to a bug in VAX DEC C, this takes effect a statement early.
11603    */
11604 #  pragma message restore
11605 #endif
11606   /* cast ok for read only parameter */
11607   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11608                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11609                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11610
11611   if (file == NULL || *file == '\0') {
11612     SETERRNO(ENOENT, LIB$_INVARG);
11613     return -1;
11614   }
11615
11616   /* Convert to VMS format ensuring that it will fit in 255 characters */
11617   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11618       SETERRNO(ENOENT, LIB$_INVARG);
11619       return -1;
11620   }
11621   if (utimes != NULL) {
11622     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11623      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11624      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11625      * as input, we force the sign bit to be clear by shifting unixtime right
11626      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11627      */
11628     lowbit = (utimes->modtime & 1) ? secscale : 0;
11629     unixtime = (long int) utimes->modtime;
11630 #   ifdef VMSISH_TIME
11631     /* If input was UTC; convert to local for sys svc */
11632     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11633 #   endif
11634     unixtime >>= 1;  secscale <<= 1;
11635     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11636     if (!(retsts & 1)) {
11637       SETERRNO(EVMSERR, retsts);
11638       return -1;
11639     }
11640     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11641     if (!(retsts & 1)) {
11642       SETERRNO(EVMSERR, retsts);
11643       return -1;
11644     }
11645   }
11646   else {
11647     /* Just get the current time in VMS format directly */
11648     retsts = sys$gettim(bintime);
11649     if (!(retsts & 1)) {
11650       SETERRNO(EVMSERR, retsts);
11651       return -1;
11652     }
11653   }
11654
11655   myfab.fab$l_fna = vmsspec;
11656   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11657   myfab.fab$l_nam = &mynam;
11658   mynam.nam$l_esa = esa;
11659   mynam.nam$b_ess = (unsigned char) sizeof esa;
11660   mynam.nam$l_rsa = rsa;
11661   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11662   if (decc_efs_case_preserve)
11663       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11664
11665   /* Look for the file to be affected, letting RMS parse the file
11666    * specification for us as well.  I have set errno using only
11667    * values documented in the utime() man page for VMS POSIX.
11668    */
11669   retsts = sys$parse(&myfab,0,0);
11670   if (!(retsts & 1)) {
11671     set_vaxc_errno(retsts);
11672     if      (retsts == RMS$_PRV) set_errno(EACCES);
11673     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11674     else                         set_errno(EVMSERR);
11675     return -1;
11676   }
11677   retsts = sys$search(&myfab,0,0);
11678   if (!(retsts & 1)) {
11679     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11680     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11681     set_vaxc_errno(retsts);
11682     if      (retsts == RMS$_PRV) set_errno(EACCES);
11683     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11684     else                         set_errno(EVMSERR);
11685     return -1;
11686   }
11687
11688   devdsc.dsc$w_length = mynam.nam$b_dev;
11689   /* cast ok for read only parameter */
11690   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11691
11692   retsts = sys$assign(&devdsc,&chan,0,0);
11693   if (!(retsts & 1)) {
11694     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11695     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11696     set_vaxc_errno(retsts);
11697     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11698     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11699     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11700     else                               set_errno(EVMSERR);
11701     return -1;
11702   }
11703
11704   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11705   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11706
11707   memset((void *) &myfib, 0, sizeof myfib);
11708 #if defined(__DECC) || defined(__DECCXX)
11709   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11710   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11711   /* This prevents the revision time of the file being reset to the current
11712    * time as a result of our IO$_MODIFY $QIO. */
11713   myfib.fib$l_acctl = FIB$M_NORECORD;
11714 #else
11715   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11716   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11717   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11718 #endif
11719   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11720   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11721   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11722   _ckvmssts(sys$dassgn(chan));
11723   if (retsts & 1) retsts = iosb[0];
11724   if (!(retsts & 1)) {
11725     set_vaxc_errno(retsts);
11726     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11727     else                      set_errno(EVMSERR);
11728     return -1;
11729   }
11730
11731   return 0;
11732
11733 #endif /* #if __CRTL_VER >= 70300000 */
11734
11735 }  /* end of my_utime() */
11736 /*}}}*/
11737
11738 /*
11739  * flex_stat, flex_lstat, flex_fstat
11740  * basic stat, but gets it right when asked to stat
11741  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11742  */
11743
11744 #ifndef _USE_STD_STAT
11745 /* encode_dev packs a VMS device name string into an integer to allow
11746  * simple comparisons. This can be used, for example, to check whether two
11747  * files are located on the same device, by comparing their encoded device
11748  * names. Even a string comparison would not do, because stat() reuses the
11749  * device name buffer for each call; so without encode_dev, it would be
11750  * necessary to save the buffer and use strcmp (this would mean a number of
11751  * changes to the standard Perl code, to say nothing of what a Perl script
11752  * would have to do.
11753  *
11754  * The device lock id, if it exists, should be unique (unless perhaps compared
11755  * with lock ids transferred from other nodes). We have a lock id if the disk is
11756  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11757  * device names. Thus we use the lock id in preference, and only if that isn't
11758  * available, do we try to pack the device name into an integer (flagged by
11759  * the sign bit (LOCKID_MASK) being set).
11760  *
11761  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11762  * name and its encoded form, but it seems very unlikely that we will find
11763  * two files on different disks that share the same encoded device names,
11764  * and even more remote that they will share the same file id (if the test
11765  * is to check for the same file).
11766  *
11767  * A better method might be to use sys$device_scan on the first call, and to
11768  * search for the device, returning an index into the cached array.
11769  * The number returned would be more intelligible.
11770  * This is probably not worth it, and anyway would take quite a bit longer
11771  * on the first call.
11772  */
11773 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11774 static mydev_t encode_dev (pTHX_ const char *dev)
11775 {
11776   int i;
11777   unsigned long int f;
11778   mydev_t enc;
11779   char c;
11780   const char *q;
11781
11782   if (!dev || !dev[0]) return 0;
11783
11784 #if LOCKID_MASK
11785   {
11786     struct dsc$descriptor_s dev_desc;
11787     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11788
11789     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11790        can try that first. */
11791     dev_desc.dsc$w_length =  strlen (dev);
11792     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11793     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11794     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11795     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11796     if (!$VMS_STATUS_SUCCESS(status)) {
11797       switch (status) {
11798         case SS$_NOSUCHDEV:
11799           SETERRNO(ENODEV, status);
11800           return 0;
11801         default:
11802           _ckvmssts(status);
11803       }
11804     }
11805     if (lockid) return (lockid & ~LOCKID_MASK);
11806   }
11807 #endif
11808
11809   /* Otherwise we try to encode the device name */
11810   enc = 0;
11811   f = 1;
11812   i = 0;
11813   for (q = dev + strlen(dev); q--; q >= dev) {
11814     if (*q == ':')
11815         break;
11816     if (isdigit (*q))
11817       c= (*q) - '0';
11818     else if (isalpha (toupper (*q)))
11819       c= toupper (*q) - 'A' + (char)10;
11820     else
11821       continue; /* Skip '$'s */
11822     i++;
11823     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11824     if (i>1) f *= 36;
11825     enc += f * (unsigned long int) c;
11826   }
11827   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11828
11829 }  /* end of encode_dev() */
11830 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11831         device_no = encode_dev(aTHX_ devname)
11832 #else
11833 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11834         device_no = new_dev_no
11835 #endif
11836
11837 static int
11838 is_null_device(const char *name)
11839 {
11840   if (decc_bug_devnull != 0) {
11841     if (strncmp("/dev/null", name, 9) == 0)
11842       return 1;
11843   }
11844     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11845        The underscore prefix, controller letter, and unit number are
11846        independently optional; for our purposes, the colon punctuation
11847        is not.  The colon can be trailed by optional directory and/or
11848        filename, but two consecutive colons indicates a nodename rather
11849        than a device.  [pr]  */
11850   if (*name == '_') ++name;
11851   if (tolower(*name++) != 'n') return 0;
11852   if (tolower(*name++) != 'l') return 0;
11853   if (tolower(*name) == 'a') ++name;
11854   if (*name == '0') ++name;
11855   return (*name++ == ':') && (*name != ':');
11856 }
11857
11858 static int
11859 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11860
11861 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11862
11863 static I32
11864 Perl_cando_by_name_int
11865    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11866 {
11867   char usrname[L_cuserid];
11868   struct dsc$descriptor_s usrdsc =
11869          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11870   char *vmsname = NULL, *fileified = NULL;
11871   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11872   unsigned short int retlen, trnlnm_iter_count;
11873   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11874   union prvdef curprv;
11875   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11876          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11877          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11878   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11879          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11880          {0,0,0,0}};
11881   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11882          {0,0,0,0}};
11883   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11884   Stat_t st;
11885   static int profile_context = -1;
11886
11887   if (!fname || !*fname) return FALSE;
11888
11889   /* Make sure we expand logical names, since sys$check_access doesn't */
11890   fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11891   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11892   if (!strpbrk(fname,"/]>:")) {
11893       my_strlcpy(fileified, fname, VMS_MAXRSS);
11894       trnlnm_iter_count = 0;
11895       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11896         trnlnm_iter_count++;
11897         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11898       }
11899       fname = fileified;
11900   }
11901
11902   vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11903   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11904   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11905     /* Don't know if already in VMS format, so make sure */
11906     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11907       PerlMem_free(fileified);
11908       PerlMem_free(vmsname);
11909       return FALSE;
11910     }
11911   }
11912   else {
11913     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11914   }
11915
11916   /* sys$check_access needs a file spec, not a directory spec.
11917    * flex_stat now will handle a null thread context during startup.
11918    */
11919
11920   retlen = namdsc.dsc$w_length = strlen(vmsname);
11921   if (vmsname[retlen-1] == ']'
11922       || vmsname[retlen-1] == '>'
11923       || vmsname[retlen-1] == ':'
11924       || (!flex_stat_int(vmsname, &st, 1) &&
11925           S_ISDIR(st.st_mode))) {
11926
11927       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11928         PerlMem_free(fileified);
11929         PerlMem_free(vmsname);
11930         return FALSE;
11931       }
11932       fname = fileified;
11933   }
11934   else {
11935       fname = vmsname;
11936   }
11937
11938   retlen = namdsc.dsc$w_length = strlen(fname);
11939   namdsc.dsc$a_pointer = (char *)fname;
11940
11941   switch (bit) {
11942     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11943       access = ARM$M_EXECUTE;
11944       flags = CHP$M_READ;
11945       break;
11946     case S_IRUSR: case S_IRGRP: case S_IROTH:
11947       access = ARM$M_READ;
11948       flags = CHP$M_READ | CHP$M_USEREADALL;
11949       break;
11950     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11951       access = ARM$M_WRITE;
11952       flags = CHP$M_READ | CHP$M_WRITE;
11953       break;
11954     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11955       access = ARM$M_DELETE;
11956       flags = CHP$M_READ | CHP$M_WRITE;
11957       break;
11958     default:
11959       if (fileified != NULL)
11960         PerlMem_free(fileified);
11961       if (vmsname != NULL)
11962         PerlMem_free(vmsname);
11963       return FALSE;
11964   }
11965
11966   /* Before we call $check_access, create a user profile with the current
11967    * process privs since otherwise it just uses the default privs from the
11968    * UAF and might give false positives or negatives.  This only works on
11969    * VMS versions v6.0 and later since that's when sys$create_user_profile
11970    * became available.
11971    */
11972
11973   /* get current process privs and username */
11974   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11975   _ckvmssts_noperl(iosb[0]);
11976
11977   /* find out the space required for the profile */
11978   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11979                                     &usrprodsc.dsc$w_length,&profile_context));
11980
11981   /* allocate space for the profile and get it filled in */
11982   usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
11983   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11984   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11985                                     &usrprodsc.dsc$w_length,&profile_context));
11986
11987   /* use the profile to check access to the file; free profile & analyze results */
11988   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11989   PerlMem_free(usrprodsc.dsc$a_pointer);
11990   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11991
11992   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11993       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11994       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11995     set_vaxc_errno(retsts);
11996     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11997     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11998     else set_errno(ENOENT);
11999     if (fileified != NULL)
12000       PerlMem_free(fileified);
12001     if (vmsname != NULL)
12002       PerlMem_free(vmsname);
12003     return FALSE;
12004   }
12005   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12006     if (fileified != NULL)
12007       PerlMem_free(fileified);
12008     if (vmsname != NULL)
12009       PerlMem_free(vmsname);
12010     return TRUE;
12011   }
12012   _ckvmssts_noperl(retsts);
12013
12014   if (fileified != NULL)
12015     PerlMem_free(fileified);
12016   if (vmsname != NULL)
12017     PerlMem_free(vmsname);
12018   return FALSE;  /* Should never get here */
12019
12020 }
12021
12022 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12023 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12024  * subset of the applicable information.
12025  */
12026 bool
12027 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12028 {
12029   return cando_by_name_int
12030         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12031 }  /* end of cando() */
12032 /*}}}*/
12033
12034
12035 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12036 I32
12037 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12038 {
12039    return cando_by_name_int(bit, effective, fname, 0);
12040
12041 }  /* end of cando_by_name() */
12042 /*}}}*/
12043
12044
12045 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12046 int
12047 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12048 {
12049   dSAVE_ERRNO; /* fstat may set this even on success */
12050   if (!fstat(fd, &statbufp->crtl_stat)) {
12051     char *cptr;
12052     char *vms_filename;
12053     vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12054     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12055
12056     /* Save name for cando by name in VMS format */
12057     cptr = getname(fd, vms_filename, 1);
12058
12059     /* This should not happen, but just in case */
12060     if (cptr == NULL) {
12061         statbufp->st_devnam[0] = 0;
12062     }
12063     else {
12064         /* Make sure that the saved name fits in 255 characters */
12065         cptr = int_rmsexpand_vms
12066                        (vms_filename,
12067                         statbufp->st_devnam,
12068                         0);
12069         if (cptr == NULL)
12070             statbufp->st_devnam[0] = 0;
12071     }
12072     PerlMem_free(vms_filename);
12073
12074     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12075     VMS_DEVICE_ENCODE
12076         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12077
12078 #   ifdef VMSISH_TIME
12079     if (VMSISH_TIME) {
12080       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12081       statbufp->st_atime = _toloc(statbufp->st_atime);
12082       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12083     }
12084 #   endif
12085     RESTORE_ERRNO;
12086     return 0;
12087   }
12088   return -1;
12089
12090 }  /* end of flex_fstat() */
12091 /*}}}*/
12092
12093 static int
12094 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12095 {
12096     char *temp_fspec = NULL;
12097     char *fileified = NULL;
12098     const char *save_spec;
12099     char *ret_spec;
12100     int retval = -1;
12101     char efs_hack = 0;
12102     char already_fileified = 0;
12103     dSAVEDERRNO;
12104
12105     if (!fspec) {
12106         errno = EINVAL;
12107         return retval;
12108     }
12109
12110     if (decc_bug_devnull != 0) {
12111       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12112         memset(statbufp,0,sizeof *statbufp);
12113         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12114         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12115         statbufp->st_uid = 0x00010001;
12116         statbufp->st_gid = 0x0001;
12117         time((time_t *)&statbufp->st_mtime);
12118         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12119         return 0;
12120       }
12121     }
12122
12123     SAVE_ERRNO;
12124
12125 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12126   /*
12127    * If we are in POSIX filespec mode, accept the filename as is.
12128    */
12129   if (decc_posix_compliant_pathnames == 0) {
12130 #endif
12131
12132     /* Try for a simple stat first.  If fspec contains a filename without
12133      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12134      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12135      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12136      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12137      * the file with null type, specify this by calling flex_stat() with
12138      * a '.' at the end of fspec.
12139      */
12140
12141     if (lstat_flag == 0)
12142         retval = stat(fspec, &statbufp->crtl_stat);
12143     else
12144         retval = lstat(fspec, &statbufp->crtl_stat);
12145
12146     if (!retval) {
12147         save_spec = fspec;
12148     }
12149     else {
12150         /* In the odd case where we have write but not read access
12151          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12152          */
12153         fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12154         if (fileified == NULL)
12155               _ckvmssts_noperl(SS$_INSFMEM);
12156
12157         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12158         if (ret_spec != NULL) {
12159             if (lstat_flag == 0)
12160                 retval = stat(fileified, &statbufp->crtl_stat);
12161             else
12162                 retval = lstat(fileified, &statbufp->crtl_stat);
12163             save_spec = fileified;
12164             already_fileified = 1;
12165         }
12166     }
12167
12168     if (retval && vms_bug_stat_filename) {
12169
12170         temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12171         if (temp_fspec == NULL)
12172             _ckvmssts_noperl(SS$_INSFMEM);
12173
12174         /* We should try again as a vmsified file specification. */
12175
12176         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12177         if (ret_spec != NULL) {
12178             if (lstat_flag == 0)
12179                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12180             else
12181                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12182             save_spec = temp_fspec;
12183         }
12184     }
12185
12186     if (retval) {
12187         /* Last chance - allow multiple dots without EFS CHARSET */
12188         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12189          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12190          * enable it if it isn't already.
12191          */
12192 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12193         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12194             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12195 #endif
12196         if (lstat_flag == 0)
12197             retval = stat(fspec, &statbufp->crtl_stat);
12198         else
12199             retval = lstat(fspec, &statbufp->crtl_stat);
12200         save_spec = fspec;
12201 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12202         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12203             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12204             efs_hack = 1;
12205         }
12206 #endif
12207     }
12208
12209 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12210   } else {
12211     if (lstat_flag == 0)
12212       retval = stat(temp_fspec, &statbufp->crtl_stat);
12213     else
12214       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12215       save_spec = temp_fspec;
12216   }
12217 #endif
12218
12219 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12220   /* As you were... */
12221   if (!decc_efs_charset)
12222     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12223 #endif
12224
12225     if (!retval) {
12226       char *cptr;
12227       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12228
12229       /* If this is an lstat, do not follow the link */
12230       if (lstat_flag)
12231         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12232
12233 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12234       /* If we used the efs_hack above, we must also use it here for */
12235       /* perl_cando to work */
12236       if (efs_hack && (decc_efs_charset_index > 0)) {
12237           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12238       }
12239 #endif
12240
12241       /* If we've got a directory, save a fileified, expanded version of it
12242        * in st_devnam.  If not a directory, just an expanded version.
12243        */
12244       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12245           fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12246           if (fileified == NULL)
12247               _ckvmssts_noperl(SS$_INSFMEM);
12248
12249           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12250           if (cptr != NULL)
12251               save_spec = fileified;
12252       }
12253
12254       cptr = int_rmsexpand(save_spec,
12255                            statbufp->st_devnam,
12256                            NULL,
12257                            rmsex_flags,
12258                            0,
12259                            0);
12260
12261 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12262       if (efs_hack && (decc_efs_charset_index > 0)) {
12263           decc$feature_set_value(decc_efs_charset, 1, 0);
12264       }
12265 #endif
12266
12267       /* Fix me: If this is NULL then stat found a file, and we could */
12268       /* not convert the specification to VMS - Should never happen */
12269       if (cptr == NULL)
12270         statbufp->st_devnam[0] = 0;
12271
12272       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12273       VMS_DEVICE_ENCODE
12274         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12275 #     ifdef VMSISH_TIME
12276       if (VMSISH_TIME) {
12277         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12278         statbufp->st_atime = _toloc(statbufp->st_atime);
12279         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12280       }
12281 #     endif
12282     }
12283     /* If we were successful, leave errno where we found it */
12284     if (retval == 0) RESTORE_ERRNO;
12285     if (temp_fspec)
12286         PerlMem_free(temp_fspec);
12287     if (fileified)
12288         PerlMem_free(fileified);
12289     return retval;
12290
12291 }  /* end of flex_stat_int() */
12292
12293
12294 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12295 int
12296 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12297 {
12298    return flex_stat_int(fspec, statbufp, 0);
12299 }
12300 /*}}}*/
12301
12302 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12303 int
12304 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12305 {
12306    return flex_stat_int(fspec, statbufp, 1);
12307 }
12308 /*}}}*/
12309
12310
12311 /*{{{char *my_getlogin()*/
12312 /* VMS cuserid == Unix getlogin, except calling sequence */
12313 char *
12314 my_getlogin(void)
12315 {
12316     static char user[L_cuserid];
12317     return cuserid(user);
12318 }
12319 /*}}}*/
12320
12321
12322 /*  rmscopy - copy a file using VMS RMS routines
12323  *
12324  *  Copies contents and attributes of spec_in to spec_out, except owner
12325  *  and protection information.  Name and type of spec_in are used as
12326  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12327  *  should try to propagate timestamps from the input file to the output file.
12328  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12329  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12330  *  propagated to the output file at creation iff the output file specification
12331  *  did not contain an explicit name or type, and the revision date is always
12332  *  updated at the end of the copy operation.  If it is greater than 0, then
12333  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12334  *  other than the revision date should be propagated, and bit 1 indicates
12335  *  that the revision date should be propagated.
12336  *
12337  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12338  *
12339  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12340  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12341  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12342  * as part of the Perl standard distribution under the terms of the
12343  * GNU General Public License or the Perl Artistic License.  Copies
12344  * of each may be found in the Perl standard distribution.
12345  */ /* FIXME */
12346 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12347 int
12348 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12349 {
12350     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12351          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12352     unsigned long int sts;
12353     int dna_len;
12354     struct FAB fab_in, fab_out;
12355     struct RAB rab_in, rab_out;
12356     rms_setup_nam(nam);
12357     rms_setup_nam(nam_out);
12358     struct XABDAT xabdat;
12359     struct XABFHC xabfhc;
12360     struct XABRDT xabrdt;
12361     struct XABSUM xabsum;
12362
12363     vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12364     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12365     vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12366     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12367     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12368         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12369       PerlMem_free(vmsin);
12370       PerlMem_free(vmsout);
12371       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12372       return 0;
12373     }
12374
12375     esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12376     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12377     esal = NULL;
12378 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12379     esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12380     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12381 #endif
12382     fab_in = cc$rms_fab;
12383     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12384     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12385     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12386     fab_in.fab$l_fop = FAB$M_SQO;
12387     rms_bind_fab_nam(fab_in, nam);
12388     fab_in.fab$l_xab = (void *) &xabdat;
12389
12390     rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12391     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12392     rsal = NULL;
12393 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12394     rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12395     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12396 #endif
12397     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12398     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12399     rms_nam_esl(nam) = 0;
12400     rms_nam_rsl(nam) = 0;
12401     rms_nam_esll(nam) = 0;
12402     rms_nam_rsll(nam) = 0;
12403 #ifdef NAM$M_NO_SHORT_UPCASE
12404     if (decc_efs_case_preserve)
12405         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12406 #endif
12407
12408     xabdat = cc$rms_xabdat;        /* To get creation date */
12409     xabdat.xab$l_nxt = (void *) &xabfhc;
12410
12411     xabfhc = cc$rms_xabfhc;        /* To get record length */
12412     xabfhc.xab$l_nxt = (void *) &xabsum;
12413
12414     xabsum = cc$rms_xabsum;        /* To get key and area information */
12415
12416     if (!((sts = sys$open(&fab_in)) & 1)) {
12417       PerlMem_free(vmsin);
12418       PerlMem_free(vmsout);
12419       PerlMem_free(esa);
12420       if (esal != NULL)
12421         PerlMem_free(esal);
12422       PerlMem_free(rsa);
12423       if (rsal != NULL)
12424         PerlMem_free(rsal);
12425       set_vaxc_errno(sts);
12426       switch (sts) {
12427         case RMS$_FNF: case RMS$_DNF:
12428           set_errno(ENOENT); break;
12429         case RMS$_DIR:
12430           set_errno(ENOTDIR); break;
12431         case RMS$_DEV:
12432           set_errno(ENODEV); break;
12433         case RMS$_SYN:
12434           set_errno(EINVAL); break;
12435         case RMS$_PRV:
12436           set_errno(EACCES); break;
12437         default:
12438           set_errno(EVMSERR);
12439       }
12440       return 0;
12441     }
12442
12443     nam_out = nam;
12444     fab_out = fab_in;
12445     fab_out.fab$w_ifi = 0;
12446     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12447     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12448     fab_out.fab$l_fop = FAB$M_SQO;
12449     rms_bind_fab_nam(fab_out, nam_out);
12450     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12451     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12452     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12453     esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12454     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12455     rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12456     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12457     esal_out = NULL;
12458     rsal_out = NULL;
12459 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12460     esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12461     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12462     rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12463     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12464 #endif
12465     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12466     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12467
12468     if (preserve_dates == 0) {  /* Act like DCL COPY */
12469       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12470       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12471       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12472         PerlMem_free(vmsin);
12473         PerlMem_free(vmsout);
12474         PerlMem_free(esa);
12475         if (esal != NULL)
12476             PerlMem_free(esal);
12477         PerlMem_free(rsa);
12478         if (rsal != NULL)
12479             PerlMem_free(rsal);
12480         PerlMem_free(esa_out);
12481         if (esal_out != NULL)
12482             PerlMem_free(esal_out);
12483         PerlMem_free(rsa_out);
12484         if (rsal_out != NULL)
12485             PerlMem_free(rsal_out);
12486         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12487         set_vaxc_errno(sts);
12488         return 0;
12489       }
12490       fab_out.fab$l_xab = (void *) &xabdat;
12491       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12492         preserve_dates = 1;
12493     }
12494     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12495       preserve_dates =0;      /* bitmask from this point forward   */
12496
12497     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12498     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12499       PerlMem_free(vmsin);
12500       PerlMem_free(vmsout);
12501       PerlMem_free(esa);
12502       if (esal != NULL)
12503           PerlMem_free(esal);
12504       PerlMem_free(rsa);
12505       if (rsal != NULL)
12506           PerlMem_free(rsal);
12507       PerlMem_free(esa_out);
12508       if (esal_out != NULL)
12509           PerlMem_free(esal_out);
12510       PerlMem_free(rsa_out);
12511       if (rsal_out != NULL)
12512           PerlMem_free(rsal_out);
12513       set_vaxc_errno(sts);
12514       switch (sts) {
12515         case RMS$_DNF:
12516           set_errno(ENOENT); break;
12517         case RMS$_DIR:
12518           set_errno(ENOTDIR); break;
12519         case RMS$_DEV:
12520           set_errno(ENODEV); break;
12521         case RMS$_SYN:
12522           set_errno(EINVAL); break;
12523         case RMS$_PRV:
12524           set_errno(EACCES); break;
12525         default:
12526           set_errno(EVMSERR);
12527       }
12528       return 0;
12529     }
12530     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12531     if (preserve_dates & 2) {
12532       /* sys$close() will process xabrdt, not xabdat */
12533       xabrdt = cc$rms_xabrdt;
12534 #ifndef __GNUC__
12535       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12536 #else
12537       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12538        * is unsigned long[2], while DECC & VAXC use a struct */
12539       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12540 #endif
12541       fab_out.fab$l_xab = (void *) &xabrdt;
12542     }
12543
12544     ubf = (char *)PerlMem_malloc(32256);
12545     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12546     rab_in = cc$rms_rab;
12547     rab_in.rab$l_fab = &fab_in;
12548     rab_in.rab$l_rop = RAB$M_BIO;
12549     rab_in.rab$l_ubf = ubf;
12550     rab_in.rab$w_usz = 32256;
12551     if (!((sts = sys$connect(&rab_in)) & 1)) {
12552       sys$close(&fab_in); sys$close(&fab_out);
12553       PerlMem_free(vmsin);
12554       PerlMem_free(vmsout);
12555       PerlMem_free(ubf);
12556       PerlMem_free(esa);
12557       if (esal != NULL)
12558           PerlMem_free(esal);
12559       PerlMem_free(rsa);
12560       if (rsal != NULL)
12561           PerlMem_free(rsal);
12562       PerlMem_free(esa_out);
12563       if (esal_out != NULL)
12564           PerlMem_free(esal_out);
12565       PerlMem_free(rsa_out);
12566       if (rsal_out != NULL)
12567           PerlMem_free(rsal_out);
12568       set_errno(EVMSERR); set_vaxc_errno(sts);
12569       return 0;
12570     }
12571
12572     rab_out = cc$rms_rab;
12573     rab_out.rab$l_fab = &fab_out;
12574     rab_out.rab$l_rbf = ubf;
12575     if (!((sts = sys$connect(&rab_out)) & 1)) {
12576       sys$close(&fab_in); sys$close(&fab_out);
12577       PerlMem_free(vmsin);
12578       PerlMem_free(vmsout);
12579       PerlMem_free(ubf);
12580       PerlMem_free(esa);
12581       if (esal != NULL)
12582           PerlMem_free(esal);
12583       PerlMem_free(rsa);
12584       if (rsal != NULL)
12585           PerlMem_free(rsal);
12586       PerlMem_free(esa_out);
12587       if (esal_out != NULL)
12588           PerlMem_free(esal_out);
12589       PerlMem_free(rsa_out);
12590       if (rsal_out != NULL)
12591           PerlMem_free(rsal_out);
12592       set_errno(EVMSERR); set_vaxc_errno(sts);
12593       return 0;
12594     }
12595
12596     while ((sts = sys$read(&rab_in))) {  /* always true  */
12597       if (sts == RMS$_EOF) break;
12598       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12599       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12600         sys$close(&fab_in); sys$close(&fab_out);
12601         PerlMem_free(vmsin);
12602         PerlMem_free(vmsout);
12603         PerlMem_free(ubf);
12604         PerlMem_free(esa);
12605         if (esal != NULL)
12606             PerlMem_free(esal);
12607         PerlMem_free(rsa);
12608         if (rsal != NULL)
12609             PerlMem_free(rsal);
12610         PerlMem_free(esa_out);
12611         if (esal_out != NULL)
12612             PerlMem_free(esal_out);
12613         PerlMem_free(rsa_out);
12614         if (rsal_out != NULL)
12615             PerlMem_free(rsal_out);
12616         set_errno(EVMSERR); set_vaxc_errno(sts);
12617         return 0;
12618       }
12619     }
12620
12621
12622     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12623     sys$close(&fab_in);  sys$close(&fab_out);
12624     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12625
12626     PerlMem_free(vmsin);
12627     PerlMem_free(vmsout);
12628     PerlMem_free(ubf);
12629     PerlMem_free(esa);
12630     if (esal != NULL)
12631         PerlMem_free(esal);
12632     PerlMem_free(rsa);
12633     if (rsal != NULL)
12634         PerlMem_free(rsal);
12635     PerlMem_free(esa_out);
12636     if (esal_out != NULL)
12637         PerlMem_free(esal_out);
12638     PerlMem_free(rsa_out);
12639     if (rsal_out != NULL)
12640         PerlMem_free(rsal_out);
12641
12642     if (!(sts & 1)) {
12643       set_errno(EVMSERR); set_vaxc_errno(sts);
12644       return 0;
12645     }
12646
12647     return 1;
12648
12649 }  /* end of rmscopy() */
12650 /*}}}*/
12651
12652
12653 /***  The following glue provides 'hooks' to make some of the routines
12654  * from this file available from Perl.  These routines are sufficiently
12655  * basic, and are required sufficiently early in the build process,
12656  * that's it's nice to have them available to miniperl as well as the
12657  * full Perl, so they're set up here instead of in an extension.  The
12658  * Perl code which handles importation of these names into a given
12659  * package lives in [.VMS]Filespec.pm in @INC.
12660  */
12661
12662 void
12663 rmsexpand_fromperl(pTHX_ CV *cv)
12664 {
12665   dXSARGS;
12666   char *fspec, *defspec = NULL, *rslt;
12667   STRLEN n_a;
12668   int fs_utf8, dfs_utf8;
12669
12670   fs_utf8 = 0;
12671   dfs_utf8 = 0;
12672   if (!items || items > 2)
12673     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12674   fspec = SvPV(ST(0),n_a);
12675   fs_utf8 = SvUTF8(ST(0));
12676   if (!fspec || !*fspec) XSRETURN_UNDEF;
12677   if (items == 2) {
12678     defspec = SvPV(ST(1),n_a);
12679     dfs_utf8 = SvUTF8(ST(1));
12680   }
12681   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12682   ST(0) = sv_newmortal();
12683   if (rslt != NULL) {
12684     sv_usepvn(ST(0),rslt,strlen(rslt));
12685     if (fs_utf8) {
12686         SvUTF8_on(ST(0));
12687     }
12688   }
12689   XSRETURN(1);
12690 }
12691
12692 void
12693 vmsify_fromperl(pTHX_ CV *cv)
12694 {
12695   dXSARGS;
12696   char *vmsified;
12697   STRLEN n_a;
12698   int utf8_fl;
12699
12700   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12701   utf8_fl = SvUTF8(ST(0));
12702   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12703   ST(0) = sv_newmortal();
12704   if (vmsified != NULL) {
12705     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12706     if (utf8_fl) {
12707         SvUTF8_on(ST(0));
12708     }
12709   }
12710   XSRETURN(1);
12711 }
12712
12713 void
12714 unixify_fromperl(pTHX_ CV *cv)
12715 {
12716   dXSARGS;
12717   char *unixified;
12718   STRLEN n_a;
12719   int utf8_fl;
12720
12721   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12722   utf8_fl = SvUTF8(ST(0));
12723   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12724   ST(0) = sv_newmortal();
12725   if (unixified != NULL) {
12726     sv_usepvn(ST(0),unixified,strlen(unixified));
12727     if (utf8_fl) {
12728         SvUTF8_on(ST(0));
12729     }
12730   }
12731   XSRETURN(1);
12732 }
12733
12734 void
12735 fileify_fromperl(pTHX_ CV *cv)
12736 {
12737   dXSARGS;
12738   char *fileified;
12739   STRLEN n_a;
12740   int utf8_fl;
12741
12742   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12743   utf8_fl = SvUTF8(ST(0));
12744   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12745   ST(0) = sv_newmortal();
12746   if (fileified != NULL) {
12747     sv_usepvn(ST(0),fileified,strlen(fileified));
12748     if (utf8_fl) {
12749         SvUTF8_on(ST(0));
12750     }
12751   }
12752   XSRETURN(1);
12753 }
12754
12755 void
12756 pathify_fromperl(pTHX_ CV *cv)
12757 {
12758   dXSARGS;
12759   char *pathified;
12760   STRLEN n_a;
12761   int utf8_fl;
12762
12763   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12764   utf8_fl = SvUTF8(ST(0));
12765   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12766   ST(0) = sv_newmortal();
12767   if (pathified != NULL) {
12768     sv_usepvn(ST(0),pathified,strlen(pathified));
12769     if (utf8_fl) {
12770         SvUTF8_on(ST(0));
12771     }
12772   }
12773   XSRETURN(1);
12774 }
12775
12776 void
12777 vmspath_fromperl(pTHX_ CV *cv)
12778 {
12779   dXSARGS;
12780   char *vmspath;
12781   STRLEN n_a;
12782   int utf8_fl;
12783
12784   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12785   utf8_fl = SvUTF8(ST(0));
12786   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12787   ST(0) = sv_newmortal();
12788   if (vmspath != NULL) {
12789     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12790     if (utf8_fl) {
12791         SvUTF8_on(ST(0));
12792     }
12793   }
12794   XSRETURN(1);
12795 }
12796
12797 void
12798 unixpath_fromperl(pTHX_ CV *cv)
12799 {
12800   dXSARGS;
12801   char *unixpath;
12802   STRLEN n_a;
12803   int utf8_fl;
12804
12805   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12806   utf8_fl = SvUTF8(ST(0));
12807   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12808   ST(0) = sv_newmortal();
12809   if (unixpath != NULL) {
12810     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12811     if (utf8_fl) {
12812         SvUTF8_on(ST(0));
12813     }
12814   }
12815   XSRETURN(1);
12816 }
12817
12818 void
12819 candelete_fromperl(pTHX_ CV *cv)
12820 {
12821   dXSARGS;
12822   char *fspec, *fsp;
12823   SV *mysv;
12824   IO *io;
12825   STRLEN n_a;
12826
12827   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12828
12829   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12830   Newx(fspec, VMS_MAXRSS, char);
12831   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12832   if (isGV_with_GP(mysv)) {
12833     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12834       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12835       ST(0) = &PL_sv_no;
12836       Safefree(fspec);
12837       XSRETURN(1);
12838     }
12839     fsp = fspec;
12840   }
12841   else {
12842     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12843       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12844       ST(0) = &PL_sv_no;
12845       Safefree(fspec);
12846       XSRETURN(1);
12847     }
12848   }
12849
12850   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12851   Safefree(fspec);
12852   XSRETURN(1);
12853 }
12854
12855 void
12856 rmscopy_fromperl(pTHX_ CV *cv)
12857 {
12858   dXSARGS;
12859   char *inspec, *outspec, *inp, *outp;
12860   int date_flag;
12861   SV *mysv;
12862   IO *io;
12863   STRLEN n_a;
12864
12865   if (items < 2 || items > 3)
12866     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12867
12868   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12869   Newx(inspec, VMS_MAXRSS, char);
12870   if (isGV_with_GP(mysv)) {
12871     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12872       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12873       ST(0) = sv_2mortal(newSViv(0));
12874       Safefree(inspec);
12875       XSRETURN(1);
12876     }
12877     inp = inspec;
12878   }
12879   else {
12880     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12881       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12882       ST(0) = sv_2mortal(newSViv(0));
12883       Safefree(inspec);
12884       XSRETURN(1);
12885     }
12886   }
12887   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12888   Newx(outspec, VMS_MAXRSS, char);
12889   if (isGV_with_GP(mysv)) {
12890     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12891       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12892       ST(0) = sv_2mortal(newSViv(0));
12893       Safefree(inspec);
12894       Safefree(outspec);
12895       XSRETURN(1);
12896     }
12897     outp = outspec;
12898   }
12899   else {
12900     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12901       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12902       ST(0) = sv_2mortal(newSViv(0));
12903       Safefree(inspec);
12904       Safefree(outspec);
12905       XSRETURN(1);
12906     }
12907   }
12908   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12909
12910   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12911   Safefree(inspec);
12912   Safefree(outspec);
12913   XSRETURN(1);
12914 }
12915
12916 /* The mod2fname is limited to shorter filenames by design, so it should
12917  * not be modified to support longer EFS pathnames
12918  */
12919 void
12920 mod2fname(pTHX_ CV *cv)
12921 {
12922   dXSARGS;
12923   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12924        workbuff[NAM$C_MAXRSS*1 + 1];
12925   SSize_t counter, num_entries;
12926   /* ODS-5 ups this, but we want to be consistent, so... */
12927   int max_name_len = 39;
12928   AV *in_array = (AV *)SvRV(ST(0));
12929
12930   num_entries = av_tindex(in_array);
12931
12932   /* All the names start with PL_. */
12933   strcpy(ultimate_name, "PL_");
12934
12935   /* Clean up our working buffer */
12936   Zero(work_name, sizeof(work_name), char);
12937
12938   /* Run through the entries and build up a working name */
12939   for(counter = 0; counter <= num_entries; counter++) {
12940     /* If it's not the first name then tack on a __ */
12941     if (counter) {
12942       my_strlcat(work_name, "__", sizeof(work_name));
12943     }
12944     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12945   }
12946
12947   /* Check to see if we actually have to bother...*/
12948   if (strlen(work_name) + 3 <= max_name_len) {
12949     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12950   } else {
12951     /* It's too darned big, so we need to go strip. We use the same */
12952     /* algorithm as xsubpp does. First, strip out doubled __ */
12953     char *source, *dest, last;
12954     dest = workbuff;
12955     last = 0;
12956     for (source = work_name; *source; source++) {
12957       if (last == *source && last == '_') {
12958         continue;
12959       }
12960       *dest++ = *source;
12961       last = *source;
12962     }
12963     /* Go put it back */
12964     my_strlcpy(work_name, workbuff, sizeof(work_name));
12965     /* Is it still too big? */
12966     if (strlen(work_name) + 3 > max_name_len) {
12967       /* Strip duplicate letters */
12968       last = 0;
12969       dest = workbuff;
12970       for (source = work_name; *source; source++) {
12971         if (last == toupper(*source)) {
12972         continue;
12973         }
12974         *dest++ = *source;
12975         last = toupper(*source);
12976       }
12977       my_strlcpy(work_name, workbuff, sizeof(work_name));
12978     }
12979
12980     /* Is it *still* too big? */
12981     if (strlen(work_name) + 3 > max_name_len) {
12982       /* Too bad, we truncate */
12983       work_name[max_name_len - 2] = 0;
12984     }
12985     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12986   }
12987
12988   /* Okay, return it */
12989   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12990   XSRETURN(1);
12991 }
12992
12993 void
12994 hushexit_fromperl(pTHX_ CV *cv)
12995 {
12996     dXSARGS;
12997
12998     if (items > 0) {
12999         VMSISH_HUSHED = SvTRUE(ST(0));
13000     }
13001     ST(0) = boolSV(VMSISH_HUSHED);
13002     XSRETURN(1);
13003 }
13004
13005
13006 PerlIO *
13007 Perl_vms_start_glob
13008    (pTHX_ SV *tmpglob,
13009     IO *io)
13010 {
13011     PerlIO *fp;
13012     struct vs_str_st *rslt;
13013     char *vmsspec;
13014     char *rstr;
13015     char *begin, *cp;
13016     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13017     PerlIO *tmpfp;
13018     STRLEN i;
13019     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13020     struct dsc$descriptor_vs rsdsc;
13021     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13022     unsigned long hasver = 0, isunix = 0;
13023     unsigned long int lff_flags = 0;
13024     int rms_sts;
13025     int vms_old_glob = 1;
13026
13027     if (!SvOK(tmpglob)) {
13028         SETERRNO(ENOENT,RMS$_FNF);
13029         return NULL;
13030     }
13031
13032     vms_old_glob = !decc_filename_unix_report;
13033
13034 #ifdef VMS_LONGNAME_SUPPORT
13035     lff_flags = LIB$M_FIL_LONG_NAMES;
13036 #endif
13037     /* The Newx macro will not allow me to assign a smaller array
13038      * to the rslt pointer, so we will assign it to the begin char pointer
13039      * and then copy the value into the rslt pointer.
13040      */
13041     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13042     rslt = (struct vs_str_st *)begin;
13043     rslt->length = 0;
13044     rstr = &rslt->str[0];
13045     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13046     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13047     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13048     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13049
13050     Newx(vmsspec, VMS_MAXRSS, char);
13051
13052         /* We could find out if there's an explicit dev/dir or version
13053            by peeking into lib$find_file's internal context at
13054            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13055            but that's unsupported, so I don't want to do it now and
13056            have it bite someone in the future. */
13057         /* Fix-me: vms_split_path() is the only way to do this, the
13058            existing method will fail with many legal EFS or UNIX specifications
13059          */
13060
13061     cp = SvPV(tmpglob,i);
13062
13063     for (; i; i--) {
13064         if (cp[i] == ';') hasver = 1;
13065         if (cp[i] == '.') {
13066             if (sts) hasver = 1;
13067             else sts = 1;
13068         }
13069         if (cp[i] == '/') {
13070             hasdir = isunix = 1;
13071             break;
13072         }
13073         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13074             hasdir = 1;
13075             break;
13076         }
13077     }
13078
13079     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13080     if ((hasdir == 0) && decc_filename_unix_report) {
13081         isunix = 1;
13082     }
13083
13084     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13085         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13086         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13087         int wildstar = 0;
13088         int wildquery = 0;
13089         int found = 0;
13090         Stat_t st;
13091         int stat_sts;
13092         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13093         if (!stat_sts && S_ISDIR(st.st_mode)) {
13094             char * vms_dir;
13095             const char * fname;
13096             STRLEN fname_len;
13097
13098             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13099             /* path delimiter of ':>]', if so, then the old behavior has */
13100             /* obviously been specifically requested */
13101
13102             fname = SvPVX_const(tmpglob);
13103             fname_len = strlen(fname);
13104             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13105             if (vms_old_glob || (vms_dir != NULL)) {
13106                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13107                                             SvPVX(tmpglob),vmsspec,NULL);
13108                 ok = (wilddsc.dsc$a_pointer != NULL);
13109                 /* maybe passed 'foo' rather than '[.foo]', thus not
13110                    detected above */
13111                 hasdir = 1;
13112             } else {
13113                 /* Operate just on the directory, the special stat/fstat for */
13114                 /* leaves the fileified  specification in the st_devnam */
13115                 /* member. */
13116                 wilddsc.dsc$a_pointer = st.st_devnam;
13117                 ok = 1;
13118             }
13119         }
13120         else {
13121             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13122             ok = (wilddsc.dsc$a_pointer != NULL);
13123         }
13124         if (ok)
13125             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13126
13127         /* If not extended character set, replace ? with % */
13128         /* With extended character set, ? is a wildcard single character */
13129         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13130             if (*cp == '?') {
13131                 wildquery = 1;
13132                 if (!decc_efs_charset)
13133                     *cp = '%';
13134             } else if (*cp == '%') {
13135                 wildquery = 1;
13136             } else if (*cp == '*') {
13137                 wildstar = 1;
13138             }
13139         }
13140
13141         if (ok) {
13142             wv_sts = vms_split_path(
13143                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13144                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13145                 &wvs_spec, &wvs_len);
13146         } else {
13147             wn_spec = NULL;
13148             wn_len = 0;
13149             we_spec = NULL;
13150             we_len = 0;
13151         }
13152
13153         sts = SS$_NORMAL;
13154         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13155          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13156          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13157          int valid_find;
13158
13159             valid_find = 0;
13160             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13161                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13162             if (!$VMS_STATUS_SUCCESS(sts))
13163                 break;
13164
13165             /* with varying string, 1st word of buffer contains result length */
13166             rstr[rslt->length] = '\0';
13167
13168              /* Find where all the components are */
13169              v_sts = vms_split_path
13170                        (rstr,
13171                         &v_spec,
13172                         &v_len,
13173                         &r_spec,
13174                         &r_len,
13175                         &d_spec,
13176                         &d_len,
13177                         &n_spec,
13178                         &n_len,
13179                         &e_spec,
13180                         &e_len,
13181                         &vs_spec,
13182                         &vs_len);
13183
13184             /* If no version on input, truncate the version on output */
13185             if (!hasver && (vs_len > 0)) {
13186                 *vs_spec = '\0';
13187                 vs_len = 0;
13188             }
13189
13190             if (isunix) {
13191
13192                 /* In Unix report mode, remove the ".dir;1" from the name */
13193                 /* if it is a real directory */
13194                 if (decc_filename_unix_report && decc_efs_charset) {
13195                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13196                         Stat_t statbuf;
13197                         int ret_sts;
13198
13199                         ret_sts = flex_lstat(rstr, &statbuf);
13200                         if ((ret_sts == 0) &&
13201                             S_ISDIR(statbuf.st_mode)) {
13202                             e_len = 0;
13203                             e_spec[0] = 0;
13204                         }
13205                     }
13206                 }
13207
13208                 /* No version & a null extension on UNIX handling */
13209                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13210                     e_len = 0;
13211                     *e_spec = '\0';
13212                 }
13213             }
13214
13215             if (!decc_efs_case_preserve) {
13216                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13217             }
13218
13219             /* Find File treats a Null extension as return all extensions */
13220             /* This is contrary to Perl expectations */
13221
13222             if (wildstar || wildquery || vms_old_glob) {
13223                 /* really need to see if the returned file name matched */
13224                 /* but for now will assume that it matches */
13225                 valid_find = 1;
13226             } else {
13227                 /* Exact Match requested */
13228                 /* How are directories handled? - like a file */
13229                 if ((e_len == we_len) && (n_len == wn_len)) {
13230                     int t1;
13231                     t1 = e_len;
13232                     if (t1 > 0)
13233                         t1 = strncmp(e_spec, we_spec, e_len);
13234                     if (t1 == 0) {
13235                        t1 = n_len;
13236                        if (t1 > 0)
13237                            t1 = strncmp(n_spec, we_spec, n_len);
13238                        if (t1 == 0)
13239                            valid_find = 1;
13240                     }
13241                 }
13242             }
13243
13244             if (valid_find) {
13245                 found++;
13246
13247                 if (hasdir) {
13248                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13249                     begin = rstr;
13250                 }
13251                 else {
13252                     /* Start with the name */
13253                     begin = n_spec;
13254                 }
13255                 strcat(begin,"\n");
13256                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13257             }
13258         }
13259         if (cxt) (void)lib$find_file_end(&cxt);
13260
13261         if (!found) {
13262             /* Be POSIXish: return the input pattern when no matches */
13263             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13264             strcat(rstr,"\n");
13265             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13266         }
13267
13268         if (ok && sts != RMS$_NMF &&
13269             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13270         if (!ok) {
13271             if (!(sts & 1)) {
13272                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13273             }
13274             PerlIO_close(tmpfp);
13275             fp = NULL;
13276         }
13277         else {
13278             PerlIO_rewind(tmpfp);
13279             IoTYPE(io) = IoTYPE_RDONLY;
13280             IoIFP(io) = fp = tmpfp;
13281             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13282         }
13283     }
13284     Safefree(vmsspec);
13285     Safefree(rslt);
13286     return fp;
13287 }
13288
13289
13290 static char *
13291 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13292                    int *utf8_fl);
13293
13294 void
13295 unixrealpath_fromperl(pTHX_ CV *cv)
13296 {
13297     dXSARGS;
13298     char *fspec, *rslt_spec, *rslt;
13299     STRLEN n_a;
13300
13301     if (!items || items != 1)
13302         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13303
13304     fspec = SvPV(ST(0),n_a);
13305     if (!fspec || !*fspec) XSRETURN_UNDEF;
13306
13307     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13308     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13309
13310     ST(0) = sv_newmortal();
13311     if (rslt != NULL)
13312         sv_usepvn(ST(0),rslt,strlen(rslt));
13313     else
13314         Safefree(rslt_spec);
13315         XSRETURN(1);
13316 }
13317
13318 static char *
13319 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13320                    int *utf8_fl);
13321
13322 void
13323 vmsrealpath_fromperl(pTHX_ CV *cv)
13324 {
13325     dXSARGS;
13326     char *fspec, *rslt_spec, *rslt;
13327     STRLEN n_a;
13328
13329     if (!items || items != 1)
13330         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13331
13332     fspec = SvPV(ST(0),n_a);
13333     if (!fspec || !*fspec) XSRETURN_UNDEF;
13334
13335     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13336     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13337
13338     ST(0) = sv_newmortal();
13339     if (rslt != NULL)
13340         sv_usepvn(ST(0),rslt,strlen(rslt));
13341     else
13342         Safefree(rslt_spec);
13343         XSRETURN(1);
13344 }
13345
13346 #ifdef HAS_SYMLINK
13347 /*
13348  * A thin wrapper around decc$symlink to make sure we follow the
13349  * standard and do not create a symlink with a zero-length name,
13350  * and convert the target to Unix format, as the CRTL can't handle
13351  * targets in VMS format.
13352  */
13353 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13354 int
13355 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13356 {
13357     int sts;
13358     char * utarget;
13359
13360     if (!link_name || !*link_name) {
13361       SETERRNO(ENOENT, SS$_NOSUCHFILE);
13362       return -1;
13363     }
13364
13365     utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13366     /* An untranslatable filename should be passed through. */
13367     (void) int_tounixspec(contents, utarget, NULL);
13368     sts = symlink(utarget, link_name);
13369     PerlMem_free(utarget);
13370     return sts;
13371 }
13372 /*}}}*/
13373
13374 #endif /* HAS_SYMLINK */
13375
13376 int do_vms_case_tolerant(void);
13377
13378 void
13379 case_tolerant_process_fromperl(pTHX_ CV *cv)
13380 {
13381   dXSARGS;
13382   ST(0) = boolSV(do_vms_case_tolerant());
13383   XSRETURN(1);
13384 }
13385
13386 #ifdef USE_ITHREADS
13387
13388 void
13389 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13390                           struct interp_intern *dst)
13391 {
13392     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13393
13394     memcpy(dst,src,sizeof(struct interp_intern));
13395 }
13396
13397 #endif
13398
13399 void
13400 Perl_sys_intern_clear(pTHX)
13401 {
13402 }
13403
13404 void
13405 Perl_sys_intern_init(pTHX)
13406 {
13407     unsigned int ix = RAND_MAX;
13408     double x;
13409
13410     VMSISH_HUSHED = 0;
13411
13412     MY_POSIX_EXIT = vms_posix_exit;
13413
13414     x = (float)ix;
13415     MY_INV_RAND_MAX = 1./x;
13416 }
13417
13418 void
13419 init_os_extras(void)
13420 {
13421   dTHX;
13422   char* file = __FILE__;
13423   if (decc_disable_to_vms_logname_translation) {
13424     no_translate_barewords = TRUE;
13425   } else {
13426     no_translate_barewords = FALSE;
13427   }
13428
13429   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13430   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13431   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13432   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13433   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13434   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13435   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13436   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13437   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13438   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13439   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13440   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13441   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13442   newXSproto("VMS::Filespec::case_tolerant_process",
13443       case_tolerant_process_fromperl,file,"");
13444
13445   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13446
13447   return;
13448 }
13449
13450 #if __CRTL_VER == 80200000
13451 /* This missed getting in to the DECC SDK for 8.2 */
13452 char *realpath(const char *file_name, char * resolved_name, ...);
13453 #endif
13454
13455 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13456 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13457  * The perl fallback routine to provide realpath() is not as efficient
13458  * on OpenVMS.
13459  */
13460
13461 #ifdef __cplusplus
13462 extern "C" {
13463 #endif
13464
13465 /* Hack, use old stat() as fastest way of getting ino_t and device */
13466 int decc$stat(const char *name, void * statbuf);
13467 #if !defined(__VAX) && __CRTL_VER >= 80200000
13468 int decc$lstat(const char *name, void * statbuf);
13469 #else
13470 #define decc$lstat decc$stat
13471 #endif
13472
13473 #ifdef __cplusplus
13474 }
13475 #endif
13476
13477
13478 /* Realpath is fragile.  In 8.3 it does not work if the feature
13479  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13480  * links are implemented in RMS, not the CRTL. It also can fail if the
13481  * user does not have read/execute access to some of the directories.
13482  * So in order for Do What I Mean mode to work, if realpath() fails,
13483  * fall back to looking up the filename by the device name and FID.
13484  */
13485
13486 int vms_fid_to_name(char * outname, int outlen,
13487                     const char * name, int lstat_flag, mode_t * mode)
13488 {
13489 #pragma message save
13490 #pragma message disable MISALGNDSTRCT
13491 #pragma message disable MISALGNDMEM
13492 #pragma member_alignment save
13493 #pragma nomember_alignment
13494 struct statbuf_t {
13495     char           * st_dev;
13496     unsigned short st_ino[3];
13497     unsigned short old_st_mode;
13498     unsigned long  padl[30];  /* plenty of room */
13499 } statbuf;
13500 #pragma message restore
13501 #pragma member_alignment restore
13502
13503     int sts;
13504     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13505     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13506     char *fileified;
13507     char *temp_fspec;
13508     char *ret_spec;
13509
13510     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13511      * unexpected answers
13512      */
13513
13514     fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13515     if (fileified == NULL)
13516         _ckvmssts_noperl(SS$_INSFMEM);
13517
13518     temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13519     if (temp_fspec == NULL)
13520         _ckvmssts_noperl(SS$_INSFMEM);
13521
13522     sts = -1;
13523     /* First need to try as a directory */
13524     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13525     if (ret_spec != NULL) {
13526         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13527         if (ret_spec != NULL) {
13528             if (lstat_flag == 0)
13529                 sts = decc$stat(fileified, &statbuf);
13530             else
13531                 sts = decc$lstat(fileified, &statbuf);
13532         }
13533     }
13534
13535     /* Then as a VMS file spec */
13536     if (sts != 0) {
13537         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13538         if (ret_spec != NULL) {
13539             if (lstat_flag == 0) {
13540                 sts = decc$stat(temp_fspec, &statbuf);
13541             } else {
13542                 sts = decc$lstat(temp_fspec, &statbuf);
13543             }
13544         }
13545     }
13546
13547     if (sts) {
13548         /* Next try - allow multiple dots with out EFS CHARSET */
13549         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13550          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13551          * enable it if it isn't already.
13552          */
13553 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13554         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13555             decc$feature_set_value(decc_efs_charset_index, 1, 1);
13556 #endif
13557         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13558         if (lstat_flag == 0) {
13559             sts = decc$stat(name, &statbuf);
13560         } else {
13561             sts = decc$lstat(name, &statbuf);
13562         }
13563 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13564         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13565             decc$feature_set_value(decc_efs_charset_index, 1, 0);
13566 #endif
13567     }
13568
13569
13570     /* and then because the Perl Unix to VMS conversion is not perfect */
13571     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13572     /* characters from filenames so we need to try it as-is */
13573     if (sts) {
13574         if (lstat_flag == 0) {
13575             sts = decc$stat(name, &statbuf);
13576         } else {
13577             sts = decc$lstat(name, &statbuf);
13578         }
13579     }
13580
13581     if (sts == 0) {
13582         int vms_sts;
13583
13584         dvidsc.dsc$a_pointer=statbuf.st_dev;
13585         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13586
13587         specdsc.dsc$a_pointer = outname;
13588         specdsc.dsc$w_length = outlen-1;
13589
13590         vms_sts = lib$fid_to_name
13591             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13592         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13593             outname[specdsc.dsc$w_length] = 0;
13594
13595             /* Return the mode */
13596             if (mode) {
13597                 *mode = statbuf.old_st_mode;
13598             }
13599         }
13600     }
13601     PerlMem_free(temp_fspec);
13602     PerlMem_free(fileified);
13603     return sts;
13604 }
13605
13606
13607
13608 static char *
13609 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13610                    int *utf8_fl)
13611 {
13612     char * rslt = NULL;
13613
13614 #ifdef HAS_SYMLINK
13615     if (decc_posix_compliant_pathnames > 0 ) {
13616         /* realpath currently only works if posix compliant pathnames are
13617          * enabled.  It may start working when they are not, but in that
13618          * case we still want the fallback behavior for backwards compatibility
13619          */
13620         rslt = realpath(filespec, outbuf);
13621     }
13622 #endif
13623
13624     if (rslt == NULL) {
13625         char * vms_spec;
13626         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13627         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13628         mode_t my_mode;
13629
13630         /* Fall back to fid_to_name */
13631
13632         Newx(vms_spec, VMS_MAXRSS + 1, char);
13633
13634         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13635         if (sts == 0) {
13636
13637
13638             /* Now need to trim the version off */
13639             sts = vms_split_path
13640                   (vms_spec,
13641                    &v_spec,
13642                    &v_len,
13643                    &r_spec,
13644                    &r_len,
13645                    &d_spec,
13646                    &d_len,
13647                    &n_spec,
13648                    &n_len,
13649                    &e_spec,
13650                    &e_len,
13651                    &vs_spec,
13652                    &vs_len);
13653
13654
13655                 if (sts == 0) {
13656                     int haslower = 0;
13657                     const char *cp;
13658
13659                     /* Trim off the version */
13660                     int file_len = v_len + r_len + d_len + n_len + e_len;
13661                     vms_spec[file_len] = 0;
13662
13663                     /* Trim off the .DIR if this is a directory */
13664                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13665                         if (S_ISDIR(my_mode)) {
13666                             e_len = 0;
13667                             e_spec[0] = 0;
13668                         }
13669                     }
13670
13671                     /* Drop NULL extensions on UNIX file specification */
13672                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
13673                         e_len = 0;
13674                         e_spec[0] = '\0';
13675                     }
13676
13677                     /* The result is expected to be in UNIX format */
13678                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13679
13680                     /* Downcase if input had any lower case letters and
13681                      * case preservation is not in effect.
13682                      */
13683                     if (!decc_efs_case_preserve) {
13684                         for (cp = filespec; *cp; cp++)
13685                             if (islower(*cp)) { haslower = 1; break; }
13686
13687                         if (haslower) __mystrtolower(rslt);
13688                     }
13689                 }
13690         } else {
13691
13692             /* Now for some hacks to deal with backwards and forward */
13693             /* compatibility */
13694             if (!decc_efs_charset) {
13695
13696                 /* 1. ODS-2 mode wants to do a syntax only translation */
13697                 rslt = int_rmsexpand(filespec, outbuf,
13698                                     NULL, 0, NULL, utf8_fl);
13699
13700             } else {
13701                 if (decc_filename_unix_report) {
13702                     char * dir_name;
13703                     char * vms_dir_name;
13704                     char * file_name;
13705
13706                     /* 2. ODS-5 / UNIX report mode should return a failure */
13707                     /*    if the parent directory also does not exist */
13708                     /*    Otherwise, get the real path for the parent */
13709                     /*    and add the child to it. */
13710
13711                     /* basename / dirname only available for VMS 7.0+ */
13712                     /* So we may need to implement them as common routines */
13713
13714                     Newx(dir_name, VMS_MAXRSS + 1, char);
13715                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13716                     dir_name[0] = '\0';
13717                     file_name = NULL;
13718
13719                     /* First try a VMS parse */
13720                     sts = vms_split_path
13721                           (filespec,
13722                            &v_spec,
13723                            &v_len,
13724                            &r_spec,
13725                            &r_len,
13726                            &d_spec,
13727                            &d_len,
13728                            &n_spec,
13729                            &n_len,
13730                            &e_spec,
13731                            &e_len,
13732                            &vs_spec,
13733                            &vs_len);
13734
13735                     if (sts == 0) {
13736                         /* This is VMS */
13737
13738                         int dir_len = v_len + r_len + d_len + n_len;
13739                         if (dir_len > 0) {
13740                            memcpy(dir_name, filespec, dir_len);
13741                            dir_name[dir_len] = '\0';
13742                            file_name = (char *)&filespec[dir_len + 1];
13743                         }
13744                     } else {
13745                         /* This must be UNIX */
13746                         char * tchar;
13747
13748                         tchar = strrchr(filespec, '/');
13749
13750                         if (tchar != NULL) {
13751                             int dir_len = tchar - filespec;
13752                             memcpy(dir_name, filespec, dir_len);
13753                             dir_name[dir_len] = '\0';
13754                             file_name = (char *) &filespec[dir_len + 1];
13755                         }
13756                     }
13757
13758                     /* Dir name is defaulted */
13759                     if (dir_name[0] == 0) {
13760                         dir_name[0] = '.';
13761                         dir_name[1] = '\0';
13762                     }
13763
13764                     /* Need realpath for the directory */
13765                     sts = vms_fid_to_name(vms_dir_name,
13766                                           VMS_MAXRSS + 1,
13767                                           dir_name, 0, NULL);
13768
13769                     if (sts == 0) {
13770                         /* Now need to pathify it. */
13771                         char *tdir = int_pathify_dirspec(vms_dir_name,
13772                                                          outbuf);
13773
13774                         /* And now add the original filespec to it */
13775                         if (file_name != NULL) {
13776                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13777                         }
13778                         return outbuf;
13779                     }
13780                     Safefree(vms_dir_name);
13781                     Safefree(dir_name);
13782                 }
13783             }
13784         }
13785         Safefree(vms_spec);
13786     }
13787     return rslt;
13788 }
13789
13790 static char *
13791 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13792                    int *utf8_fl)
13793 {
13794     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13795     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13796
13797     /* Fall back to fid_to_name */
13798
13799     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13800     if (sts != 0) {
13801         return NULL;
13802     }
13803     else {
13804
13805
13806         /* Now need to trim the version off */
13807         sts = vms_split_path
13808                   (outbuf,
13809                    &v_spec,
13810                    &v_len,
13811                    &r_spec,
13812                    &r_len,
13813                    &d_spec,
13814                    &d_len,
13815                    &n_spec,
13816                    &n_len,
13817                    &e_spec,
13818                    &e_len,
13819                    &vs_spec,
13820                    &vs_len);
13821
13822
13823         if (sts == 0) {
13824             int haslower = 0;
13825             const char *cp;
13826
13827             /* Trim off the version */
13828             int file_len = v_len + r_len + d_len + n_len + e_len;
13829             outbuf[file_len] = 0;
13830
13831             /* Downcase if input had any lower case letters and
13832              * case preservation is not in effect.
13833              */
13834             if (!decc_efs_case_preserve) {
13835                 for (cp = filespec; *cp; cp++)
13836                     if (islower(*cp)) { haslower = 1; break; }
13837
13838                 if (haslower) __mystrtolower(outbuf);
13839             }
13840         }
13841     }
13842     return outbuf;
13843 }
13844
13845
13846 /*}}}*/
13847 /* External entry points */
13848 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13849 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13850
13851 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13852 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13853
13854 /* case_tolerant */
13855
13856 /*{{{int do_vms_case_tolerant(void)*/
13857 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13858  * controlled by a process setting.
13859  */
13860 int do_vms_case_tolerant(void)
13861 {
13862     return vms_process_case_tolerant;
13863 }
13864 /*}}}*/
13865 /* External entry points */
13866 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13867 int Perl_vms_case_tolerant(void)
13868 { return do_vms_case_tolerant(); }
13869 #else
13870 int Perl_vms_case_tolerant(void)
13871 { return vms_process_case_tolerant; }
13872 #endif
13873
13874
13875  /* Start of DECC RTL Feature handling */
13876
13877 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13878
13879 static int
13880 set_feature_default(const char *name, int value)
13881 {
13882     int status;
13883     int index;
13884     char val_str[10];
13885
13886     /* If the feature has been explicitly disabled in the environment,
13887      * then don't enable it here.
13888      */
13889     if (value > 0) {
13890         status = simple_trnlnm(name, val_str, sizeof(val_str));
13891         if (status) {
13892             val_str[0] = _toupper(val_str[0]);
13893             if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
13894                 return 0;
13895         }
13896     }
13897
13898     index = decc$feature_get_index(name);
13899
13900     status = decc$feature_set_value(index, 1, value);
13901     if (index == -1 || (status == -1)) {
13902       return -1;
13903     }
13904
13905     status = decc$feature_get_value(index, 1);
13906     if (status != value) {
13907       return -1;
13908     }
13909
13910     /* Various things may check for an environment setting
13911      * rather than the feature directly, so set that too.
13912      */
13913     vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13914
13915     return 0;
13916 }
13917 #endif
13918
13919
13920 /* C RTL Feature settings */
13921
13922 #if defined(__DECC) || defined(__DECCXX)
13923
13924 #ifdef __cplusplus
13925 extern "C" {
13926 #endif
13927
13928 extern void
13929 vmsperl_set_features(void)
13930 {
13931     int status;
13932     int s;
13933     char val_str[10];
13934 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13935     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13936     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13937     unsigned long case_perm;
13938     unsigned long case_image;
13939 #endif
13940
13941     /* Allow an exception to bring Perl into the VMS debugger */
13942     vms_debug_on_exception = 0;
13943     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13944     if (status) {
13945        val_str[0] = _toupper(val_str[0]);
13946        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13947          vms_debug_on_exception = 1;
13948        else
13949          vms_debug_on_exception = 0;
13950     }
13951
13952     /* Debug unix/vms file translation routines */
13953     vms_debug_fileify = 0;
13954     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13955     if (status) {
13956         val_str[0] = _toupper(val_str[0]);
13957         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13958             vms_debug_fileify = 1;
13959         else
13960             vms_debug_fileify = 0;
13961     }
13962
13963
13964     /* Historically PERL has been doing vmsify / stat differently than */
13965     /* the CRTL.  In particular, under some conditions the CRTL will   */
13966     /* remove some illegal characters like spaces from filenames       */
13967     /* resulting in some differences.  The stat()/lstat() wrapper has  */
13968     /* been reporting such file names as invalid and fails to stat them */
13969     /* fixing this bug so that stat()/lstat() accept these like the     */
13970     /* CRTL does will result in several tests failing.                  */
13971     /* This should really be fixed, but for now, set up a feature to    */
13972     /* enable it so that the impact can be studied.                     */
13973     vms_bug_stat_filename = 0;
13974     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13975     if (status) {
13976         val_str[0] = _toupper(val_str[0]);
13977         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13978             vms_bug_stat_filename = 1;
13979         else
13980             vms_bug_stat_filename = 0;
13981     }
13982
13983
13984     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13985     vms_vtf7_filenames = 0;
13986     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13987     if (status) {
13988        val_str[0] = _toupper(val_str[0]);
13989        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13990          vms_vtf7_filenames = 1;
13991        else
13992          vms_vtf7_filenames = 0;
13993     }
13994
13995     /* unlink all versions on unlink() or rename() */
13996     vms_unlink_all_versions = 0;
13997     status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13998     if (status) {
13999        val_str[0] = _toupper(val_str[0]);
14000        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14001          vms_unlink_all_versions = 1;
14002        else
14003          vms_unlink_all_versions = 0;
14004     }
14005
14006 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14007     /* Detect running under GNV Bash or other UNIX like shell */
14008     gnv_unix_shell = 0;
14009     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14010     if (status) {
14011          gnv_unix_shell = 1;
14012          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14013          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14014          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14015          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14016          vms_unlink_all_versions = 1;
14017          vms_posix_exit = 1;
14018          /* Reverse default ordering of PERL_ENV_TABLES. */
14019          defenv[0] = &crtlenvdsc;
14020          defenv[1] = &fildevdsc;
14021     }
14022     /* Some reasonable defaults that are not CRTL defaults */
14023     set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14024     set_feature_default("DECC$ARGV_PARSE_STYLE", 1);     /* Requires extended parse. */
14025     set_feature_default("DECC$EFS_CHARSET", 1);
14026 #endif
14027
14028     /* hacks to see if known bugs are still present for testing */
14029
14030     /* PCP mode requires creating /dev/null special device file */
14031     decc_bug_devnull = 0;
14032     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14033     if (status) {
14034        val_str[0] = _toupper(val_str[0]);
14035        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14036           decc_bug_devnull = 1;
14037        else
14038           decc_bug_devnull = 0;
14039     }
14040
14041 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14042     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14043     if (s >= 0) {
14044         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14045         if (decc_disable_to_vms_logname_translation < 0)
14046             decc_disable_to_vms_logname_translation = 0;
14047     }
14048
14049     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14050     if (s >= 0) {
14051         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14052         if (decc_efs_case_preserve < 0)
14053             decc_efs_case_preserve = 0;
14054     }
14055
14056     s = decc$feature_get_index("DECC$EFS_CHARSET");
14057     decc_efs_charset_index = s;
14058     if (s >= 0) {
14059         decc_efs_charset = decc$feature_get_value(s, 1);
14060         if (decc_efs_charset < 0)
14061             decc_efs_charset = 0;
14062     }
14063
14064     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14065     if (s >= 0) {
14066         decc_filename_unix_report = decc$feature_get_value(s, 1);
14067         if (decc_filename_unix_report > 0) {
14068             decc_filename_unix_report = 1;
14069             vms_posix_exit = 1;
14070         }
14071         else
14072             decc_filename_unix_report = 0;
14073     }
14074
14075     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14076     if (s >= 0) {
14077         decc_filename_unix_only = decc$feature_get_value(s, 1);
14078         if (decc_filename_unix_only > 0) {
14079             decc_filename_unix_only = 1;
14080         }
14081         else {
14082             decc_filename_unix_only = 0;
14083         }
14084     }
14085
14086     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14087     if (s >= 0) {
14088         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14089         if (decc_filename_unix_no_version < 0)
14090             decc_filename_unix_no_version = 0;
14091     }
14092
14093     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14094     if (s >= 0) {
14095         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14096         if (decc_readdir_dropdotnotype < 0)
14097             decc_readdir_dropdotnotype = 0;
14098     }
14099
14100 #if __CRTL_VER >= 80200000
14101     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14102     if (s >= 0) {
14103         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14104         if (decc_posix_compliant_pathnames < 0)
14105             decc_posix_compliant_pathnames = 0;
14106         if (decc_posix_compliant_pathnames > 4)
14107             decc_posix_compliant_pathnames = 0;
14108     }
14109
14110 #endif
14111 #else
14112     status = simple_trnlnm
14113         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14114     if (status) {
14115         val_str[0] = _toupper(val_str[0]);
14116         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14117            decc_disable_to_vms_logname_translation = 1;
14118         }
14119     }
14120
14121 #ifndef __VAX
14122     status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14123     if (status) {
14124         val_str[0] = _toupper(val_str[0]);
14125         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14126            decc_efs_case_preserve = 1;
14127         }
14128     }
14129 #endif
14130
14131     status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14132     if (status) {
14133         val_str[0] = _toupper(val_str[0]);
14134         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14135            decc_filename_unix_report = 1;
14136         }
14137     }
14138     status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14139     if (status) {
14140         val_str[0] = _toupper(val_str[0]);
14141         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14142            decc_filename_unix_only = 1;
14143            decc_filename_unix_report = 1;
14144         }
14145     }
14146     status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14147     if (status) {
14148         val_str[0] = _toupper(val_str[0]);
14149         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14150            decc_filename_unix_no_version = 1;
14151         }
14152     }
14153     status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14154     if (status) {
14155         val_str[0] = _toupper(val_str[0]);
14156         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14157            decc_readdir_dropdotnotype = 1;
14158         }
14159     }
14160 #endif
14161
14162 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14163
14164      /* Report true case tolerance */
14165     /*----------------------------*/
14166     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14167     if (!$VMS_STATUS_SUCCESS(status))
14168         case_perm = PPROP$K_CASE_BLIND;
14169     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14170     if (!$VMS_STATUS_SUCCESS(status))
14171         case_image = PPROP$K_CASE_BLIND;
14172     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14173         (case_image == PPROP$K_CASE_SENSITIVE))
14174         vms_process_case_tolerant = 0;
14175
14176 #endif
14177
14178     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14179     /* for strict backward compatibility */
14180     status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14181     if (status) {
14182        val_str[0] = _toupper(val_str[0]);
14183        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14184          vms_posix_exit = 1;
14185        else
14186          vms_posix_exit = 0;
14187     }
14188 }
14189
14190 /* Use 32-bit pointers because that's what the image activator
14191  * assumes for the LIB$INITIALZE psect.
14192  */
14193 #if __INITIAL_POINTER_SIZE
14194 #pragma pointer_size save
14195 #pragma pointer_size 32
14196 #endif
14197
14198 /* Create a reference to the LIB$INITIALIZE function. */
14199 extern void LIB$INITIALIZE(void);
14200 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14201
14202 /* Create an array of pointers to the init functions in the special
14203  * LIB$INITIALIZE section. In our case, the array only has one entry.
14204  */
14205 #pragma extern_model save
14206 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
14207 extern void (* const vmsperl_unused_global_2[])() =
14208 {
14209    vmsperl_set_features,
14210 };
14211 #pragma extern_model restore
14212
14213 #if __INITIAL_POINTER_SIZE
14214 #pragma pointer_size restore
14215 #endif
14216
14217 #ifdef __cplusplus
14218 }
14219 #endif
14220
14221 #endif /* defined(__DECC) || defined(__DECCXX) */
14222 /*  End of vms.c */