vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993-2015 by Charles Bailey and others.
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  */
  10
  11 /*
  12  *   Yet small as was their hunted band
  13  *   still fell and fearless was each hand,
  14  *   and strong deeds they wrought yet oft,
  15  *   and loved the woods, whose ways more soft
  16  *   them seemed than thralls of that black throne
  17  *   to live and languish in halls of stone.
  18  *        "The Lay of Leithian", Canto II, lines 135-40
  19  *
  20  *     [p.162 of _The Lays of Beleriand_]
  21  */
  22
  23 #include <acedef.h>
  24 #include <acldef.h>
  25 #include <armdef.h>
  26 #if __CRTL_VER < 70300000
  27 /* needed for home-rolled utime() */
  28 #include <atrdef.h>
  29 #include <fibdef.h>
  30 #endif
  31 #include <chpdef.h>
  32 #include <clidef.h>
  33 #include <climsgdef.h>
  34 #include <dcdef.h>
  35 #include <descrip.h>
  36 #include <devdef.h>
  37 #include <dvidef.h>
  38 #include <float.h>
  39 #include <fscndef.h>
  40 #include <iodef.h>
  41 #include <jpidef.h>
  42 #include <kgbdef.h>
  43 #include <libclidef.h>
  44 #include <libdef.h>
  45 #include <lib$routines.h>
  46 #include <lnmdef.h>
  47 #include <ossdef.h>
  48 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  49 #include <ppropdef.h>
  50 #endif
  51 #include <prvdef.h>
  52 #include <psldef.h>
  53 #include <rms.h>
  54 #include <shrdef.h>
  55 #include <ssdef.h>
  56 #include <starlet.h>
  57 #include <strdef.h>
  58 #include <str$routines.h>
  59 #include <syidef.h>
  60 #include <uaidef.h>
  61 #include <uicdef.h>
  62 #include <stsdef.h>
  63 #include <efndef.h>
  64 #define NO_EFN EFN$C_ENF
  65
  66 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  67 int   decc$feature_get_index(const char *name);
  68 char* decc$feature_get_name(int index);
  69 int   decc$feature_get_value(int index, int mode);
  70 int   decc$feature_set_value(int index, int mode, int value);
  71 #else
  72 #include <unixlib.h>
  73 #endif
  74
  75 #pragma member_alignment save
  76 #pragma nomember_alignment longword
  77 struct item_list_3 {
  78         unsigned short len;
  79         unsigned short code;
  80         void * bufadr;
  81         unsigned short * retadr;
  82 };
  83 #pragma member_alignment restore
  84
  85 /* Older versions of ssdef.h don't have these */
  86 #ifndef SS$_INVFILFOROP
  87 #  define SS$_INVFILFOROP 3930
  88 #endif
  89 #ifndef SS$_NOSUCHOBJECT
  90 #  define SS$_NOSUCHOBJECT 2696
  91 #endif
  92
  93 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
  94 #define PERLIO_NOT_STDIO 0
  95
  96 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
  97  * code below needs to get to the underlying CRTL routines. */
  98 #define DONT_MASK_RTL_CALLS
  99 #include "EXTERN.h"
 100 #include "perl.h"
 101 #include "XSUB.h"
 102 /* Anticipating future expansion in lexical warnings . . . */
 103 #ifndef WARN_INTERNAL
 104 #  define WARN_INTERNAL WARN_MISC
 105 #endif
 106
 107 #ifdef VMS_LONGNAME_SUPPORT
 108 #include <libfildef.h>
 109 #endif
 110
 111 #if !defined(__VAX) && __CRTL_VER >= 80200000
 112 #ifdef lstat
 113 #undef lstat
 114 #endif
 115 #else
 116 #ifdef lstat
 117 #undef lstat
 118 #endif
 119 #define lstat(_x, _y) stat(_x, _y)
 120 #endif
 121
 122 /* Routine to create a decterm for use with the Perl debugger */
 123 /* No headers, this information was found in the Programming Concepts Manual */
 124
 125 static int (*decw_term_port)
 126    (const struct dsc$descriptor_s * display,
 127     const struct dsc$descriptor_s * setup_file,
 128     const struct dsc$descriptor_s * customization,
 129     struct dsc$descriptor_s * result_device_name,
 130     unsigned short * result_device_name_length,
 131     void * controller,
 132     void * char_buffer,
 133     void * char_change_buffer) = 0;
 134
 135 /* gcc's header files don't #define direct access macros
 136  * corresponding to VAXC's variant structs */
 137 #ifdef __GNUC__
 138 #  define uic$v_format uic$r_uic_form.uic$v_format
 139 #  define uic$v_group uic$r_uic_form.uic$v_group
 140 #  define uic$v_member uic$r_uic_form.uic$v_member
 141 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 142 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 143 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 144 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 145 #endif
 146
 147 #if defined(NEED_AN_H_ERRNO)
 148 dEXT int h_errno;
 149 #endif
 150
 151 #if defined(__DECC) || defined(__DECCXX)
 152 #pragma member_alignment save
 153 #pragma nomember_alignment longword
 154 #pragma message save
 155 #pragma message disable misalgndmem
 156 #endif
 157 struct itmlst_3 {
 158   unsigned short int buflen;
 159   unsigned short int itmcode;
 160   void *bufadr;
 161   unsigned short int *retlen;
 162 };
 163
 164 struct filescan_itmlst_2 {
 165     unsigned short length;
 166     unsigned short itmcode;
 167     char * component;
 168 };
 169
 170 struct vs_str_st {
 171     unsigned short length;
 172     char str[VMS_MAXRSS];
 173     unsigned short pad; /* for longword struct alignment */
 174 };
 175
 176 #if defined(__DECC) || defined(__DECCXX)
 177 #pragma message restore
 178 #pragma member_alignment restore
 179 #endif
 180
 181 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 182 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 183 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 184 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 185 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 186 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 187 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 188 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 189 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 190 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 191 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 192 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 193
 194 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 195 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 196 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 197 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 198
 199 static char *  int_rmsexpand_vms(
 200     const char * filespec, char * outbuf, unsigned opts);
 201 static char * int_rmsexpand_tovms(
 202     const char * filespec, char * outbuf, unsigned opts);
 203 static char *int_tovmsspec
 204    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 205 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 206 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 207 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 208
 209 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 210 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 211
 212 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 213  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 214  * the Perl facility.
 215  */
 216 #define PERL_LNM_MAX_ITER 10
 217
 218   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 219 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 220 #define MAX_DCL_SYMBOL          (8192)
 221 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 222 #else
 223 #define MAX_DCL_SYMBOL          (1024)
 224 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 225 #endif
 226
 227 static char *__mystrtolower(char *str)
 228 {
 229   if (str) for (; *str; ++str) *str= tolower(*str);
 230   return str;
 231 }
 232
 233 static struct dsc$descriptor_s fildevdsc =
 234   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 235 static struct dsc$descriptor_s crtlenvdsc =
 236   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 237 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 238 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 239 static struct dsc$descriptor_s **env_tables = defenv;
 240 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 241
 242 /* True if we shouldn't treat barewords as logicals during directory */
 243 /* munching */
 244 static int no_translate_barewords;
 245
 246 /* DECC Features that may need to affect how Perl interprets
 247  * displays filename information
 248  */
 249 static int decc_disable_to_vms_logname_translation = 1;
 250 static int decc_disable_posix_root = 1;
 251 int decc_efs_case_preserve = 0;
 252 static int decc_efs_charset = 0;
 253 static int decc_efs_charset_index = -1;
 254 static int decc_filename_unix_no_version = 0;
 255 static int decc_filename_unix_only = 0;
 256 int decc_filename_unix_report = 0;
 257 int decc_posix_compliant_pathnames = 0;
 258 int decc_readdir_dropdotnotype = 0;
 259 static int vms_process_case_tolerant = 1;
 260 int vms_vtf7_filenames = 0;
 261 int gnv_unix_shell = 0;
 262 static int vms_unlink_all_versions = 0;
 263 static int vms_posix_exit = 0;
 264
 265 /* bug workarounds if needed */
 266 int decc_bug_devnull = 1;
 267 int vms_bug_stat_filename = 0;
 268
 269 static int vms_debug_on_exception = 0;
 270 static int vms_debug_fileify = 0;
 271
 272 /* Simple logical name translation */
 273 static int
 274 simple_trnlnm(const char * logname, char * value, int value_len)
 275 {
 276     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 277     const unsigned long attr = LNM$M_CASE_BLIND;
 278     struct dsc$descriptor_s name_dsc;
 279     int status;
 280     unsigned short result;
 281     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 282                                 {0, 0, 0, 0}};
 283
 284     name_dsc.dsc$w_length = strlen(logname);
 285     name_dsc.dsc$a_pointer = (char *)logname;
 286     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 287     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 288
 289     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 290
 291     if ($VMS_STATUS_SUCCESS(status)) {
 292
 293          /* Null terminate and return the string */
 294         /*--------------------------------------*/
 295         value[result] = 0;
 296         return result;
 297     }
 298
 299     return 0;
 300 }
 301
 302
 303 /* Is this a UNIX file specification?
 304  *   No longer a simple check with EFS file specs
 305  *   For now, not a full check, but need to
 306  *   handle POSIX ^UP^ specifications
 307  *   Fixing to handle ^/ cases would require
 308  *   changes to many other conversion routines.
 309  */
 310
 311 static int
 312 is_unix_filespec(const char *path)
 313 {
 314     int ret_val;
 315     const char * pch1;
 316
 317     ret_val = 0;
 318     if (strncmp(path,"\"^UP^",5) != 0) {
 319         pch1 = strchr(path, '/');
 320         if (pch1 != NULL)
 321             ret_val = 1;
 322         else {
 323
 324             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 325             if (decc_filename_unix_report || decc_filename_unix_only) {
 326             if (strcmp(path,".") == 0)
 327                 ret_val = 1;
 328             }
 329         }
 330     }
 331     return ret_val;
 332 }
 333
 334 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 335  */
 336
 337 static void
 338 ucs2_to_vtf7(char *outspec, unsigned long ucs2_char, int * output_cnt)
 339 {
 340     unsigned char * ucs_ptr;
 341     int hex;
 342
 343     ucs_ptr = (unsigned char *)&ucs2_char;
 344
 345     outspec[0] = '^';
 346     outspec[1] = 'U';
 347     hex = (ucs_ptr[1] >> 4) & 0xf;
 348     if (hex < 0xA)
 349         outspec[2] = hex + '0';
 350     else
 351         outspec[2] = (hex - 9) + 'A';
 352     hex = ucs_ptr[1] & 0xF;
 353     if (hex < 0xA)
 354         outspec[3] = hex + '0';
 355     else {
 356         outspec[3] = (hex - 9) + 'A';
 357     }
 358     hex = (ucs_ptr[0] >> 4) & 0xf;
 359     if (hex < 0xA)
 360         outspec[4] = hex + '0';
 361     else
 362         outspec[4] = (hex - 9) + 'A';
 363     hex = ucs_ptr[1] & 0xF;
 364     if (hex < 0xA)
 365         outspec[5] = hex + '0';
 366     else {
 367         outspec[5] = (hex - 9) + 'A';
 368     }
 369     *output_cnt = 6;
 370 }
 371
 372
 373 /* This handles the conversion of a UNIX extended character set to a ^
 374  * escaped VMS character.
 375  * in a UNIX file specification.
 376  *
 377  * The output count variable contains the number of characters added
 378  * to the output string.
 379  *
 380  * The return value is the number of characters read from the input string
 381  */
 382 static int
 383 copy_expand_unix_filename_escape(char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 384 {
 385     int count;
 386     int utf8_flag;
 387
 388     utf8_flag = 0;
 389     if (utf8_fl)
 390       utf8_flag = *utf8_fl;
 391
 392     count = 0;
 393     *output_cnt = 0;
 394     if (*inspec >= 0x80) {
 395         if (utf8_fl && vms_vtf7_filenames) {
 396         unsigned long ucs_char;
 397
 398             ucs_char = 0;
 399
 400             if ((*inspec & 0xE0) == 0xC0) {
 401                 /* 2 byte Unicode */
 402                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 403                 if (ucs_char >= 0x80) {
 404                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 405                     return 2;
 406                 }
 407             } else if ((*inspec & 0xF0) == 0xE0) {
 408                 /* 3 byte Unicode */
 409                 ucs_char = ((inspec[0] & 0xF) << 12) +
 410                    ((inspec[1] & 0x3f) << 6) +
 411                    (inspec[2] & 0x3f);
 412                 if (ucs_char >= 0x800) {
 413                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 414                     return 3;
 415                 }
 416
 417 #if 0 /* I do not see longer sequences supported by OpenVMS */
 418       /* Maybe some one can fix this later */
 419             } else if ((*inspec & 0xF8) == 0xF0) {
 420                 /* 4 byte Unicode */
 421                 /* UCS-4 to UCS-2 */
 422             } else if ((*inspec & 0xFC) == 0xF8) {
 423                 /* 5 byte Unicode */
 424                 /* UCS-4 to UCS-2 */
 425             } else if ((*inspec & 0xFE) == 0xFC) {
 426                 /* 6 byte Unicode */
 427                 /* UCS-4 to UCS-2 */
 428 #endif
 429             }
 430         }
 431
 432         /* High bit set, but not a Unicode character! */
 433
 434         /* Non printing DECMCS or ISO Latin-1 character? */
 435         if ((unsigned char)*inspec <= 0x9F) {
 436             int hex;
 437             outspec[0] = '^';
 438             outspec++;
 439             hex = (*inspec >> 4) & 0xF;
 440             if (hex < 0xA)
 441                 outspec[1] = hex + '0';
 442             else {
 443                 outspec[1] = (hex - 9) + 'A';
 444             }
 445             hex = *inspec & 0xF;
 446             if (hex < 0xA)
 447                 outspec[2] = hex + '0';
 448             else {
 449                 outspec[2] = (hex - 9) + 'A';
 450             }
 451             *output_cnt = 3;
 452             return 1;
 453         } else if ((unsigned char)*inspec == 0xA0) {
 454             outspec[0] = '^';
 455             outspec[1] = 'A';
 456             outspec[2] = '0';
 457             *output_cnt = 3;
 458             return 1;
 459         } else if ((unsigned char)*inspec == 0xFF) {
 460             outspec[0] = '^';
 461             outspec[1] = 'F';
 462             outspec[2] = 'F';
 463             *output_cnt = 3;
 464             return 1;
 465         }
 466         *outspec = *inspec;
 467         *output_cnt = 1;
 468         return 1;
 469     }
 470
 471     /* Is this a macro that needs to be passed through?
 472      * Macros start with $( and an alpha character, followed
 473      * by a string of alpha numeric characters ending with a )
 474      * If this does not match, then encode it as ODS-5.
 475      */
 476     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 477     int tcnt;
 478
 479         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 480             tcnt = 3;
 481             outspec[0] = inspec[0];
 482             outspec[1] = inspec[1];
 483             outspec[2] = inspec[2];
 484
 485             while(isalnum(inspec[tcnt]) ||
 486                   (inspec[2] == '.') || (inspec[2] == '_')) {
 487                 outspec[tcnt] = inspec[tcnt];
 488                 tcnt++;
 489             }
 490             if (inspec[tcnt] == ')') {
 491                 outspec[tcnt] = inspec[tcnt];
 492                 tcnt++;
 493                 *output_cnt = tcnt;
 494                 return tcnt;
 495             }
 496         }
 497     }
 498
 499     switch (*inspec) {
 500     case 0x7f:
 501         outspec[0] = '^';
 502         outspec[1] = '7';
 503         outspec[2] = 'F';
 504         *output_cnt = 3;
 505         return 1;
 506         break;
 507     case '?':
 508         if (decc_efs_charset == 0)
 509           outspec[0] = '%';
 510         else
 511           outspec[0] = '?';
 512         *output_cnt = 1;
 513         return 1;
 514         break;
 515     case '.':
 516     case '~':
 517     case '!':
 518     case '#':
 519     case '&':
 520     case '\'':
 521     case '`':
 522     case '(':
 523     case ')':
 524     case '+':
 525     case '@':
 526     case '{':
 527     case '}':
 528     case ',':
 529     case ';':
 530     case '[':
 531     case ']':
 532     case '%':
 533     case '^':
 534     case '\\':
 535         /* Don't escape again if following character is
 536          * already something we escape.
 537          */
 538         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 539             *outspec = *inspec;
 540             *output_cnt = 1;
 541             return 1;
 542             break;
 543         }
 544         /* But otherwise fall through and escape it. */
 545     case '=':
 546         /* Assume that this is to be escaped */
 547         outspec[0] = '^';
 548         outspec[1] = *inspec;
 549         *output_cnt = 2;
 550         return 1;
 551         break;
 552     case ' ': /* space */
 553         /* Assume that this is to be escaped */
 554         outspec[0] = '^';
 555         outspec[1] = '_';
 556         *output_cnt = 2;
 557         return 1;
 558         break;
 559     default:
 560         *outspec = *inspec;
 561         *output_cnt = 1;
 562         return 1;
 563         break;
 564     }
 565     return 0;
 566 }
 567
 568
 569 /* This handles the expansion of a '^' prefix to the proper character
 570  * in a UNIX file specification.
 571  *
 572  * The output count variable contains the number of characters added
 573  * to the output string.
 574  *
 575  * The return value is the number of characters read from the input
 576  * string
 577  */
 578 static int
 579 copy_expand_vms_filename_escape(char *outspec, const char *inspec, int *output_cnt)
 580 {
 581     int count;
 582     int scnt;
 583
 584     count = 0;
 585     *output_cnt = 0;
 586     if (*inspec == '^') {
 587         inspec++;
 588         switch (*inspec) {
 589         /* Spaces and non-trailing dots should just be passed through,
 590          * but eat the escape character.
 591          */
 592         case '.':
 593             *outspec = *inspec;
 594             count += 2;
 595             (*output_cnt)++;
 596             break;
 597         case '_': /* space */
 598             *outspec = ' ';
 599             count += 2;
 600             (*output_cnt)++;
 601             break;
 602         case '^':
 603             /* Hmm.  Better leave the escape escaped. */
 604             outspec[0] = '^';
 605             outspec[1] = '^';
 606             count += 2;
 607             (*output_cnt) += 2;
 608             break;
 609         case 'U': /* Unicode - FIX-ME this is wrong. */
 610             inspec++;
 611             count++;
 612             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 613             if (scnt == 4) {
 614                 unsigned int c1, c2;
 615                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 616                 outspec[0] = c1 & 0xff;
 617                 outspec[1] = c2 & 0xff;
 618                 if (scnt > 1) {
 619                     (*output_cnt) += 2;
 620                     count += 4;
 621                 }
 622             }
 623             else {
 624                 /* Error - do best we can to continue */
 625                 *outspec = 'U';
 626                 outspec++;
 627                 (*output_cnt++);
 628                 *outspec = *inspec;
 629                 count++;
 630                 (*output_cnt++);
 631             }
 632             break;
 633         default:
 634             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 635             if (scnt == 2) {
 636                 /* Hex encoded */
 637                 unsigned int c1;
 638                 scnt = sscanf(inspec, "%2x", &c1);
 639                 outspec[0] = c1 & 0xff;
 640                 if (scnt > 0) {
 641                     (*output_cnt++);
 642                     count += 2;
 643                 }
 644             }
 645             else {
 646                 *outspec = *inspec;
 647                 count++;
 648                 (*output_cnt++);
 649             }
 650         }
 651     }
 652     else {
 653         *outspec = *inspec;
 654         count++;
 655         (*output_cnt)++;
 656     }
 657     return count;
 658 }
 659
 660 /* vms_split_path - Verify that the input file specification is a
 661  * VMS format file specification, and provide pointers to the components of
 662  * it.  With EFS format filenames, this is virtually the only way to
 663  * parse a VMS path specification into components.
 664  *
 665  * If the sum of the components do not add up to the length of the
 666  * string, then the passed file specification is probably a UNIX style
 667  * path.
 668  */
 669 static int
 670 vms_split_path(const char * path, char * * volume, int * vol_len, char * * root, int * root_len,
 671                char * * dir, int * dir_len, char * * name, int * name_len,
 672                char * * ext, int * ext_len, char * * version, int * ver_len)
 673 {
 674     struct dsc$descriptor path_desc;
 675     int status;
 676     unsigned long flags;
 677     int ret_stat;
 678     struct filescan_itmlst_2 item_list[9];
 679     const int filespec = 0;
 680     const int nodespec = 1;
 681     const int devspec = 2;
 682     const int rootspec = 3;
 683     const int dirspec = 4;
 684     const int namespec = 5;
 685     const int typespec = 6;
 686     const int verspec = 7;
 687
 688     /* Assume the worst for an easy exit */
 689     ret_stat = -1;
 690     *volume = NULL;
 691     *vol_len = 0;
 692     *root = NULL;
 693     *root_len = 0;
 694     *dir = NULL;
 695     *name = NULL;
 696     *name_len = 0;
 697     *ext = NULL;
 698     *ext_len = 0;
 699     *version = NULL;
 700     *ver_len = 0;
 701
 702     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 703     path_desc.dsc$w_length = strlen(path);
 704     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 705     path_desc.dsc$b_class = DSC$K_CLASS_S;
 706
 707     /* Get the total length, if it is shorter than the string passed
 708      * then this was probably not a VMS formatted file specification
 709      */
 710     item_list[filespec].itmcode = FSCN$_FILESPEC;
 711     item_list[filespec].length = 0;
 712     item_list[filespec].component = NULL;
 713
 714     /* If the node is present, then it gets considered as part of the
 715      * volume name to hopefully make things simple.
 716      */
 717     item_list[nodespec].itmcode = FSCN$_NODE;
 718     item_list[nodespec].length = 0;
 719     item_list[nodespec].component = NULL;
 720
 721     item_list[devspec].itmcode = FSCN$_DEVICE;
 722     item_list[devspec].length = 0;
 723     item_list[devspec].component = NULL;
 724
 725     /* root is a special case,  adding it to either the directory or
 726      * the device components will probably complicate things for the
 727      * callers of this routine, so leave it separate.
 728      */
 729     item_list[rootspec].itmcode = FSCN$_ROOT;
 730     item_list[rootspec].length = 0;
 731     item_list[rootspec].component = NULL;
 732
 733     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 734     item_list[dirspec].length = 0;
 735     item_list[dirspec].component = NULL;
 736
 737     item_list[namespec].itmcode = FSCN$_NAME;
 738     item_list[namespec].length = 0;
 739     item_list[namespec].component = NULL;
 740
 741     item_list[typespec].itmcode = FSCN$_TYPE;
 742     item_list[typespec].length = 0;
 743     item_list[typespec].component = NULL;
 744
 745     item_list[verspec].itmcode = FSCN$_VERSION;
 746     item_list[verspec].length = 0;
 747     item_list[verspec].component = NULL;
 748
 749     item_list[8].itmcode = 0;
 750     item_list[8].length = 0;
 751     item_list[8].component = NULL;
 752
 753     status = sys$filescan
 754        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 755         &flags, NULL, NULL);
 756     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 757
 758     /* If we parsed it successfully these two lengths should be the same */
 759     if (path_desc.dsc$w_length != item_list[filespec].length)
 760         return ret_stat;
 761
 762     /* If we got here, then it is a VMS file specification */
 763     ret_stat = 0;
 764
 765     /* set the volume name */
 766     if (item_list[nodespec].length > 0) {
 767         *volume = item_list[nodespec].component;
 768         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 769     }
 770     else {
 771         *volume = item_list[devspec].component;
 772         *vol_len = item_list[devspec].length;
 773     }
 774
 775     *root = item_list[rootspec].component;
 776     *root_len = item_list[rootspec].length;
 777
 778     *dir = item_list[dirspec].component;
 779     *dir_len = item_list[dirspec].length;
 780
 781     /* Now fun with versions and EFS file specifications
 782      * The parser can not tell the difference when a "." is a version
 783      * delimiter or a part of the file specification.
 784      */
 785     if ((decc_efs_charset) &&
 786         (item_list[verspec].length > 0) &&
 787         (item_list[verspec].component[0] == '.')) {
 788         *name = item_list[namespec].component;
 789         *name_len = item_list[namespec].length + item_list[typespec].length;
 790         *ext = item_list[verspec].component;
 791         *ext_len = item_list[verspec].length;
 792         *version = NULL;
 793         *ver_len = 0;
 794     }
 795     else {
 796         *name = item_list[namespec].component;
 797         *name_len = item_list[namespec].length;
 798         *ext = item_list[typespec].component;
 799         *ext_len = item_list[typespec].length;
 800         *version = item_list[verspec].component;
 801         *ver_len = item_list[verspec].length;
 802     }
 803     return ret_stat;
 804 }
 805
 806 /* Routine to determine if the file specification ends with .dir */
 807 static int
 808 is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len)
 809 {
 810
 811     /* e_len must be 4, and version must be <= 2 characters */
 812     if (e_len != 4 || vs_len > 2)
 813         return 0;
 814
 815     /* If a version number is present, it needs to be one */
 816     if ((vs_len == 2) && (vs_spec[1] != '1'))
 817         return 0;
 818
 819     /* Look for the DIR on the extension */
 820     if (vms_process_case_tolerant) {
 821         if ((toupper(e_spec[1]) == 'D') &&
 822             (toupper(e_spec[2]) == 'I') &&
 823             (toupper(e_spec[3]) == 'R')) {
 824             return 1;
 825         }
 826     } else {
 827         /* Directory extensions are supposed to be in upper case only */
 828         /* I would not be surprised if this rule can not be enforced */
 829         /* if and when someone fully debugs the case sensitive mode */
 830         if ((e_spec[1] == 'D') &&
 831             (e_spec[2] == 'I') &&
 832             (e_spec[3] == 'R')) {
 833             return 1;
 834         }
 835     }
 836     return 0;
 837 }
 838
 839
 840 /* my_maxidx
 841  * Routine to retrieve the maximum equivalence index for an input
 842  * logical name.  Some calls to this routine have no knowledge if
 843  * the variable is a logical or not.  So on error we return a max
 844  * index of zero.
 845  */
 846 /*{{{int my_maxidx(const char *lnm) */
 847 static int
 848 my_maxidx(const char *lnm)
 849 {
 850     int status;
 851     int midx;
 852     int attr = LNM$M_CASE_BLIND;
 853     struct dsc$descriptor lnmdsc;
 854     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 855                                 {0, 0, 0, 0}};
 856
 857     lnmdsc.dsc$w_length = strlen(lnm);
 858     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 859     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 860     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 861
 862     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 863     if ((status & 1) == 0)
 864        midx = 0;
 865
 866     return (midx);
 867 }
 868 /*}}}*/
 869
 870 /* Routine to remove the 2-byte prefix from the translation of a
 871  * process-permanent file (PPF).
 872  */
 873 static inline unsigned short int
 874 S_remove_ppf_prefix(const char *lnm, char *eqv, unsigned short int eqvlen)
 875 {
 876     if (*((int *)lnm) == *((int *)"SYS$")                    &&
 877         eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00      &&
 878         ( (lnm[4] == 'O' && !strcmp(lnm,"SYS$OUTPUT"))  ||
 879           (lnm[4] == 'I' && !strcmp(lnm,"SYS$INPUT"))   ||
 880           (lnm[4] == 'E' && !strcmp(lnm,"SYS$ERROR"))   ||
 881           (lnm[4] == 'C' && !strcmp(lnm,"SYS$COMMAND")) )  ) {
 882
 883         memmove(eqv, eqv+4, eqvlen-4);
 884         eqvlen -= 4;
 885     }
 886     return eqvlen;
 887 }
 888
 889 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 890 int
 891 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 892   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 893 {
 894     const char *cp1;
 895     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 896     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 897     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 898     int midx;
 899     unsigned char acmode;
 900     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 901                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 902     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 903                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 904                                  {0, 0, 0, 0}};
 905     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 906 #if defined(PERL_IMPLICIT_CONTEXT)
 907     pTHX = NULL;
 908     if (PL_curinterp) {
 909       aTHX = PERL_GET_INTERP;
 910     } else {
 911       aTHX = NULL;
 912     }
 913 #endif
 914
 915     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 916       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 917     }
 918     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 919       *cp2 = _toupper(*cp1);
 920       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 921         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 922         return 0;
 923       }
 924     }
 925     lnmdsc.dsc$w_length = cp1 - lnm;
 926     lnmdsc.dsc$a_pointer = uplnm;
 927     uplnm[lnmdsc.dsc$w_length] = '\0';
 928     secure = flags & PERL__TRNENV_SECURE;
 929     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 930     if (!tabvec || !*tabvec) tabvec = env_tables;
 931
 932     for (curtab = 0; tabvec[curtab]; curtab++) {
 933       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 934         if (!ivenv && !secure) {
 935           char *eq;
 936           int i;
 937           if (!environ) {
 938             ivenv = 1;
 939 #if defined(PERL_IMPLICIT_CONTEXT)
 940             if (aTHX == NULL) {
 941                 fprintf(stderr,
 942                     "Can't read CRTL environ\n");
 943             } else
 944 #endif
 945                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 946             continue;
 947           }
 948           retsts = SS$_NOLOGNAM;
 949           for (i = 0; environ[i]; i++) {
 950             if ((eq = strchr(environ[i],'=')) &&
 951                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 952                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 953               eq++;
 954               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 955               if (!eqvlen) continue;
 956               retsts = SS$_NORMAL;
 957               break;
 958             }
 959           }
 960           if (retsts != SS$_NOLOGNAM) break;
 961         }
 962       }
 963       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 964                !str$case_blind_compare(&tmpdsc,&clisym)) {
 965         if (!ivsym && !secure) {
 966           unsigned short int deflen = LNM$C_NAMLENGTH;
 967           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 968           /* dynamic dsc to accommodate possible long value */
 969           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 970           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 971           if (retsts & 1) {
 972             if (eqvlen > MAX_DCL_SYMBOL) {
 973               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 974               eqvlen = MAX_DCL_SYMBOL;
 975               /* Special hack--we might be called before the interpreter's */
 976               /* fully initialized, in which case either thr or PL_curcop */
 977               /* might be bogus. We have to check, since ckWARN needs them */
 978               /* both to be valid if running threaded */
 979 #if defined(PERL_IMPLICIT_CONTEXT)
 980               if (aTHX == NULL) {
 981                   fprintf(stderr,
 982                      "Value of CLI symbol \"%s\" too long",lnm);
 983               } else
 984 #endif
 985                 if (ckWARN(WARN_MISC)) {
 986                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 987                 }
 988             }
 989             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 990           }
 991           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
 992           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 993           if (retsts == LIB$_NOSUCHSYM) continue;
 994           break;
 995         }
 996       }
 997       else if (!ivlnm) {
 998         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 999           midx = my_maxidx(lnm);
1000           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1001             lnmlst[1].bufadr = cp2;
1002             eqvlen = 0;
1003             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1004             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1005             if (retsts == SS$_NOLOGNAM) break;
1006             eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
1007             cp2 += eqvlen;
1008             *cp2 = '\0';
1009           }
1010           if ((retsts == SS$_IVLOGNAM) ||
1011               (retsts == SS$_NOLOGNAM)) { continue; }
1012           eqvlen = strlen(eqv);
1013         }
1014         else {
1015           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1016           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1017           if (retsts == SS$_NOLOGNAM) continue;
1018           eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
1019           eqv[eqvlen] = '\0';
1020         }
1021         break;
1022       }
1023     }
1024     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1025     else if (retsts == LIB$_NOSUCHSYM ||
1026              retsts == SS$_NOLOGNAM) {
1027      /* Unsuccessful lookup is normal -- no need to set errno */
1028      return 0;
1029     }
1030     else if (retsts == LIB$_INVSYMNAM ||
1031              retsts == SS$_IVLOGNAM   ||
1032              retsts == SS$_IVLOGTAB) {
1033       set_errno(EINVAL);  set_vaxc_errno(retsts);
1034     }
1035     else _ckvmssts_noperl(retsts);
1036     return 0;
1037 }  /* end of vmstrnenv */
1038 /*}}}*/
1039
1040 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1041 /* Define as a function so we can access statics. */
1042 int
1043 Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1044 {
1045     int flags = 0;
1046
1047 #if defined(PERL_IMPLICIT_CONTEXT)
1048     if (aTHX != NULL)
1049 #endif
1050 #ifdef SECURE_INTERNAL_GETENV
1051         flags = (PL_curinterp ? TAINTING_get : will_taint) ?
1052                  PERL__TRNENV_SECURE : 0;
1053 #endif
1054
1055     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1056 }
1057 /*}}}*/
1058
1059 /* my_getenv
1060  * Note: Uses Perl temp to store result so char * can be returned to
1061  * caller; this pointer will be invalidated at next Perl statement
1062  * transition.
1063  * We define this as a function rather than a macro in terms of my_getenv_len()
1064  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1065  * allocate SVs).
1066  */
1067 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1068 char *
1069 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1070 {
1071     const char *cp1;
1072     static char *__my_getenv_eqv = NULL;
1073     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1074     unsigned long int idx = 0;
1075     int success, secure;
1076     int midx, flags;
1077     SV *tmpsv;
1078
1079     midx = my_maxidx(lnm) + 1;
1080
1081     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1082       /* Set up a temporary buffer for the return value; Perl will
1083        * clean it up at the next statement transition */
1084       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1085       if (!tmpsv) return NULL;
1086       eqv = SvPVX(tmpsv);
1087     }
1088     else {
1089       /* Assume no interpreter ==> single thread */
1090       if (__my_getenv_eqv != NULL) {
1091         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1092       }
1093       else {
1094         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1095       }
1096       eqv = __my_getenv_eqv;
1097     }
1098
1099     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1100     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1101       int len;
1102       getcwd(eqv,LNM$C_NAMLENGTH);
1103
1104       len = strlen(eqv);
1105
1106       /* Get rid of "000000/ in rooted filespecs */
1107       if (len > 7) {
1108         char * zeros;
1109         zeros = strstr(eqv, "/000000/");
1110         if (zeros != NULL) {
1111           int mlen;
1112           mlen = len - (zeros - eqv) - 7;
1113           memmove(zeros, &zeros[7], mlen);
1114           len = len - 7;
1115           eqv[len] = '\0';
1116         }
1117       }
1118       return eqv;
1119     }
1120     else {
1121       /* Impose security constraints only if tainting */
1122       if (sys) {
1123         /* Impose security constraints only if tainting */
1124         secure = PL_curinterp ? TAINTING_get : will_taint;
1125       }
1126       else {
1127         secure = 0;
1128       }
1129
1130       flags =
1131 #ifdef SECURE_INTERNAL_GETENV
1132               secure ? PERL__TRNENV_SECURE : 0
1133 #else
1134               0
1135 #endif
1136       ;
1137
1138       /* For the getenv interface we combine all the equivalence names
1139        * of a search list logical into one value to acquire a maximum
1140        * value length of 255*128 (assuming %ENV is using logicals).
1141        */
1142       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1143
1144       /* If the name contains a semicolon-delimited index, parse it
1145        * off and make sure we only retrieve the equivalence name for
1146        * that index.  */
1147       if ((cp2 = strchr(lnm,';')) != NULL) {
1148         my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1149         idx = strtoul(cp2+1,NULL,0);
1150         lnm = uplnm;
1151         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1152       }
1153
1154       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1155
1156       return success ? eqv : NULL;
1157     }
1158
1159 }  /* end of my_getenv() */
1160 /*}}}*/
1161
1162
1163 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1164 char *
1165 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1166 {
1167     const char *cp1;
1168     char *buf, *cp2;
1169     unsigned long idx = 0;
1170     int midx, flags;
1171     static char *__my_getenv_len_eqv = NULL;
1172     int secure;
1173     SV *tmpsv;
1174
1175     midx = my_maxidx(lnm) + 1;
1176
1177     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1178       /* Set up a temporary buffer for the return value; Perl will
1179        * clean it up at the next statement transition */
1180       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1181       if (!tmpsv) return NULL;
1182       buf = SvPVX(tmpsv);
1183     }
1184     else {
1185       /* Assume no interpreter ==> single thread */
1186       if (__my_getenv_len_eqv != NULL) {
1187         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1188       }
1189       else {
1190         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1191       }
1192       buf = __my_getenv_len_eqv;
1193     }
1194
1195     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1196     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1197     char * zeros;
1198
1199       getcwd(buf,LNM$C_NAMLENGTH);
1200       *len = strlen(buf);
1201
1202       /* Get rid of "000000/ in rooted filespecs */
1203       if (*len > 7) {
1204       zeros = strstr(buf, "/000000/");
1205       if (zeros != NULL) {
1206         int mlen;
1207         mlen = *len - (zeros - buf) - 7;
1208         memmove(zeros, &zeros[7], mlen);
1209         *len = *len - 7;
1210         buf[*len] = '\0';
1211         }
1212       }
1213       return buf;
1214     }
1215     else {
1216       if (sys) {
1217         /* Impose security constraints only if tainting */
1218         secure = PL_curinterp ? TAINTING_get : will_taint;
1219       }
1220       else {
1221         secure = 0;
1222       }
1223
1224       flags =
1225 #ifdef SECURE_INTERNAL_GETENV
1226               secure ? PERL__TRNENV_SECURE : 0
1227 #else
1228               0
1229 #endif
1230       ;
1231
1232       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1233
1234       if ((cp2 = strchr(lnm,';')) != NULL) {
1235         my_strlcpy(buf, lnm, cp2 - lnm + 1);
1236         idx = strtoul(cp2+1,NULL,0);
1237         lnm = buf;
1238         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1239       }
1240
1241       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1242
1243       /* Get rid of "000000/ in rooted filespecs */
1244       if (*len > 7) {
1245         char * zeros;
1246         zeros = strstr(buf, "/000000/");
1247         if (zeros != NULL) {
1248           int mlen;
1249           mlen = *len - (zeros - buf) - 7;
1250           memmove(zeros, &zeros[7], mlen);
1251           *len = *len - 7;
1252           buf[*len] = '\0';
1253         }
1254       }
1255
1256       return *len ? buf : NULL;
1257     }
1258
1259 }  /* end of my_getenv_len() */
1260 /*}}}*/
1261
1262 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1263
1264 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1265
1266 /*{{{ void prime_env_iter() */
1267 void
1268 prime_env_iter(void)
1269 /* Fill the %ENV associative array with all logical names we can
1270  * find, in preparation for iterating over it.
1271  */
1272 {
1273   static int primed = 0;
1274   HV *seenhv = NULL, *envhv;
1275   SV *sv = NULL;
1276   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1277   unsigned short int chan;
1278 #ifndef CLI$M_TRUSTED
1279 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1280 #endif
1281   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1282   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1283   long int i;
1284   bool have_sym = FALSE, have_lnm = FALSE;
1285   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1286   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1287   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1288   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1289   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1290 #if defined(PERL_IMPLICIT_CONTEXT)
1291   pTHX;
1292 #endif
1293 #if defined(USE_ITHREADS)
1294   static perl_mutex primenv_mutex;
1295   MUTEX_INIT(&primenv_mutex);
1296 #endif
1297
1298 #if defined(PERL_IMPLICIT_CONTEXT)
1299     /* We jump through these hoops because we can be called at */
1300     /* platform-specific initialization time, which is before anything is */
1301     /* set up--we can't even do a plain dTHX since that relies on the */
1302     /* interpreter structure to be initialized */
1303     if (PL_curinterp) {
1304       aTHX = PERL_GET_INTERP;
1305     } else {
1306       /* we never get here because the NULL pointer will cause the */
1307       /* several of the routines called by this routine to access violate */
1308
1309       /* This routine is only called by hv.c/hv_iterinit which has a */
1310       /* context, so the real fix may be to pass it through instead of */
1311       /* the hoops above */
1312       aTHX = NULL;
1313     }
1314 #endif
1315
1316   if (primed || !PL_envgv) return;
1317   MUTEX_LOCK(&primenv_mutex);
1318   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1319   envhv = GvHVn(PL_envgv);
1320   /* Perform a dummy fetch as an lval to insure that the hash table is
1321    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1322   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1323
1324   for (i = 0; env_tables[i]; i++) {
1325      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1326          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1327      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1328   }
1329   if (have_sym || have_lnm) {
1330     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1331     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1332     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1333     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1334   }
1335
1336   for (i--; i >= 0; i--) {
1337     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1338       char *start;
1339       int j;
1340       for (j = 0; environ[j]; j++) {
1341         if (!(start = strchr(environ[j],'='))) {
1342           if (ckWARN(WARN_INTERNAL))
1343             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1344         }
1345         else {
1346           start++;
1347           sv = newSVpv(start,0);
1348           SvTAINTED_on(sv);
1349           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1350         }
1351       }
1352       continue;
1353     }
1354     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1355              !str$case_blind_compare(&tmpdsc,&clisym)) {
1356       my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1357       cmddsc.dsc$w_length = 20;
1358       if (env_tables[i]->dsc$w_length == 12 &&
1359           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1360           !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local  *", sizeof(cmd)-12);
1361       flags = defflags | CLI$M_NOLOGNAM;
1362     }
1363     else {
1364       my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1365       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1366         my_strlcat(cmd," /Table=", sizeof(cmd));
1367         cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, sizeof(cmd));
1368       }
1369       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1370       flags = defflags | CLI$M_NOCLISYM;
1371     }
1372
1373     /* Create a new subprocess to execute each command, to exclude the
1374      * remote possibility that someone could subvert a mbx or file used
1375      * to write multiple commands to a single subprocess.
1376      */
1377     do {
1378       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1379                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1380       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1381       defflags &= ~CLI$M_TRUSTED;
1382     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1383     _ckvmssts(retsts);
1384     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1385     if (seenhv) SvREFCNT_dec(seenhv);
1386     seenhv = newHV();
1387     while (1) {
1388       char *cp1, *cp2, *key;
1389       unsigned long int sts, iosb[2], retlen, keylen;
1390       U32 hash;
1391
1392       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1393       if (sts & 1) sts = iosb[0] & 0xffff;
1394       if (sts == SS$_ENDOFFILE) {
1395         int wakect = 0;
1396         while (substs == 0) { sys$hiber(); wakect++;}
1397         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1398         _ckvmssts(substs);
1399         break;
1400       }
1401       _ckvmssts(sts);
1402       retlen = iosb[0] >> 16;
1403       if (!retlen) continue;  /* blank line */
1404       buf[retlen] = '\0';
1405       if (iosb[1] != subpid) {
1406         if (iosb[1]) {
1407           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1408         }
1409         continue;
1410       }
1411       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1412         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1413
1414       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1415       if (*cp1 == '(' || /* Logical name table name */
1416           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1417       if (*cp1 == '"') cp1++;
1418       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1419       key = cp1;  keylen = cp2 - cp1;
1420       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1421       while (*cp2 && *cp2 != '=') cp2++;
1422       while (*cp2 && *cp2 == '=') cp2++;
1423       while (*cp2 && *cp2 == ' ') cp2++;
1424       if (*cp2 == '"') {  /* String translation; may embed "" */
1425         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1426         cp2++;  cp1--; /* Skip "" surrounding translation */
1427       }
1428       else {  /* Numeric translation */
1429         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1430         cp1--;  /* stop on last non-space char */
1431       }
1432       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1433         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1434         continue;
1435       }
1436       PERL_HASH(hash,key,keylen);
1437
1438       if (cp1 == cp2 && *cp2 == '.') {
1439         /* A single dot usually means an unprintable character, such as a null
1440          * to indicate a zero-length value.  Get the actual value to make sure.
1441          */
1442         char lnm[LNM$C_NAMLENGTH+1];
1443         char eqv[MAX_DCL_SYMBOL+1];
1444         int trnlen;
1445         strncpy(lnm, key, keylen);
1446         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1447         sv = newSVpvn(eqv, strlen(eqv));
1448       }
1449       else {
1450         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1451       }
1452
1453       SvTAINTED_on(sv);
1454       hv_store(envhv,key,keylen,sv,hash);
1455       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1456     }
1457     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1458       /* get the PPFs for this process, not the subprocess */
1459       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1460       char eqv[LNM$C_NAMLENGTH+1];
1461       int trnlen, i;
1462       for (i = 0; ppfs[i]; i++) {
1463         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1464         sv = newSVpv(eqv,trnlen);
1465         SvTAINTED_on(sv);
1466         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1467       }
1468     }
1469   }
1470   primed = 1;
1471   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1472   if (buf) Safefree(buf);
1473   if (seenhv) SvREFCNT_dec(seenhv);
1474   MUTEX_UNLOCK(&primenv_mutex);
1475   return;
1476
1477 }  /* end of prime_env_iter */
1478 /*}}}*/
1479
1480
1481 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1482 /* Define or delete an element in the same "environment" as
1483  * vmstrnenv().  If an element is to be deleted, it's removed from
1484  * the first place it's found.  If it's to be set, it's set in the
1485  * place designated by the first element of the table vector.
1486  * Like setenv() returns 0 for success, non-zero on error.
1487  */
1488 int
1489 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1490 {
1491     const char *cp1;
1492     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1493     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1494     int nseg = 0, j;
1495     unsigned long int retsts, usermode = PSL$C_USER;
1496     struct itmlst_3 *ile, *ilist;
1497     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1498                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1499                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1500     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1501     $DESCRIPTOR(local,"_LOCAL");
1502
1503     if (!lnm) {
1504         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1505         return SS$_IVLOGNAM;
1506     }
1507
1508     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1509       *cp2 = _toupper(*cp1);
1510       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1511         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1512         return SS$_IVLOGNAM;
1513       }
1514     }
1515     lnmdsc.dsc$w_length = cp1 - lnm;
1516     if (!tabvec || !*tabvec) tabvec = env_tables;
1517
1518     if (!eqv) {  /* we're deleting n element */
1519       for (curtab = 0; tabvec[curtab]; curtab++) {
1520         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1521         int i;
1522           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1523             if ((cp1 = strchr(environ[i],'=')) &&
1524                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1525                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1526 #ifdef HAS_SETENV
1527               return setenv(lnm,"",1) ? vaxc$errno : 0;
1528             }
1529           }
1530           ivenv = 1; retsts = SS$_NOLOGNAM;
1531 #else
1532               if (ckWARN(WARN_INTERNAL))
1533                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1534               ivenv = 1; retsts = SS$_NOSUCHPGM;
1535               break;
1536             }
1537           }
1538 #endif
1539         }
1540         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1541                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1542           unsigned int symtype;
1543           if (tabvec[curtab]->dsc$w_length == 12 &&
1544               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1545               !str$case_blind_compare(&tmpdsc,&local))
1546             symtype = LIB$K_CLI_LOCAL_SYM;
1547           else symtype = LIB$K_CLI_GLOBAL_SYM;
1548           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1549           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1550           if (retsts == LIB$_NOSUCHSYM) continue;
1551           break;
1552         }
1553         else if (!ivlnm) {
1554           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1555           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1556           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1557           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1558           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1559         }
1560       }
1561     }
1562     else {  /* we're defining a value */
1563       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1564 #ifdef HAS_SETENV
1565         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1566 #else
1567         if (ckWARN(WARN_INTERNAL))
1568           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1569         retsts = SS$_NOSUCHPGM;
1570 #endif
1571       }
1572       else {
1573         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1574         eqvdsc.dsc$w_length  = strlen(eqv);
1575         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1576             !str$case_blind_compare(&tmpdsc,&clisym)) {
1577           unsigned int symtype;
1578           if (tabvec[0]->dsc$w_length == 12 &&
1579               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1580                !str$case_blind_compare(&tmpdsc,&local))
1581             symtype = LIB$K_CLI_LOCAL_SYM;
1582           else symtype = LIB$K_CLI_GLOBAL_SYM;
1583           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1584         }
1585         else {
1586           if (!*eqv) eqvdsc.dsc$w_length = 1;
1587           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1588
1589             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1590             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1591               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1592                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1593               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1594               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1595             }
1596
1597             Newx(ilist,nseg+1,struct itmlst_3);
1598             ile = ilist;
1599             if (!ile) {
1600               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1601               return SS$_INSFMEM;
1602             }
1603             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1604
1605             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1606               ile->itmcode = LNM$_STRING;
1607               ile->bufadr = c;
1608               if ((j+1) == nseg) {
1609                 ile->buflen = strlen(c);
1610                 /* in case we are truncating one that's too long */
1611                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1612               }
1613               else {
1614                 ile->buflen = LNM$C_NAMLENGTH;
1615               }
1616             }
1617
1618             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1619             Safefree (ilist);
1620           }
1621           else {
1622             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1623           }
1624         }
1625       }
1626     }
1627     if (!(retsts & 1)) {
1628       switch (retsts) {
1629         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1630         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1631           set_errno(EVMSERR); break;
1632         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1633         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1634           set_errno(EINVAL); break;
1635         case SS$_NOPRIV:
1636           set_errno(EACCES); break;
1637         default:
1638           _ckvmssts(retsts);
1639           set_errno(EVMSERR);
1640        }
1641        set_vaxc_errno(retsts);
1642        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1643     }
1644     else {
1645       /* We reset error values on success because Perl does an hv_fetch()
1646        * before each hv_store(), and if the thing we're setting didn't
1647        * previously exist, we've got a leftover error message.  (Of course,
1648        * this fails in the face of
1649        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1650        * in that the error reported in $! isn't spurious,
1651        * but it's right more often than not.)
1652        */
1653       set_errno(0); set_vaxc_errno(retsts);
1654       return 0;
1655     }
1656
1657 }  /* end of vmssetenv() */
1658 /*}}}*/
1659
1660 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1661 /* This has to be a function since there's a prototype for it in proto.h */
1662 void
1663 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1664 {
1665     if (lnm && *lnm) {
1666       int len = strlen(lnm);
1667       if  (len == 7) {
1668         char uplnm[8];
1669         int i;
1670         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1671         if (!strcmp(uplnm,"DEFAULT")) {
1672           if (eqv && *eqv) my_chdir(eqv);
1673           return;
1674         }
1675     }
1676   }
1677   (void) vmssetenv(lnm,eqv,NULL);
1678 }
1679 /*}}}*/
1680
1681 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1682 /*  vmssetuserlnm
1683  *  sets a user-mode logical in the process logical name table
1684  *  used for redirection of sys$error
1685  */
1686 void
1687 Perl_vmssetuserlnm(const char *name, const char *eqv)
1688 {
1689     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1690     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1691     unsigned long int iss, attr = LNM$M_CONFINE;
1692     unsigned char acmode = PSL$C_USER;
1693     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1694                                  {0, 0, 0, 0}};
1695     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1696     d_name.dsc$w_length = strlen(name);
1697
1698     lnmlst[0].buflen = strlen(eqv);
1699     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1700
1701     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1702     if (!(iss&1)) lib$signal(iss);
1703 }
1704 /*}}}*/
1705
1706
1707 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1708 /* my_crypt - VMS password hashing
1709  * my_crypt() provides an interface compatible with the Unix crypt()
1710  * C library function, and uses sys$hash_password() to perform VMS
1711  * password hashing.  The quadword hashed password value is returned
1712  * as a NUL-terminated 8 character string.  my_crypt() does not change
1713  * the case of its string arguments; in order to match the behavior
1714  * of LOGINOUT et al., alphabetic characters in both arguments must
1715  *  be upcased by the caller.
1716  *
1717  * - fix me to call ACM services when available
1718  */
1719 char *
1720 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1721 {
1722 #   ifndef UAI$C_PREFERRED_ALGORITHM
1723 #     define UAI$C_PREFERRED_ALGORITHM 127
1724 #   endif
1725     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1726     unsigned short int salt = 0;
1727     unsigned long int sts;
1728     struct const_dsc {
1729         unsigned short int dsc$w_length;
1730         unsigned char      dsc$b_type;
1731         unsigned char      dsc$b_class;
1732         const char *       dsc$a_pointer;
1733     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1734        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1735     struct itmlst_3 uailst[3] = {
1736         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1737         { sizeof salt, UAI$_SALT,    &salt, 0},
1738         { 0,           0,            NULL,  NULL}};
1739     static char hash[9];
1740
1741     usrdsc.dsc$w_length = strlen(usrname);
1742     usrdsc.dsc$a_pointer = usrname;
1743     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1744       switch (sts) {
1745         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1746           set_errno(EACCES);
1747           break;
1748         case RMS$_RNF:
1749           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1750           break;
1751         default:
1752           set_errno(EVMSERR);
1753       }
1754       set_vaxc_errno(sts);
1755       if (sts != RMS$_RNF) return NULL;
1756     }
1757
1758     txtdsc.dsc$w_length = strlen(textpasswd);
1759     txtdsc.dsc$a_pointer = textpasswd;
1760     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1761       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1762     }
1763
1764     return (char *) hash;
1765
1766 }  /* end of my_crypt() */
1767 /*}}}*/
1768
1769
1770 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1771 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1772 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1773
1774 /* 8.3, remove() is now broken on symbolic links */
1775 static int rms_erase(const char * vmsname);
1776
1777
1778 /* mp_do_kill_file
1779  * A little hack to get around a bug in some implementation of remove()
1780  * that do not know how to delete a directory
1781  *
1782  * Delete any file to which user has control access, regardless of whether
1783  * delete access is explicitly allowed.
1784  * Limitations: User must have write access to parent directory.
1785  *              Does not block signals or ASTs; if interrupted in midstream
1786  *              may leave file with an altered ACL.
1787  * HANDLE WITH CARE!
1788  */
1789 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1790 static int
1791 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1792 {
1793     char *vmsname;
1794     char *rslt;
1795     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1796     unsigned long int cxt = 0, aclsts, fndsts;
1797     int rmsts = -1;
1798     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1799     struct myacedef {
1800       unsigned char myace$b_length;
1801       unsigned char myace$b_type;
1802       unsigned short int myace$w_flags;
1803       unsigned long int myace$l_access;
1804       unsigned long int myace$l_ident;
1805     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1806                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1807       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1808      struct itmlst_3
1809        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1810                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1811        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1812        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1813        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1814        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1815
1816     /* Expand the input spec using RMS, since the CRTL remove() and
1817      * system services won't do this by themselves, so we may miss
1818      * a file "hiding" behind a logical name or search list. */
1819     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1820     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1821
1822     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1823     if (rslt == NULL) {
1824         PerlMem_free(vmsname);
1825         return -1;
1826       }
1827
1828     /* Erase the file */
1829     rmsts = rms_erase(vmsname);
1830
1831     /* Did it succeed */
1832     if ($VMS_STATUS_SUCCESS(rmsts)) {
1833         PerlMem_free(vmsname);
1834         return 0;
1835       }
1836
1837     /* If not, can changing protections help? */
1838     if (rmsts != RMS$_PRV) {
1839       set_vaxc_errno(rmsts);
1840       PerlMem_free(vmsname);
1841       return -1;
1842     }
1843
1844     /* No, so we get our own UIC to use as a rights identifier,
1845      * and the insert an ACE at the head of the ACL which allows us
1846      * to delete the file.
1847      */
1848     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1849     fildsc.dsc$w_length = strlen(vmsname);
1850     fildsc.dsc$a_pointer = vmsname;
1851     cxt = 0;
1852     newace.myace$l_ident = oldace.myace$l_ident;
1853     rmsts = -1;
1854     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1855       switch (aclsts) {
1856         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1857           set_errno(ENOENT); break;
1858         case RMS$_DIR:
1859           set_errno(ENOTDIR); break;
1860         case RMS$_DEV:
1861           set_errno(ENODEV); break;
1862         case RMS$_SYN: case SS$_INVFILFOROP:
1863           set_errno(EINVAL); break;
1864         case RMS$_PRV:
1865           set_errno(EACCES); break;
1866         default:
1867           _ckvmssts_noperl(aclsts);
1868       }
1869       set_vaxc_errno(aclsts);
1870       PerlMem_free(vmsname);
1871       return -1;
1872     }
1873     /* Grab any existing ACEs with this identifier in case we fail */
1874     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1875     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1876                     || fndsts == SS$_NOMOREACE ) {
1877       /* Add the new ACE . . . */
1878       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1879         goto yourroom;
1880
1881       rmsts = rms_erase(vmsname);
1882       if ($VMS_STATUS_SUCCESS(rmsts)) {
1883         rmsts = 0;
1884         }
1885         else {
1886         rmsts = -1;
1887         /* We blew it - dir with files in it, no write priv for
1888          * parent directory, etc.  Put things back the way they were. */
1889         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1890           goto yourroom;
1891         if (fndsts & 1) {
1892           addlst[0].bufadr = &oldace;
1893           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1894             goto yourroom;
1895         }
1896       }
1897     }
1898
1899     yourroom:
1900     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1901     /* We just deleted it, so of course it's not there.  Some versions of
1902      * VMS seem to return success on the unlock operation anyhow (after all
1903      * the unlock is successful), but others don't.
1904      */
1905     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1906     if (aclsts & 1) aclsts = fndsts;
1907     if (!(aclsts & 1)) {
1908       set_errno(EVMSERR);
1909       set_vaxc_errno(aclsts);
1910     }
1911
1912     PerlMem_free(vmsname);
1913     return rmsts;
1914
1915 }  /* end of kill_file() */
1916 /*}}}*/
1917
1918
1919 /*{{{int do_rmdir(char *name)*/
1920 int
1921 Perl_do_rmdir(pTHX_ const char *name)
1922 {
1923     char * dirfile;
1924     int retval;
1925     Stat_t st;
1926
1927     /* lstat returns a VMS fileified specification of the name */
1928     /* that is looked up, and also lets verifies that this is a directory */
1929
1930     retval = flex_lstat(name, &st);
1931     if (retval != 0) {
1932         char * ret_spec;
1933
1934         /* Due to a historical feature, flex_stat/lstat can not see some */
1935         /* Unix format file names that the rest of the CRTL can see */
1936         /* Fixing that feature will cause some perl tests to fail */
1937         /* So try this one more time. */
1938
1939         retval = lstat(name, &st.crtl_stat);
1940         if (retval != 0)
1941             return -1;
1942
1943         /* force it to a file spec for the kill file to work. */
1944         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1945         if (ret_spec == NULL) {
1946             errno = EIO;
1947             return -1;
1948         }
1949     }
1950
1951     if (!S_ISDIR(st.st_mode)) {
1952         errno = ENOTDIR;
1953         retval = -1;
1954     }
1955     else {
1956         dirfile = st.st_devnam;
1957
1958         /* It may be possible for flex_stat to find a file and vmsify() to */
1959         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
1960         /* with that case, so fail it */
1961         if (dirfile[0] == 0) {
1962             errno = EIO;
1963             return -1;
1964         }
1965
1966         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1967     }
1968
1969     return retval;
1970
1971 }  /* end of do_rmdir */
1972 /*}}}*/
1973
1974 /* kill_file
1975  * Delete any file to which user has control access, regardless of whether
1976  * delete access is explicitly allowed.
1977  * Limitations: User must have write access to parent directory.
1978  *              Does not block signals or ASTs; if interrupted in midstream
1979  *              may leave file with an altered ACL.
1980  * HANDLE WITH CARE!
1981  */
1982 /*{{{int kill_file(char *name)*/
1983 int
1984 Perl_kill_file(pTHX_ const char *name)
1985 {
1986     char * vmsfile;
1987     Stat_t st;
1988     int rmsts;
1989
1990     /* Convert the filename to VMS format and see if it is a directory */
1991     /* flex_lstat returns a vmsified file specification */
1992     rmsts = flex_lstat(name, &st);
1993     if (rmsts != 0) {
1994
1995         /* Due to a historical feature, flex_stat/lstat can not see some */
1996         /* Unix format file names that the rest of the CRTL can see when */
1997         /* ODS-2 file specifications are in use. */
1998         /* Fixing that feature will cause some perl tests to fail */
1999         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2000         st.st_mode = 0;
2001         vmsfile = (char *) name; /* cast ok */
2002
2003     } else {
2004         vmsfile = st.st_devnam;
2005         if (vmsfile[0] == 0) {
2006             /* It may be possible for flex_stat to find a file and vmsify() */
2007             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2008             /* deal with that case, so fail it */
2009             errno = EIO;
2010             return -1;
2011         }
2012     }
2013
2014     /* Remove() is allowed to delete directories, according to the X/Open
2015      * specifications.
2016      * This may need special handling to work with the ACL hacks.
2017      */
2018     if (S_ISDIR(st.st_mode)) {
2019         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2020         return rmsts;
2021     }
2022
2023     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2024
2025     /* Need to delete all versions ? */
2026     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2027         int i = 0;
2028
2029         /* Just use lstat() here as do not need st_dev */
2030         /* and we know that the file is in VMS format or that */
2031         /* because of a historical bug, flex_stat can not see the file */
2032         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2033             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2034             if (rmsts != 0)
2035                 break;
2036             i++;
2037
2038             /* Make sure that we do not loop forever */
2039             if (i > 32767) {
2040                 errno = EIO;
2041                 rmsts = -1;
2042                 break;
2043             }
2044         }
2045     }
2046
2047     return rmsts;
2048
2049 }  /* end of kill_file() */
2050 /*}}}*/
2051
2052
2053 /*{{{int my_mkdir(char *,Mode_t)*/
2054 int
2055 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2056 {
2057   STRLEN dirlen = strlen(dir);
2058
2059   /* zero length string sometimes gives ACCVIO */
2060   if (dirlen == 0) return -1;
2061
2062   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2063    * null file name/type.  However, it's commonplace under Unix,
2064    * so we'll allow it for a gain in portability.
2065    */
2066   if (dir[dirlen-1] == '/') {
2067     char *newdir = savepvn(dir,dirlen-1);
2068     int ret = mkdir(newdir,mode);
2069     Safefree(newdir);
2070     return ret;
2071   }
2072   else return mkdir(dir,mode);
2073 }  /* end of my_mkdir */
2074 /*}}}*/
2075
2076 /*{{{int my_chdir(char *)*/
2077 int
2078 Perl_my_chdir(pTHX_ const char *dir)
2079 {
2080   STRLEN dirlen = strlen(dir);
2081   const char *dir1 = dir;
2082
2083   /* zero length string sometimes gives ACCVIO */
2084   if (dirlen == 0) {
2085     SETERRNO(EINVAL, SS$_BADPARAM);
2086     return -1;
2087   }
2088
2089   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2090    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2091    * so that existing scripts do not need to be changed.
2092    */
2093   while ((dirlen > 0) && (*dir1 == ' ')) {
2094     dir1++;
2095     dirlen--;
2096   }
2097
2098   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2099    * that implies
2100    * null file name/type.  However, it's commonplace under Unix,
2101    * so we'll allow it for a gain in portability.
2102    *
2103    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2104    */
2105   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2106       char *newdir;
2107       int ret;
2108       newdir = (char *)PerlMem_malloc(dirlen);
2109       if (newdir ==NULL)
2110           _ckvmssts_noperl(SS$_INSFMEM);
2111       memcpy(newdir, dir1, dirlen-1);
2112       newdir[dirlen-1] = '\0';
2113       ret = chdir(newdir);
2114       PerlMem_free(newdir);
2115       return ret;
2116   }
2117   else return chdir(dir1);
2118 }  /* end of my_chdir */
2119 /*}}}*/
2120
2121
2122 /*{{{int my_chmod(char *, mode_t)*/
2123 int
2124 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2125 {
2126   Stat_t st;
2127   int ret = -1;
2128   char * changefile;
2129   STRLEN speclen = strlen(file_spec);
2130
2131   /* zero length string sometimes gives ACCVIO */
2132   if (speclen == 0) return -1;
2133
2134   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2135    * that implies null file name/type.  However, it's commonplace under Unix,
2136    * so we'll allow it for a gain in portability.
2137    *
2138    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2139    * in VMS file.dir notation.
2140    */
2141   changefile = (char *) file_spec; /* cast ok */
2142   ret = flex_lstat(file_spec, &st);
2143   if (ret != 0) {
2144
2145         /* Due to a historical feature, flex_stat/lstat can not see some */
2146         /* Unix format file names that the rest of the CRTL can see when */
2147         /* ODS-2 file specifications are in use. */
2148         /* Fixing that feature will cause some perl tests to fail */
2149         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2150         st.st_mode = 0;
2151
2152   } else {
2153       /* It may be possible to get here with nothing in st_devname */
2154       /* chmod still may work though */
2155       if (st.st_devnam[0] != 0) {
2156           changefile = st.st_devnam;
2157       }
2158   }
2159   ret = chmod(changefile, mode);
2160   return ret;
2161 }  /* end of my_chmod */
2162 /*}}}*/
2163
2164
2165 /*{{{FILE *my_tmpfile()*/
2166 FILE *
2167 my_tmpfile(void)
2168 {
2169   FILE *fp;
2170   char *cp;
2171
2172   if ((fp = tmpfile())) return fp;
2173
2174   cp = (char *)PerlMem_malloc(L_tmpnam+24);
2175   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2176
2177   if (decc_filename_unix_only == 0)
2178     strcpy(cp,"Sys$Scratch:");
2179   else
2180     strcpy(cp,"/tmp/");
2181   tmpnam(cp+strlen(cp));
2182   strcat(cp,".Perltmp");
2183   fp = fopen(cp,"w+","fop=dlt");
2184   PerlMem_free(cp);
2185   return fp;
2186 }
2187 /*}}}*/
2188
2189
2190 /*
2191  * The C RTL's sigaction fails to check for invalid signal numbers so we
2192  * help it out a bit.  The docs are correct, but the actual routine doesn't
2193  * do what the docs say it will.
2194  */
2195 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2196 int
2197 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2198                    struct sigaction* oact)
2199 {
2200   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2201         SETERRNO(EINVAL, SS$_INVARG);
2202         return -1;
2203   }
2204   return sigaction(sig, act, oact);
2205 }
2206 /*}}}*/
2207
2208 #ifdef KILL_BY_SIGPRC
2209 #include <errnodef.h>
2210
2211 /* We implement our own kill() using the undocumented system service
2212    sys$sigprc for one of two reasons:
2213
2214    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2215    target process to do a sys$exit, which usually can't be handled
2216    gracefully...certainly not by Perl and the %SIG{} mechanism.
2217
2218    2.) If the kill() in the CRTL can't be called from a signal
2219    handler without disappearing into the ether, i.e., the signal
2220    it purportedly sends is never trapped. Still true as of VMS 7.3.
2221
2222    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2223    in the target process rather than calling sys$exit.
2224
2225    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2226    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2227    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2228    with condition codes C$_SIG0+nsig*8, catching the exception on the
2229    target process and resignaling with appropriate arguments.
2230
2231    But we don't have that VMS 7.0+ exception handler, so if you
2232    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2233
2234    Also note that SIGTERM is listed in the docs as being "unimplemented",
2235    yet always seems to be signaled with a VMS condition code of 4 (and
2236    correctly handled for that code).  So we hardwire it in.
2237
2238    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2239    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2240    than signalling with an unrecognized (and unhandled by CRTL) code.
2241 */
2242
2243 #define _MY_SIG_MAX 28
2244
2245 static unsigned int
2246 Perl_sig_to_vmscondition_int(int sig)
2247 {
2248     static unsigned int sig_code[_MY_SIG_MAX+1] =
2249     {
2250         0,                  /*  0 ZERO     */
2251         SS$_HANGUP,         /*  1 SIGHUP   */
2252         SS$_CONTROLC,       /*  2 SIGINT   */
2253         SS$_CONTROLY,       /*  3 SIGQUIT  */
2254         SS$_RADRMOD,        /*  4 SIGILL   */
2255         SS$_BREAK,          /*  5 SIGTRAP  */
2256         SS$_OPCCUS,         /*  6 SIGABRT  */
2257         SS$_COMPAT,         /*  7 SIGEMT   */
2258 #ifdef __VAX
2259         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2260 #else
2261         SS$_HPARITH,        /*  8 SIGFPE AXP */
2262 #endif
2263         SS$_ABORT,          /*  9 SIGKILL  */
2264         SS$_ACCVIO,         /* 10 SIGBUS   */
2265         SS$_ACCVIO,         /* 11 SIGSEGV  */
2266         SS$_BADPARAM,       /* 12 SIGSYS   */
2267         SS$_NOMBX,          /* 13 SIGPIPE  */
2268         SS$_ASTFLT,         /* 14 SIGALRM  */
2269         4,                  /* 15 SIGTERM  */
2270         0,                  /* 16 SIGUSR1  */
2271         0,                  /* 17 SIGUSR2  */
2272         0,                  /* 18 */
2273         0,                  /* 19 */
2274         0,                  /* 20 SIGCHLD  */
2275         0,                  /* 21 SIGCONT  */
2276         0,                  /* 22 SIGSTOP  */
2277         0,                  /* 23 SIGTSTP  */
2278         0,                  /* 24 SIGTTIN  */
2279         0,                  /* 25 SIGTTOU  */
2280         0,                  /* 26 */
2281         0,                  /* 27 */
2282         0                   /* 28 SIGWINCH  */
2283     };
2284
2285     static int initted = 0;
2286     if (!initted) {
2287         initted = 1;
2288         sig_code[16] = C$_SIGUSR1;
2289         sig_code[17] = C$_SIGUSR2;
2290         sig_code[20] = C$_SIGCHLD;
2291 #if __CRTL_VER >= 70300000
2292         sig_code[28] = C$_SIGWINCH;
2293 #endif
2294     }
2295
2296     if (sig < _SIG_MIN) return 0;
2297     if (sig > _MY_SIG_MAX) return 0;
2298     return sig_code[sig];
2299 }
2300
2301 unsigned int
2302 Perl_sig_to_vmscondition(int sig)
2303 {
2304 #ifdef SS$_DEBUG
2305     if (vms_debug_on_exception != 0)
2306         lib$signal(SS$_DEBUG);
2307 #endif
2308     return Perl_sig_to_vmscondition_int(sig);
2309 }
2310
2311
2312 #define sys$sigprc SYS$SIGPRC
2313 #ifdef __cplusplus
2314 extern "C" {
2315 #endif
2316 int sys$sigprc(unsigned int *pidadr,
2317                struct dsc$descriptor_s *prcname,
2318                unsigned int code);
2319 #ifdef __cplusplus
2320 }
2321 #endif
2322
2323 int
2324 Perl_my_kill(int pid, int sig)
2325 {
2326     int iss;
2327     unsigned int code;
2328
2329      /* sig 0 means validate the PID */
2330     /*------------------------------*/
2331     if (sig == 0) {
2332         const unsigned long int jpicode = JPI$_PID;
2333         pid_t ret_pid;
2334         int status;
2335         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2336         if ($VMS_STATUS_SUCCESS(status))
2337            return 0;
2338         switch (status) {
2339         case SS$_NOSUCHNODE:
2340         case SS$_UNREACHABLE:
2341         case SS$_NONEXPR:
2342            errno = ESRCH;
2343            break;
2344         case SS$_NOPRIV:
2345            errno = EPERM;
2346            break;
2347         default:
2348            errno = EVMSERR;
2349         }
2350         vaxc$errno=status;
2351         return -1;
2352     }
2353
2354     code = Perl_sig_to_vmscondition_int(sig);
2355
2356     if (!code) {
2357         SETERRNO(EINVAL, SS$_BADPARAM);
2358         return -1;
2359     }
2360
2361     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2362      * signals are to be sent to multiple processes.
2363      *  pid = 0 - all processes in group except ones that the system exempts
2364      *  pid = -1 - all processes except ones that the system exempts
2365      *  pid = -n - all processes in group (abs(n)) except ...
2366      * For now, just report as not supported.
2367      */
2368
2369     if (pid <= 0) {
2370         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2371         return -1;
2372     }
2373
2374     iss = sys$sigprc((unsigned int *)&pid,0,code);
2375     if (iss&1) return 0;
2376
2377     switch (iss) {
2378       case SS$_NOPRIV:
2379         set_errno(EPERM);  break;
2380       case SS$_NONEXPR:
2381       case SS$_NOSUCHNODE:
2382       case SS$_UNREACHABLE:
2383         set_errno(ESRCH);  break;
2384       case SS$_INSFMEM:
2385         set_errno(ENOMEM); break;
2386       default:
2387         _ckvmssts_noperl(iss);
2388         set_errno(EVMSERR);
2389     }
2390     set_vaxc_errno(iss);
2391
2392     return -1;
2393 }
2394 #endif
2395
2396 /* Routine to convert a VMS status code to a UNIX status code.
2397 ** More tricky than it appears because of conflicting conventions with
2398 ** existing code.
2399 **
2400 ** VMS status codes are a bit mask, with the least significant bit set for
2401 ** success.
2402 **
2403 ** Special UNIX status of EVMSERR indicates that no translation is currently
2404 ** available, and programs should check the VMS status code.
2405 **
2406 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2407 ** decoding.
2408 */
2409
2410 #ifndef C_FACILITY_NO
2411 #define C_FACILITY_NO 0x350000
2412 #endif
2413 #ifndef DCL_IVVERB
2414 #define DCL_IVVERB 0x38090
2415 #endif
2416
2417 int
2418 Perl_vms_status_to_unix(int vms_status, int child_flag)
2419 {
2420   int facility;
2421   int fac_sp;
2422   int msg_no;
2423   int msg_status;
2424   int unix_status;
2425
2426   /* Assume the best or the worst */
2427   if (vms_status & STS$M_SUCCESS)
2428     unix_status = 0;
2429   else
2430     unix_status = EVMSERR;
2431
2432   msg_status = vms_status & ~STS$M_CONTROL;
2433
2434   facility = vms_status & STS$M_FAC_NO;
2435   fac_sp = vms_status & STS$M_FAC_SP;
2436   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2437
2438   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2439     switch(msg_no) {
2440     case SS$_NORMAL:
2441         unix_status = 0;
2442         break;
2443     case SS$_ACCVIO:
2444         unix_status = EFAULT;
2445         break;
2446     case SS$_DEVOFFLINE:
2447         unix_status = EBUSY;
2448         break;
2449     case SS$_CLEARED:
2450         unix_status = ENOTCONN;
2451         break;
2452     case SS$_IVCHAN:
2453     case SS$_IVLOGNAM:
2454     case SS$_BADPARAM:
2455     case SS$_IVLOGTAB:
2456     case SS$_NOLOGNAM:
2457     case SS$_NOLOGTAB:
2458     case SS$_INVFILFOROP:
2459     case SS$_INVARG:
2460     case SS$_NOSUCHID:
2461     case SS$_IVIDENT:
2462         unix_status = EINVAL;
2463         break;
2464     case SS$_UNSUPPORTED:
2465         unix_status = ENOTSUP;
2466         break;
2467     case SS$_FILACCERR:
2468     case SS$_NOGRPPRV:
2469     case SS$_NOSYSPRV:
2470         unix_status = EACCES;
2471         break;
2472     case SS$_DEVICEFULL:
2473         unix_status = ENOSPC;
2474         break;
2475     case SS$_NOSUCHDEV:
2476         unix_status = ENODEV;
2477         break;
2478     case SS$_NOSUCHFILE:
2479     case SS$_NOSUCHOBJECT:
2480         unix_status = ENOENT;
2481         break;
2482     case SS$_ABORT:                                 /* Fatal case */
2483     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2484     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2485         unix_status = EINTR;
2486         break;
2487     case SS$_BUFFEROVF:
2488         unix_status = E2BIG;
2489         break;
2490     case SS$_INSFMEM:
2491         unix_status = ENOMEM;
2492         break;
2493     case SS$_NOPRIV:
2494         unix_status = EPERM;
2495         break;
2496     case SS$_NOSUCHNODE:
2497     case SS$_UNREACHABLE:
2498         unix_status = ESRCH;
2499         break;
2500     case SS$_NONEXPR:
2501         unix_status = ECHILD;
2502         break;
2503     default:
2504         if ((facility == 0) && (msg_no < 8)) {
2505           /* These are not real VMS status codes so assume that they are
2506           ** already UNIX status codes
2507           */
2508           unix_status = msg_no;
2509           break;
2510         }
2511     }
2512   }
2513   else {
2514     /* Translate a POSIX exit code to a UNIX exit code */
2515     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2516         unix_status = (msg_no & 0x07F8) >> 3;
2517     }
2518     else {
2519
2520          /* Documented traditional behavior for handling VMS child exits */
2521         /*--------------------------------------------------------------*/
2522         if (child_flag != 0) {
2523
2524              /* Success / Informational return 0 */
2525             /*----------------------------------*/
2526             if (msg_no & STS$K_SUCCESS)
2527                 return 0;
2528
2529              /* Warning returns 1 */
2530             /*-------------------*/
2531             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2532                 return 1;
2533
2534              /* Everything else pass through the severity bits */
2535             /*------------------------------------------------*/
2536             return (msg_no & STS$M_SEVERITY);
2537         }
2538
2539          /* Normal VMS status to ERRNO mapping attempt */
2540         /*--------------------------------------------*/
2541         switch(msg_status) {
2542         /* case RMS$_EOF: */ /* End of File */
2543         case RMS$_FNF:  /* File Not Found */
2544         case RMS$_DNF:  /* Dir Not Found */
2545                 unix_status = ENOENT;
2546                 break;
2547         case RMS$_RNF:  /* Record Not Found */
2548                 unix_status = ESRCH;
2549                 break;
2550         case RMS$_DIR:
2551                 unix_status = ENOTDIR;
2552                 break;
2553         case RMS$_DEV:
2554                 unix_status = ENODEV;
2555                 break;
2556         case RMS$_IFI:
2557         case RMS$_FAC:
2558         case RMS$_ISI:
2559                 unix_status = EBADF;
2560                 break;
2561         case RMS$_FEX:
2562                 unix_status = EEXIST;
2563                 break;
2564         case RMS$_SYN:
2565         case RMS$_FNM:
2566         case LIB$_INVSTRDES:
2567         case LIB$_INVARG:
2568         case LIB$_NOSUCHSYM:
2569         case LIB$_INVSYMNAM:
2570         case DCL_IVVERB:
2571                 unix_status = EINVAL;
2572                 break;
2573         case CLI$_BUFOVF:
2574         case RMS$_RTB:
2575         case CLI$_TKNOVF:
2576         case CLI$_RSLOVF:
2577                 unix_status = E2BIG;
2578                 break;
2579         case RMS$_PRV:  /* No privilege */
2580         case RMS$_ACC:  /* ACP file access failed */
2581         case RMS$_WLK:  /* Device write locked */
2582                 unix_status = EACCES;
2583                 break;
2584         case RMS$_MKD:  /* Failed to mark for delete */
2585                 unix_status = EPERM;
2586                 break;
2587         /* case RMS$_NMF: */  /* No more files */
2588         }
2589     }
2590   }
2591
2592   return unix_status;
2593 }
2594
2595 /* Try to guess at what VMS error status should go with a UNIX errno
2596  * value.  This is hard to do as there could be many possible VMS
2597  * error statuses that caused the errno value to be set.
2598  */
2599
2600 int
2601 Perl_unix_status_to_vms(int unix_status)
2602 {
2603     int test_unix_status;
2604
2605      /* Trivial cases first */
2606     /*---------------------*/
2607     if (unix_status == EVMSERR)
2608         return vaxc$errno;
2609
2610      /* Is vaxc$errno sane? */
2611     /*---------------------*/
2612     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2613     if (test_unix_status == unix_status)
2614         return vaxc$errno;
2615
2616      /* If way out of range, must be VMS code already */
2617     /*-----------------------------------------------*/
2618     if (unix_status > EVMSERR)
2619         return unix_status;
2620
2621      /* If out of range, punt */
2622     /*-----------------------*/
2623     if (unix_status > __ERRNO_MAX)
2624         return SS$_ABORT;
2625
2626
2627      /* Ok, now we have to do it the hard way. */
2628     /*----------------------------------------*/
2629     switch(unix_status) {
2630     case 0:     return SS$_NORMAL;
2631     case EPERM: return SS$_NOPRIV;
2632     case ENOENT: return SS$_NOSUCHOBJECT;
2633     case ESRCH: return SS$_UNREACHABLE;
2634     case EINTR: return SS$_ABORT;
2635     /* case EIO: */
2636     /* case ENXIO:  */
2637     case E2BIG: return SS$_BUFFEROVF;
2638     /* case ENOEXEC */
2639     case EBADF: return RMS$_IFI;
2640     case ECHILD: return SS$_NONEXPR;
2641     /* case EAGAIN */
2642     case ENOMEM: return SS$_INSFMEM;
2643     case EACCES: return SS$_FILACCERR;
2644     case EFAULT: return SS$_ACCVIO;
2645     /* case ENOTBLK */
2646     case EBUSY: return SS$_DEVOFFLINE;
2647     case EEXIST: return RMS$_FEX;
2648     /* case EXDEV */
2649     case ENODEV: return SS$_NOSUCHDEV;
2650     case ENOTDIR: return RMS$_DIR;
2651     /* case EISDIR */
2652     case EINVAL: return SS$_INVARG;
2653     /* case ENFILE */
2654     /* case EMFILE */
2655     /* case ENOTTY */
2656     /* case ETXTBSY */
2657     /* case EFBIG */
2658     case ENOSPC: return SS$_DEVICEFULL;
2659     case ESPIPE: return LIB$_INVARG;
2660     /* case EROFS: */
2661     /* case EMLINK: */
2662     /* case EPIPE: */
2663     /* case EDOM */
2664     case ERANGE: return LIB$_INVARG;
2665     /* case EWOULDBLOCK */
2666     /* case EINPROGRESS */
2667     /* case EALREADY */
2668     /* case ENOTSOCK */
2669     /* case EDESTADDRREQ */
2670     /* case EMSGSIZE */
2671     /* case EPROTOTYPE */
2672     /* case ENOPROTOOPT */
2673     /* case EPROTONOSUPPORT */
2674     /* case ESOCKTNOSUPPORT */
2675     /* case EOPNOTSUPP */
2676     /* case EPFNOSUPPORT */
2677     /* case EAFNOSUPPORT */
2678     /* case EADDRINUSE */
2679     /* case EADDRNOTAVAIL */
2680     /* case ENETDOWN */
2681     /* case ENETUNREACH */
2682     /* case ENETRESET */
2683     /* case ECONNABORTED */
2684     /* case ECONNRESET */
2685     /* case ENOBUFS */
2686     /* case EISCONN */
2687     case ENOTCONN: return SS$_CLEARED;
2688     /* case ESHUTDOWN */
2689     /* case ETOOMANYREFS */
2690     /* case ETIMEDOUT */
2691     /* case ECONNREFUSED */
2692     /* case ELOOP */
2693     /* case ENAMETOOLONG */
2694     /* case EHOSTDOWN */
2695     /* case EHOSTUNREACH */
2696     /* case ENOTEMPTY */
2697     /* case EPROCLIM */
2698     /* case EUSERS  */
2699     /* case EDQUOT  */
2700     /* case ENOMSG  */
2701     /* case EIDRM */
2702     /* case EALIGN */
2703     /* case ESTALE */
2704     /* case EREMOTE */
2705     /* case ENOLCK */
2706     /* case ENOSYS */
2707     /* case EFTYPE */
2708     /* case ECANCELED */
2709     /* case EFAIL */
2710     /* case EINPROG */
2711     case ENOTSUP:
2712         return SS$_UNSUPPORTED;
2713     /* case EDEADLK */
2714     /* case ENWAIT */
2715     /* case EILSEQ */
2716     /* case EBADCAT */
2717     /* case EBADMSG */
2718     /* case EABANDONED */
2719     default:
2720         return SS$_ABORT; /* punt */
2721     }
2722 }
2723
2724
2725 /* default piping mailbox size */
2726 #ifdef __VAX
2727 #  define PERL_BUFSIZ        512
2728 #else
2729 #  define PERL_BUFSIZ        8192
2730 #endif
2731
2732
2733 static void
2734 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2735 {
2736   unsigned long int mbxbufsiz;
2737   static unsigned long int syssize = 0;
2738   unsigned long int dviitm = DVI$_DEVNAM;
2739   char csize[LNM$C_NAMLENGTH+1];
2740   int sts;
2741
2742   if (!syssize) {
2743     unsigned long syiitm = SYI$_MAXBUF;
2744     /*
2745      * Get the SYSGEN parameter MAXBUF
2746      *
2747      * If the logical 'PERL_MBX_SIZE' is defined
2748      * use the value of the logical instead of PERL_BUFSIZ, but
2749      * keep the size between 128 and MAXBUF.
2750      *
2751      */
2752     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2753   }
2754
2755   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2756       mbxbufsiz = atoi(csize);
2757   } else {
2758       mbxbufsiz = PERL_BUFSIZ;
2759   }
2760   if (mbxbufsiz < 128) mbxbufsiz = 128;
2761   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2762
2763   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2764
2765   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2766   _ckvmssts_noperl(sts);
2767   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2768
2769 }  /* end of create_mbx() */
2770
2771
2772 /*{{{  my_popen and my_pclose*/
2773
2774 typedef struct _iosb           IOSB;
2775 typedef struct _iosb*         pIOSB;
2776 typedef struct _pipe           Pipe;
2777 typedef struct _pipe*         pPipe;
2778 typedef struct pipe_details    Info;
2779 typedef struct pipe_details*  pInfo;
2780 typedef struct _srqp            RQE;
2781 typedef struct _srqp*          pRQE;
2782 typedef struct _tochildbuf      CBuf;
2783 typedef struct _tochildbuf*    pCBuf;
2784
2785 struct _iosb {
2786     unsigned short status;
2787     unsigned short count;
2788     unsigned long  dvispec;
2789 };
2790
2791 #pragma member_alignment save
2792 #pragma nomember_alignment quadword
2793 struct _srqp {          /* VMS self-relative queue entry */
2794     unsigned long qptr[2];
2795 };
2796 #pragma member_alignment restore
2797 static RQE  RQE_ZERO = {0,0};
2798
2799 struct _tochildbuf {
2800     RQE             q;
2801     int             eof;
2802     unsigned short  size;
2803     char            *buf;
2804 };
2805
2806 struct _pipe {
2807     RQE            free;
2808     RQE            wait;
2809     int            fd_out;
2810     unsigned short chan_in;
2811     unsigned short chan_out;
2812     char          *buf;
2813     unsigned int   bufsize;
2814     IOSB           iosb;
2815     IOSB           iosb2;
2816     int           *pipe_done;
2817     int            retry;
2818     int            type;
2819     int            shut_on_empty;
2820     int            need_wake;
2821     pPipe         *home;
2822     pInfo          info;
2823     pCBuf          curr;
2824     pCBuf          curr2;
2825 #if defined(PERL_IMPLICIT_CONTEXT)
2826     void            *thx;           /* Either a thread or an interpreter */
2827                                     /* pointer, depending on how we're built */
2828 #endif
2829 };
2830
2831
2832 struct pipe_details
2833 {
2834     pInfo           next;
2835     PerlIO *fp;  /* file pointer to pipe mailbox */
2836     int useFILE; /* using stdio, not perlio */
2837     int pid;   /* PID of subprocess */
2838     int mode;  /* == 'r' if pipe open for reading */
2839     int done;  /* subprocess has completed */
2840     int waiting; /* waiting for completion/closure */
2841     int             closing;        /* my_pclose is closing this pipe */
2842     unsigned long   completion;     /* termination status of subprocess */
2843     pPipe           in;             /* pipe in to sub */
2844     pPipe           out;            /* pipe out of sub */
2845     pPipe           err;            /* pipe of sub's sys$error */
2846     int             in_done;        /* true when in pipe finished */
2847     int             out_done;
2848     int             err_done;
2849     unsigned short  xchan;          /* channel to debug xterm */
2850     unsigned short  xchan_valid;    /* channel is assigned */
2851 };
2852
2853 struct exit_control_block
2854 {
2855     struct exit_control_block *flink;
2856     unsigned long int (*exit_routine)(void);
2857     unsigned long int arg_count;
2858     unsigned long int *status_address;
2859     unsigned long int exit_status;
2860 };
2861
2862 typedef struct _closed_pipes    Xpipe;
2863 typedef struct _closed_pipes*  pXpipe;
2864
2865 struct _closed_pipes {
2866     int             pid;            /* PID of subprocess */
2867     unsigned long   completion;     /* termination status of subprocess */
2868 };
2869 #define NKEEPCLOSED 50
2870 static Xpipe closed_list[NKEEPCLOSED];
2871 static int   closed_index = 0;
2872 static int   closed_num = 0;
2873
2874 #define RETRY_DELAY     "0 ::0.20"
2875 #define MAX_RETRY              50
2876
2877 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2878 static unsigned long mypid;
2879 static unsigned long delaytime[2];
2880
2881 static pInfo open_pipes = NULL;
2882 static $DESCRIPTOR(nl_desc, "NL:");
2883
2884 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2885
2886
2887
2888 static unsigned long int
2889 pipe_exit_routine(void)
2890 {
2891     pInfo info;
2892     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2893     int sts, did_stuff, j;
2894
2895    /*
2896     * Flush any pending i/o, but since we are in process run-down, be
2897     * careful about referencing PerlIO structures that may already have
2898     * been deallocated.  We may not even have an interpreter anymore.
2899     */
2900     info = open_pipes;
2901     while (info) {
2902         if (info->fp) {
2903 #if defined(PERL_IMPLICIT_CONTEXT)
2904            /* We need to use the Perl context of the thread that created */
2905            /* the pipe. */
2906            pTHX;
2907            if (info->err)
2908                aTHX = info->err->thx;
2909            else if (info->out)
2910                aTHX = info->out->thx;
2911            else if (info->in)
2912                aTHX = info->in->thx;
2913 #endif
2914            if (!info->useFILE
2915 #if defined(USE_ITHREADS)
2916              && my_perl
2917 #endif
2918 #ifdef USE_PERLIO
2919              && PL_perlio_fd_refcnt
2920 #endif
2921               )
2922                PerlIO_flush(info->fp);
2923            else
2924                fflush((FILE *)info->fp);
2925         }
2926         info = info->next;
2927     }
2928
2929     /*
2930      next we try sending an EOF...ignore if doesn't work, make sure we
2931      don't hang
2932     */
2933     did_stuff = 0;
2934     info = open_pipes;
2935
2936     while (info) {
2937       _ckvmssts_noperl(sys$setast(0));
2938       if (info->in && !info->in->shut_on_empty) {
2939         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2940                                  0, 0, 0, 0, 0, 0));
2941         info->waiting = 1;
2942         did_stuff = 1;
2943       }
2944       _ckvmssts_noperl(sys$setast(1));
2945       info = info->next;
2946     }
2947
2948     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2949
2950     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2951         int nwait = 0;
2952
2953         info = open_pipes;
2954         while (info) {
2955           _ckvmssts_noperl(sys$setast(0));
2956           if (info->waiting && info->done)
2957                 info->waiting = 0;
2958           nwait += info->waiting;
2959           _ckvmssts_noperl(sys$setast(1));
2960           info = info->next;
2961         }
2962         if (!nwait) break;
2963         sleep(1);
2964     }
2965
2966     did_stuff = 0;
2967     info = open_pipes;
2968     while (info) {
2969       _ckvmssts_noperl(sys$setast(0));
2970       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2971         sts = sys$forcex(&info->pid,0,&abort);
2972         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2973         did_stuff = 1;
2974       }
2975       _ckvmssts_noperl(sys$setast(1));
2976       info = info->next;
2977     }
2978
2979     /* again, wait for effect */
2980
2981     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2982         int nwait = 0;
2983
2984         info = open_pipes;
2985         while (info) {
2986           _ckvmssts_noperl(sys$setast(0));
2987           if (info->waiting && info->done)
2988                 info->waiting = 0;
2989           nwait += info->waiting;
2990           _ckvmssts_noperl(sys$setast(1));
2991           info = info->next;
2992         }
2993         if (!nwait) break;
2994         sleep(1);
2995     }
2996
2997     info = open_pipes;
2998     while (info) {
2999       _ckvmssts_noperl(sys$setast(0));
3000       if (!info->done) {  /* We tried to be nice . . . */
3001         sts = sys$delprc(&info->pid,0);
3002         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3003         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3004       }
3005       _ckvmssts_noperl(sys$setast(1));
3006       info = info->next;
3007     }
3008
3009     while(open_pipes) {
3010
3011 #if defined(PERL_IMPLICIT_CONTEXT)
3012       /* We need to use the Perl context of the thread that created */
3013       /* the pipe. */
3014       pTHX;
3015       if (open_pipes->err)
3016           aTHX = open_pipes->err->thx;
3017       else if (open_pipes->out)
3018           aTHX = open_pipes->out->thx;
3019       else if (open_pipes->in)
3020           aTHX = open_pipes->in->thx;
3021 #endif
3022       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3023       else if (!(sts & 1)) retsts = sts;
3024     }
3025     return retsts;
3026 }
3027
3028 static struct exit_control_block pipe_exitblock =
3029        {(struct exit_control_block *) 0,
3030         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3031
3032 static void pipe_mbxtofd_ast(pPipe p);
3033 static void pipe_tochild1_ast(pPipe p);
3034 static void pipe_tochild2_ast(pPipe p);
3035
3036 static void
3037 popen_completion_ast(pInfo info)
3038 {
3039   pInfo i = open_pipes;
3040   int iss;
3041
3042   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3043   closed_list[closed_index].pid = info->pid;
3044   closed_list[closed_index].completion = info->completion;
3045   closed_index++;
3046   if (closed_index == NKEEPCLOSED)
3047     closed_index = 0;
3048   closed_num++;
3049
3050   while (i) {
3051     if (i == info) break;
3052     i = i->next;
3053   }
3054   if (!i) return;       /* unlinked, probably freed too */
3055
3056   info->done = TRUE;
3057
3058 /*
3059     Writing to subprocess ...
3060             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3061
3062             chan_out may be waiting for "done" flag, or hung waiting
3063             for i/o completion to child...cancel the i/o.  This will
3064             put it into "snarf mode" (done but no EOF yet) that discards
3065             input.
3066
3067     Output from subprocess (stdout, stderr) needs to be flushed and
3068     shut down.   We try sending an EOF, but if the mbx is full the pipe
3069     routine should still catch the "shut_on_empty" flag, telling it to
3070     use immediate-style reads so that "mbx empty" -> EOF.
3071
3072
3073 */
3074   if (info->in && !info->in_done) {               /* only for mode=w */
3075         if (info->in->shut_on_empty && info->in->need_wake) {
3076             info->in->need_wake = FALSE;
3077             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3078         } else {
3079             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3080         }
3081   }
3082
3083   if (info->out && !info->out_done) {             /* were we also piping output? */
3084       info->out->shut_on_empty = TRUE;
3085       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3086       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3087       _ckvmssts_noperl(iss);
3088   }
3089
3090   if (info->err && !info->err_done) {        /* we were piping stderr */
3091         info->err->shut_on_empty = TRUE;
3092         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3093         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3094         _ckvmssts_noperl(iss);
3095   }
3096   _ckvmssts_noperl(sys$setef(pipe_ef));
3097
3098 }
3099
3100 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3101 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3102 static void pipe_infromchild_ast(pPipe p);
3103
3104 /*
3105     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3106     inside an AST routine without worrying about reentrancy and which Perl
3107     memory allocator is being used.
3108
3109     We read data and queue up the buffers, then spit them out one at a
3110     time to the output mailbox when the output mailbox is ready for one.
3111
3112 */
3113 #define INITIAL_TOCHILDQUEUE  2
3114
3115 static pPipe
3116 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3117 {
3118     pPipe p;
3119     pCBuf b;
3120     char mbx1[64], mbx2[64];
3121     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3122                                       DSC$K_CLASS_S, mbx1},
3123                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3124                                       DSC$K_CLASS_S, mbx2};
3125     unsigned int dviitm = DVI$_DEVBUFSIZ;
3126     int j, n;
3127
3128     n = sizeof(Pipe);
3129     _ckvmssts_noperl(lib$get_vm(&n, &p));
3130
3131     create_mbx(&p->chan_in , &d_mbx1);
3132     create_mbx(&p->chan_out, &d_mbx2);
3133     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3134
3135     p->buf           = 0;
3136     p->shut_on_empty = FALSE;
3137     p->need_wake     = FALSE;
3138     p->type          = 0;
3139     p->retry         = 0;
3140     p->iosb.status   = SS$_NORMAL;
3141     p->iosb2.status  = SS$_NORMAL;
3142     p->free          = RQE_ZERO;
3143     p->wait          = RQE_ZERO;
3144     p->curr          = 0;
3145     p->curr2         = 0;
3146     p->info          = 0;
3147 #ifdef PERL_IMPLICIT_CONTEXT
3148     p->thx           = aTHX;
3149 #endif
3150
3151     n = sizeof(CBuf) + p->bufsize;
3152
3153     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3154         _ckvmssts_noperl(lib$get_vm(&n, &b));
3155         b->buf = (char *) b + sizeof(CBuf);
3156         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3157     }
3158
3159     pipe_tochild2_ast(p);
3160     pipe_tochild1_ast(p);
3161     strcpy(wmbx, mbx1);
3162     strcpy(rmbx, mbx2);
3163     return p;
3164 }
3165
3166 /*  reads the MBX Perl is writing, and queues */
3167
3168 static void
3169 pipe_tochild1_ast(pPipe p)
3170 {
3171     pCBuf b = p->curr;
3172     int iss = p->iosb.status;
3173     int eof = (iss == SS$_ENDOFFILE);
3174     int sts;
3175 #ifdef PERL_IMPLICIT_CONTEXT
3176     pTHX = p->thx;
3177 #endif
3178
3179     if (p->retry) {
3180         if (eof) {
3181             p->shut_on_empty = TRUE;
3182             b->eof     = TRUE;
3183             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3184         } else  {
3185             _ckvmssts_noperl(iss);
3186         }
3187
3188         b->eof  = eof;
3189         b->size = p->iosb.count;
3190         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3191         if (p->need_wake) {
3192             p->need_wake = FALSE;
3193             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3194         }
3195     } else {
3196         p->retry = 1;   /* initial call */
3197     }
3198
3199     if (eof) {                  /* flush the free queue, return when done */
3200         int n = sizeof(CBuf) + p->bufsize;
3201         while (1) {
3202             iss = lib$remqti(&p->free, &b);
3203             if (iss == LIB$_QUEWASEMP) return;
3204             _ckvmssts_noperl(iss);
3205             _ckvmssts_noperl(lib$free_vm(&n, &b));
3206         }
3207     }
3208
3209     iss = lib$remqti(&p->free, &b);
3210     if (iss == LIB$_QUEWASEMP) {
3211         int n = sizeof(CBuf) + p->bufsize;
3212         _ckvmssts_noperl(lib$get_vm(&n, &b));
3213         b->buf = (char *) b + sizeof(CBuf);
3214     } else {
3215        _ckvmssts_noperl(iss);
3216     }
3217
3218     p->curr = b;
3219     iss = sys$qio(0,p->chan_in,
3220              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3221              &p->iosb,
3222              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3223     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3224     _ckvmssts_noperl(iss);
3225 }
3226
3227
3228 /* writes queued buffers to output, waits for each to complete before
3229    doing the next */
3230
3231 static void
3232 pipe_tochild2_ast(pPipe p)
3233 {
3234     pCBuf b = p->curr2;
3235     int iss = p->iosb2.status;
3236     int n = sizeof(CBuf) + p->bufsize;
3237     int done = (p->info && p->info->done) ||
3238               iss == SS$_CANCEL || iss == SS$_ABORT;
3239 #if defined(PERL_IMPLICIT_CONTEXT)
3240     pTHX = p->thx;
3241 #endif
3242
3243     do {
3244         if (p->type) {         /* type=1 has old buffer, dispose */
3245             if (p->shut_on_empty) {
3246                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3247             } else {
3248                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3249             }
3250             p->type = 0;
3251         }
3252
3253         iss = lib$remqti(&p->wait, &b);
3254         if (iss == LIB$_QUEWASEMP) {
3255             if (p->shut_on_empty) {
3256                 if (done) {
3257                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3258                     *p->pipe_done = TRUE;
3259                     _ckvmssts_noperl(sys$setef(pipe_ef));
3260                 } else {
3261                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3262                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3263                 }
3264                 return;
3265             }
3266             p->need_wake = TRUE;
3267             return;
3268         }
3269         _ckvmssts_noperl(iss);
3270         p->type = 1;
3271     } while (done);
3272
3273
3274     p->curr2 = b;
3275     if (b->eof) {
3276         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3277             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3278     } else {
3279         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3280             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3281     }
3282
3283     return;
3284
3285 }
3286
3287
3288 static pPipe
3289 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3290 {
3291     pPipe p;
3292     char mbx1[64], mbx2[64];
3293     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3294                                       DSC$K_CLASS_S, mbx1},
3295                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3296                                       DSC$K_CLASS_S, mbx2};
3297     unsigned int dviitm = DVI$_DEVBUFSIZ;
3298
3299     int n = sizeof(Pipe);
3300     _ckvmssts_noperl(lib$get_vm(&n, &p));
3301     create_mbx(&p->chan_in , &d_mbx1);
3302     create_mbx(&p->chan_out, &d_mbx2);
3303
3304     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3305     n = p->bufsize * sizeof(char);
3306     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3307     p->shut_on_empty = FALSE;
3308     p->info   = 0;
3309     p->type   = 0;
3310     p->iosb.status = SS$_NORMAL;
3311 #if defined(PERL_IMPLICIT_CONTEXT)
3312     p->thx = aTHX;
3313 #endif
3314     pipe_infromchild_ast(p);
3315
3316     strcpy(wmbx, mbx1);
3317     strcpy(rmbx, mbx2);
3318     return p;
3319 }
3320
3321 static void
3322 pipe_infromchild_ast(pPipe p)
3323 {
3324     int iss = p->iosb.status;
3325     int eof = (iss == SS$_ENDOFFILE);
3326     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3327     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3328 #if defined(PERL_IMPLICIT_CONTEXT)
3329     pTHX = p->thx;
3330 #endif
3331
3332     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3333         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3334         p->chan_out = 0;
3335     }
3336
3337     /* read completed:
3338             input shutdown if EOF from self (done or shut_on_empty)
3339             output shutdown if closing flag set (my_pclose)
3340             send data/eof from child or eof from self
3341             otherwise, re-read (snarf of data from child)
3342     */
3343
3344     if (p->type == 1) {
3345         p->type = 0;
3346         if (myeof && p->chan_in) {                  /* input shutdown */
3347             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3348             p->chan_in = 0;
3349         }
3350
3351         if (p->chan_out) {
3352             if (myeof || kideof) {      /* pass EOF to parent */
3353                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3354                                          pipe_infromchild_ast, p,
3355                                          0, 0, 0, 0, 0, 0));
3356                 return;
3357             } else if (eof) {       /* eat EOF --- fall through to read*/
3358
3359             } else {                /* transmit data */
3360                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3361                                          pipe_infromchild_ast,p,
3362                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3363                 return;
3364             }
3365         }
3366     }
3367
3368     /*  everything shut? flag as done */
3369
3370     if (!p->chan_in && !p->chan_out) {
3371         *p->pipe_done = TRUE;
3372         _ckvmssts_noperl(sys$setef(pipe_ef));
3373         return;
3374     }
3375
3376     /* write completed (or read, if snarfing from child)
3377             if still have input active,
3378                queue read...immediate mode if shut_on_empty so we get EOF if empty
3379             otherwise,
3380                check if Perl reading, generate EOFs as needed
3381     */
3382
3383     if (p->type == 0) {
3384         p->type = 1;
3385         if (p->chan_in) {
3386             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3387                           pipe_infromchild_ast,p,
3388                           p->buf, p->bufsize, 0, 0, 0, 0);
3389             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3390             _ckvmssts_noperl(iss);
3391         } else {           /* send EOFs for extra reads */
3392             p->iosb.status = SS$_ENDOFFILE;
3393             p->iosb.dvispec = 0;
3394             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3395                                      0, 0, 0,
3396                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3397         }
3398     }
3399 }
3400
3401 static pPipe
3402 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3403 {
3404     pPipe p;
3405     char mbx[64];
3406     unsigned long dviitm = DVI$_DEVBUFSIZ;
3407     struct stat s;
3408     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3409                                       DSC$K_CLASS_S, mbx};
3410     int n = sizeof(Pipe);
3411
3412     /* things like terminals and mbx's don't need this filter */
3413     if (fd && fstat(fd,&s) == 0) {
3414         unsigned long devchar;
3415         char device[65];
3416         unsigned short dev_len;
3417         struct dsc$descriptor_s d_dev;
3418         char * cptr;
3419         struct item_list_3 items[3];
3420         int status;
3421         unsigned short dvi_iosb[4];
3422
3423         cptr = getname(fd, out, 1);
3424         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3425         d_dev.dsc$a_pointer = out;
3426         d_dev.dsc$w_length = strlen(out);
3427         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3428         d_dev.dsc$b_class = DSC$K_CLASS_S;
3429
3430         items[0].len = 4;
3431         items[0].code = DVI$_DEVCHAR;
3432         items[0].bufadr = &devchar;
3433         items[0].retadr = NULL;
3434         items[1].len = 64;
3435         items[1].code = DVI$_FULLDEVNAM;
3436         items[1].bufadr = device;
3437         items[1].retadr = &dev_len;
3438         items[2].len = 0;
3439         items[2].code = 0;
3440
3441         status = sys$getdviw
3442                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3443         _ckvmssts_noperl(status);
3444         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3445             device[dev_len] = 0;
3446
3447             if (!(devchar & DEV$M_DIR)) {
3448                 strcpy(out, device);
3449                 return 0;
3450             }
3451         }
3452     }
3453
3454     _ckvmssts_noperl(lib$get_vm(&n, &p));
3455     p->fd_out = dup(fd);
3456     create_mbx(&p->chan_in, &d_mbx);
3457     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3458     n = (p->bufsize+1) * sizeof(char);
3459     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3460     p->shut_on_empty = FALSE;
3461     p->retry = 0;
3462     p->info  = 0;
3463     strcpy(out, mbx);
3464
3465     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3466                              pipe_mbxtofd_ast, p,
3467                              p->buf, p->bufsize, 0, 0, 0, 0));
3468
3469     return p;
3470 }
3471
3472 static void
3473 pipe_mbxtofd_ast(pPipe p)
3474 {
3475     int iss = p->iosb.status;
3476     int done = p->info->done;
3477     int iss2;
3478     int eof = (iss == SS$_ENDOFFILE);
3479     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3480     int err = !(iss&1) && !eof;
3481 #if defined(PERL_IMPLICIT_CONTEXT)
3482     pTHX = p->thx;
3483 #endif
3484
3485     if (done && myeof) {               /* end piping */
3486         close(p->fd_out);
3487         sys$dassgn(p->chan_in);
3488         *p->pipe_done = TRUE;
3489         _ckvmssts_noperl(sys$setef(pipe_ef));
3490         return;
3491     }
3492
3493     if (!err && !eof) {             /* good data to send to file */
3494         p->buf[p->iosb.count] = '\n';
3495         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3496         if (iss2 < 0) {
3497             p->retry++;
3498             if (p->retry < MAX_RETRY) {
3499                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3500                 return;
3501             }
3502         }
3503         p->retry = 0;
3504     } else if (err) {
3505         _ckvmssts_noperl(iss);
3506     }
3507
3508
3509     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3510           pipe_mbxtofd_ast, p,
3511           p->buf, p->bufsize, 0, 0, 0, 0);
3512     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3513     _ckvmssts_noperl(iss);
3514 }
3515
3516
3517 typedef struct _pipeloc     PLOC;
3518 typedef struct _pipeloc*   pPLOC;
3519
3520 struct _pipeloc {
3521     pPLOC   next;
3522     char    dir[NAM$C_MAXRSS+1];
3523 };
3524 static pPLOC  head_PLOC = 0;
3525
3526 void
3527 free_pipelocs(pTHX_ void *head)
3528 {
3529     pPLOC p, pnext;
3530     pPLOC *pHead = (pPLOC *)head;
3531
3532     p = *pHead;
3533     while (p) {
3534         pnext = p->next;
3535         PerlMem_free(p);
3536         p = pnext;
3537     }
3538     *pHead = 0;
3539 }
3540
3541 static void
3542 store_pipelocs(pTHX)
3543 {
3544     int    i;
3545     pPLOC  p;
3546     AV    *av = 0;
3547     SV    *dirsv;
3548     char  *dir, *x;
3549     char  *unixdir;
3550     char  temp[NAM$C_MAXRSS+1];
3551     STRLEN n_a;
3552
3553     if (head_PLOC)
3554         free_pipelocs(aTHX_ &head_PLOC);
3555
3556 /*  the . directory from @INC comes last */
3557
3558     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3559     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3560     p->next = head_PLOC;
3561     head_PLOC = p;
3562     strcpy(p->dir,"./");
3563
3564 /*  get the directory from $^X */
3565
3566     unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3567     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3568
3569 #ifdef PERL_IMPLICIT_CONTEXT
3570     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3571 #else
3572     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3573 #endif
3574         my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3575         x = strrchr(temp,']');
3576         if (x == NULL) {
3577         x = strrchr(temp,'>');
3578           if (x == NULL) {
3579             /* It could be a UNIX path */
3580             x = strrchr(temp,'/');
3581           }
3582         }
3583         if (x)
3584           x[1] = '\0';
3585         else {
3586           /* Got a bare name, so use default directory */
3587           temp[0] = '.';
3588           temp[1] = '\0';
3589         }
3590
3591         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3592             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3593             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3594             p->next = head_PLOC;
3595             head_PLOC = p;
3596             my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3597         }
3598     }
3599
3600 /*  reverse order of @INC entries, skip "." since entered above */
3601
3602 #ifdef PERL_IMPLICIT_CONTEXT
3603     if (aTHX)
3604 #endif
3605     if (PL_incgv) av = GvAVn(PL_incgv);
3606
3607     for (i = 0; av && i <= AvFILL(av); i++) {
3608         dirsv = *av_fetch(av,i,TRUE);
3609
3610         if (SvROK(dirsv)) continue;
3611         dir = SvPVx(dirsv,n_a);
3612         if (strcmp(dir,".") == 0) continue;
3613         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3614             continue;
3615
3616         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3617         p->next = head_PLOC;
3618         head_PLOC = p;
3619         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3620     }
3621
3622 /* most likely spot (ARCHLIB) put first in the list */
3623
3624 #ifdef ARCHLIB_EXP
3625     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3626         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3627         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3628         p->next = head_PLOC;
3629         head_PLOC = p;
3630         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3631     }
3632 #endif
3633     PerlMem_free(unixdir);
3634 }
3635
3636 static I32 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective,
3637                                   const char *fname, int opts);
3638 #if !defined(PERL_IMPLICIT_CONTEXT)
3639 #define cando_by_name_int               Perl_cando_by_name_int
3640 #else
3641 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3642 #endif
3643
3644 static char *
3645 find_vmspipe(pTHX)
3646 {
3647     static int   vmspipe_file_status = 0;
3648     static char  vmspipe_file[NAM$C_MAXRSS+1];
3649
3650     /* already found? Check and use ... need read+execute permission */
3651
3652     if (vmspipe_file_status == 1) {
3653         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3654          && cando_by_name_int
3655            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3656             return vmspipe_file;
3657         }
3658         vmspipe_file_status = 0;
3659     }
3660
3661     /* scan through stored @INC, $^X */
3662
3663     if (vmspipe_file_status == 0) {
3664         char file[NAM$C_MAXRSS+1];
3665         pPLOC  p = head_PLOC;
3666
3667         while (p) {
3668             char * exp_res;
3669             int dirlen;
3670             dirlen = my_strlcpy(file, p->dir, sizeof(file));
3671             my_strlcat(file, "vmspipe.com", sizeof(file));
3672             p = p->next;
3673
3674             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3675             if (!exp_res) continue;
3676
3677             if (cando_by_name_int
3678                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3679              && cando_by_name_int
3680                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3681                 vmspipe_file_status = 1;
3682                 return vmspipe_file;
3683             }
3684         }
3685         vmspipe_file_status = -1;   /* failed, use tempfiles */
3686     }
3687
3688     return 0;
3689 }
3690
3691 static FILE *
3692 vmspipe_tempfile(pTHX)
3693 {
3694     char file[NAM$C_MAXRSS+1];
3695     FILE *fp;
3696     static int index = 0;
3697     Stat_t s0, s1;
3698     int cmp_result;
3699
3700     /* create a tempfile */
3701
3702     /* we can't go from   W, shr=get to  R, shr=get without
3703        an intermediate vulnerable state, so don't bother trying...
3704
3705        and lib$spawn doesn't shr=put, so have to close the write
3706
3707        So... match up the creation date/time and the FID to
3708        make sure we're dealing with the same file
3709
3710     */
3711
3712     index++;
3713     if (!decc_filename_unix_only) {
3714       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3715       fp = fopen(file,"w");
3716       if (!fp) {
3717         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3718         fp = fopen(file,"w");
3719         if (!fp) {
3720             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3721             fp = fopen(file,"w");
3722         }
3723       }
3724      }
3725      else {
3726       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3727       fp = fopen(file,"w");
3728       if (!fp) {
3729         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3730         fp = fopen(file,"w");
3731         if (!fp) {
3732           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3733           fp = fopen(file,"w");
3734         }
3735       }
3736     }
3737     if (!fp) return 0;  /* we're hosed */
3738
3739     fprintf(fp,"$! 'f$verify(0)'\n");
3740     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3741     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3742     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3743     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3744     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3745     fprintf(fp,"$ perl_del    = \"delete\"\n");
3746     fprintf(fp,"$ pif         = \"if\"\n");
3747     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3748     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3749     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3750     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3751     fprintf(fp,"$!  --- build command line to get max possible length\n");
3752     fprintf(fp,"$c=perl_popen_cmd0\n");
3753     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3754     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3755     fprintf(fp,"$x=perl_popen_cmd3\n");
3756     fprintf(fp,"$c=c+x\n");
3757     fprintf(fp,"$ perl_on\n");
3758     fprintf(fp,"$ 'c'\n");
3759     fprintf(fp,"$ perl_status = $STATUS\n");
3760     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3761     fprintf(fp,"$ perl_exit 'perl_status'\n");
3762     fsync(fileno(fp));
3763
3764     fgetname(fp, file, 1);
3765     fstat(fileno(fp), &s0.crtl_stat);
3766     fclose(fp);
3767
3768     if (decc_filename_unix_only)
3769         int_tounixspec(file, file, NULL);
3770     fp = fopen(file,"r","shr=get");
3771     if (!fp) return 0;
3772     fstat(fileno(fp), &s1.crtl_stat);
3773
3774     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3775     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3776         fclose(fp);
3777         return 0;
3778     }
3779
3780     return fp;
3781 }
3782
3783
3784 static int
3785 vms_is_syscommand_xterm(void)
3786 {
3787     const static struct dsc$descriptor_s syscommand_dsc =
3788       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3789
3790     const static struct dsc$descriptor_s decwdisplay_dsc =
3791       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3792
3793     struct item_list_3 items[2];
3794     unsigned short dvi_iosb[4];
3795     unsigned long devchar;
3796     unsigned long devclass;
3797     int status;
3798
3799     /* Very simple check to guess if sys$command is a decterm? */
3800     /* First see if the DECW$DISPLAY: device exists */
3801     items[0].len = 4;
3802     items[0].code = DVI$_DEVCHAR;
3803     items[0].bufadr = &devchar;
3804     items[0].retadr = NULL;
3805     items[1].len = 0;
3806     items[1].code = 0;
3807
3808     status = sys$getdviw
3809         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3810
3811     if ($VMS_STATUS_SUCCESS(status)) {
3812         status = dvi_iosb[0];
3813     }
3814
3815     if (!$VMS_STATUS_SUCCESS(status)) {
3816         SETERRNO(EVMSERR, status);
3817         return -1;
3818     }
3819
3820     /* If it does, then for now assume that we are on a workstation */
3821     /* Now verify that SYS$COMMAND is a terminal */
3822     /* for creating the debugger DECTerm */
3823
3824     items[0].len = 4;
3825     items[0].code = DVI$_DEVCLASS;
3826     items[0].bufadr = &devclass;
3827     items[0].retadr = NULL;
3828     items[1].len = 0;
3829     items[1].code = 0;
3830
3831     status = sys$getdviw
3832         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3833
3834     if ($VMS_STATUS_SUCCESS(status)) {
3835         status = dvi_iosb[0];
3836     }
3837
3838     if (!$VMS_STATUS_SUCCESS(status)) {
3839         SETERRNO(EVMSERR, status);
3840         return -1;
3841     }
3842     else {
3843         if (devclass == DC$_TERM) {
3844             return 0;
3845         }
3846     }
3847     return -1;
3848 }
3849
3850 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3851 static PerlIO*
3852 create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3853 {
3854     int status;
3855     int ret_stat;
3856     char * ret_char;
3857     char device_name[65];
3858     unsigned short device_name_len;
3859     struct dsc$descriptor_s customization_dsc;
3860     struct dsc$descriptor_s device_name_dsc;
3861     const char * cptr;
3862     char customization[200];
3863     char title[40];
3864     pInfo info = NULL;
3865     char mbx1[64];
3866     unsigned short p_chan;
3867     int n;
3868     unsigned short iosb[4];
3869     const char * cust_str =
3870         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3871     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3872                                           DSC$K_CLASS_S, mbx1};
3873
3874      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3875     /*---------------------------------------*/
3876     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3877
3878
3879     /* Make sure that this is from the Perl debugger */
3880     ret_char = strstr(cmd," xterm ");
3881     if (ret_char == NULL)
3882         return NULL;
3883     cptr = ret_char + 7;
3884     ret_char = strstr(cmd,"tty");
3885     if (ret_char == NULL)
3886         return NULL;
3887     ret_char = strstr(cmd,"sleep");
3888     if (ret_char == NULL)
3889         return NULL;
3890
3891     if (decw_term_port == 0) {
3892         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3893         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3894         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3895
3896        status = lib$find_image_symbol
3897                                (&filename1_dsc,
3898                                 &decw_term_port_dsc,
3899                                 (void *)&decw_term_port,
3900                                 NULL,
3901                                 0);
3902
3903         /* Try again with the other image name */
3904         if (!$VMS_STATUS_SUCCESS(status)) {
3905
3906            status = lib$find_image_symbol
3907                                (&filename2_dsc,
3908                                 &decw_term_port_dsc,
3909                                 (void *)&decw_term_port,
3910                                 NULL,
3911                                 0);
3912
3913         }
3914
3915     }
3916
3917
3918     /* No decw$term_port, give it up */
3919     if (!$VMS_STATUS_SUCCESS(status))
3920         return NULL;
3921
3922     /* Are we on a workstation? */
3923     /* to do: capture the rows / columns and pass their properties */
3924     ret_stat = vms_is_syscommand_xterm();
3925     if (ret_stat < 0)
3926         return NULL;
3927
3928     /* Make the title: */
3929     ret_char = strstr(cptr,"-title");
3930     if (ret_char != NULL) {
3931         while ((*cptr != 0) && (*cptr != '\"')) {
3932             cptr++;
3933         }
3934         if (*cptr == '\"')
3935             cptr++;
3936         n = 0;
3937         while ((*cptr != 0) && (*cptr != '\"')) {
3938             title[n] = *cptr;
3939             n++;
3940             if (n == 39) {
3941                 title[39] = 0;
3942                 break;
3943             }
3944             cptr++;
3945         }
3946         title[n] = 0;
3947     }
3948     else {
3949             /* Default title */
3950             strcpy(title,"Perl Debug DECTerm");
3951     }
3952     sprintf(customization, cust_str, title);
3953
3954     customization_dsc.dsc$a_pointer = customization;
3955     customization_dsc.dsc$w_length = strlen(customization);
3956     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3957     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3958
3959     device_name_dsc.dsc$a_pointer = device_name;
3960     device_name_dsc.dsc$w_length = sizeof device_name -1;
3961     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3962     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3963
3964     device_name_len = 0;
3965
3966     /* Try to create the window */
3967      status = (*decw_term_port)
3968        (NULL,
3969         NULL,
3970         &customization_dsc,
3971         &device_name_dsc,
3972         &device_name_len,
3973         NULL,
3974         NULL,
3975         NULL);
3976     if (!$VMS_STATUS_SUCCESS(status)) {
3977         SETERRNO(EVMSERR, status);
3978         return NULL;
3979     }
3980
3981     device_name[device_name_len] = '\0';
3982
3983     /* Need to set this up to look like a pipe for cleanup */
3984     n = sizeof(Info);
3985     status = lib$get_vm(&n, &info);
3986     if (!$VMS_STATUS_SUCCESS(status)) {
3987         SETERRNO(ENOMEM, status);
3988         return NULL;
3989     }
3990
3991     info->mode = *mode;
3992     info->done = FALSE;
3993     info->completion = 0;
3994     info->closing    = FALSE;
3995     info->in         = 0;
3996     info->out        = 0;
3997     info->err        = 0;
3998     info->fp         = NULL;
3999     info->useFILE    = 0;
4000     info->waiting    = 0;
4001     info->in_done    = TRUE;
4002     info->out_done   = TRUE;
4003     info->err_done   = TRUE;
4004
4005     /* Assign a channel on this so that it will persist, and not login */
4006     /* We stash this channel in the info structure for reference. */
4007     /* The created xterm self destructs when the last channel is removed */
4008     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4009     /* So leave this assigned. */
4010     device_name_dsc.dsc$w_length = device_name_len;
4011     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4012     if (!$VMS_STATUS_SUCCESS(status)) {
4013         SETERRNO(EVMSERR, status);
4014         return NULL;
4015     }
4016     info->xchan_valid = 1;
4017
4018     /* Now create a mailbox to be read by the application */
4019
4020     create_mbx(&p_chan, &d_mbx1);
4021
4022     /* write the name of the created terminal to the mailbox */
4023     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4024             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4025
4026     if (!$VMS_STATUS_SUCCESS(status)) {
4027         SETERRNO(EVMSERR, status);
4028         return NULL;
4029     }
4030
4031     info->fp  = PerlIO_open(mbx1, mode);
4032
4033     /* Done with this channel */
4034     sys$dassgn(p_chan);
4035
4036     /* If any errors, then clean up */
4037     if (!info->fp) {
4038         n = sizeof(Info);
4039         _ckvmssts_noperl(lib$free_vm(&n, &info));
4040         return NULL;
4041         }
4042
4043     /* All done */
4044     return info->fp;
4045 }
4046
4047 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4048
4049 static PerlIO *
4050 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4051 {
4052     static int handler_set_up = FALSE;
4053     PerlIO * ret_fp;
4054     unsigned long int sts, flags = CLI$M_NOWAIT;
4055     /* The use of a GLOBAL table (as was done previously) rendered
4056      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4057      * environment.  Hence we've switched to LOCAL symbol table.
4058      */
4059     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4060     int j, wait = 0, n;
4061     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4062     char *in, *out, *err, mbx[512];
4063     FILE *tpipe = 0;
4064     char tfilebuf[NAM$C_MAXRSS+1];
4065     pInfo info = NULL;
4066     char cmd_sym_name[20];
4067     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4068                                       DSC$K_CLASS_S, symbol};
4069     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4070                                       DSC$K_CLASS_S, 0};
4071     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4072                                       DSC$K_CLASS_S, cmd_sym_name};
4073     struct dsc$descriptor_s *vmscmd;
4074     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4075     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4076     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4077
4078     /* Check here for Xterm create request.  This means looking for
4079      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4080      *  is possible to create an xterm.
4081      */
4082     if (*in_mode == 'r') {
4083         PerlIO * xterm_fd;
4084
4085 #if defined(PERL_IMPLICIT_CONTEXT)
4086         /* Can not fork an xterm with a NULL context */
4087         /* This probably could never happen */
4088         xterm_fd = NULL;
4089         if (aTHX != NULL)
4090 #endif
4091         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4092         if (xterm_fd != NULL)
4093             return xterm_fd;
4094     }
4095
4096     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4097
4098     /* once-per-program initialization...
4099        note that the SETAST calls and the dual test of pipe_ef
4100        makes sure that only the FIRST thread through here does
4101        the initialization...all other threads wait until it's
4102        done.
4103
4104        Yeah, uglier than a pthread call, it's got all the stuff inline
4105        rather than in a separate routine.
4106     */
4107
4108     if (!pipe_ef) {
4109         _ckvmssts_noperl(sys$setast(0));
4110         if (!pipe_ef) {
4111             unsigned long int pidcode = JPI$_PID;
4112             $DESCRIPTOR(d_delay, RETRY_DELAY);
4113             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4114             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4115             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4116         }
4117         if (!handler_set_up) {
4118           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4119           handler_set_up = TRUE;
4120         }
4121         _ckvmssts_noperl(sys$setast(1));
4122     }
4123
4124     /* see if we can find a VMSPIPE.COM */
4125
4126     tfilebuf[0] = '@';
4127     vmspipe = find_vmspipe(aTHX);
4128     if (vmspipe) {
4129         vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4130     } else {        /* uh, oh...we're in tempfile hell */
4131         tpipe = vmspipe_tempfile(aTHX);
4132         if (!tpipe) {       /* a fish popular in Boston */
4133             if (ckWARN(WARN_PIPE)) {
4134                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4135             }
4136         return NULL;
4137         }
4138         fgetname(tpipe,tfilebuf+1,1);
4139         vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4140     }
4141     vmspipedsc.dsc$a_pointer = tfilebuf;
4142
4143     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4144     if (!(sts & 1)) {
4145       switch (sts) {
4146         case RMS$_FNF:  case RMS$_DNF:
4147           set_errno(ENOENT); break;
4148         case RMS$_DIR:
4149           set_errno(ENOTDIR); break;
4150         case RMS$_DEV:
4151           set_errno(ENODEV); break;
4152         case RMS$_PRV:
4153           set_errno(EACCES); break;
4154         case RMS$_SYN:
4155           set_errno(EINVAL); break;
4156         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4157           set_errno(E2BIG); break;
4158         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4159           _ckvmssts_noperl(sts); /* fall through */
4160         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4161           set_errno(EVMSERR);
4162       }
4163       set_vaxc_errno(sts);
4164       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4165         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4166       }
4167       *psts = sts;
4168       return NULL;
4169     }
4170     n = sizeof(Info);
4171     _ckvmssts_noperl(lib$get_vm(&n, &info));
4172
4173     my_strlcpy(mode, in_mode, sizeof(mode));
4174     info->mode = *mode;
4175     info->done = FALSE;
4176     info->completion = 0;
4177     info->closing    = FALSE;
4178     info->in         = 0;
4179     info->out        = 0;
4180     info->err        = 0;
4181     info->fp         = NULL;
4182     info->useFILE    = 0;
4183     info->waiting    = 0;
4184     info->in_done    = TRUE;
4185     info->out_done   = TRUE;
4186     info->err_done   = TRUE;
4187     info->xchan      = 0;
4188     info->xchan_valid = 0;
4189
4190     in = (char *)PerlMem_malloc(VMS_MAXRSS);
4191     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4192     out = (char *)PerlMem_malloc(VMS_MAXRSS);
4193     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4194     err = (char *)PerlMem_malloc(VMS_MAXRSS);
4195     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4196
4197     in[0] = out[0] = err[0] = '\0';
4198
4199     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4200         info->useFILE = 1;
4201         strcpy(p,p+1);
4202     }
4203     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4204         wait = 1;
4205         strcpy(p,p+1);
4206     }
4207
4208     if (*mode == 'r') {             /* piping from subroutine */
4209
4210         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4211         if (info->out) {
4212             info->out->pipe_done = &info->out_done;
4213             info->out_done = FALSE;
4214             info->out->info = info;
4215         }
4216         if (!info->useFILE) {
4217             info->fp  = PerlIO_open(mbx, mode);
4218         } else {
4219             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4220             vmssetuserlnm("SYS$INPUT", mbx);
4221         }
4222
4223         if (!info->fp && info->out) {
4224             sys$cancel(info->out->chan_out);
4225
4226             while (!info->out_done) {
4227                 int done;
4228                 _ckvmssts_noperl(sys$setast(0));
4229                 done = info->out_done;
4230                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4231                 _ckvmssts_noperl(sys$setast(1));
4232                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4233             }
4234
4235             if (info->out->buf) {
4236                 n = info->out->bufsize * sizeof(char);
4237                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4238             }
4239             n = sizeof(Pipe);
4240             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4241             n = sizeof(Info);
4242             _ckvmssts_noperl(lib$free_vm(&n, &info));
4243             *psts = RMS$_FNF;
4244             return NULL;
4245         }
4246
4247         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4248         if (info->err) {
4249             info->err->pipe_done = &info->err_done;
4250             info->err_done = FALSE;
4251             info->err->info = info;
4252         }
4253
4254     } else if (*mode == 'w') {      /* piping to subroutine */
4255
4256         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4257         if (info->out) {
4258             info->out->pipe_done = &info->out_done;
4259             info->out_done = FALSE;
4260             info->out->info = info;
4261         }
4262
4263         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4264         if (info->err) {
4265             info->err->pipe_done = &info->err_done;
4266             info->err_done = FALSE;
4267             info->err->info = info;
4268         }
4269
4270         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4271         if (!info->useFILE) {
4272             info->fp  = PerlIO_open(mbx, mode);
4273         } else {
4274             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4275             vmssetuserlnm("SYS$OUTPUT", mbx);
4276         }
4277
4278         if (info->in) {
4279             info->in->pipe_done = &info->in_done;
4280             info->in_done = FALSE;
4281             info->in->info = info;
4282         }
4283
4284         /* error cleanup */
4285         if (!info->fp && info->in) {
4286             info->done = TRUE;
4287             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4288                                       0, 0, 0, 0, 0, 0, 0, 0));
4289
4290             while (!info->in_done) {
4291                 int done;
4292                 _ckvmssts_noperl(sys$setast(0));
4293                 done = info->in_done;
4294                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4295                 _ckvmssts_noperl(sys$setast(1));
4296                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4297             }
4298
4299             if (info->in->buf) {
4300                 n = info->in->bufsize * sizeof(char);
4301                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4302             }
4303             n = sizeof(Pipe);
4304             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4305             n = sizeof(Info);
4306             _ckvmssts_noperl(lib$free_vm(&n, &info));
4307             *psts = RMS$_FNF;
4308             return NULL;
4309         }
4310
4311
4312     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4313         /* Let the child inherit standard input, unless it's a directory. */
4314         Stat_t st;
4315         if (my_trnlnm("SYS$INPUT", in, 0)) {
4316             if (flex_stat(in, &st) != 0 || S_ISDIR(st.st_mode))
4317                 *in = '\0';
4318         }
4319
4320         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4321         if (info->out) {
4322             info->out->pipe_done = &info->out_done;
4323             info->out_done = FALSE;
4324             info->out->info = info;
4325         }
4326
4327         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4328         if (info->err) {
4329             info->err->pipe_done = &info->err_done;
4330             info->err_done = FALSE;
4331             info->err->info = info;
4332         }
4333     }
4334
4335     d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4336     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4337
4338     d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4339     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4340
4341     d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4342     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4343
4344     /* Done with the names for the pipes */
4345     PerlMem_free(err);
4346     PerlMem_free(out);
4347     PerlMem_free(in);
4348
4349     p = vmscmd->dsc$a_pointer;
4350     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4351     if (*p == '$') p++;                         /* remove leading $ */
4352     while (*p == ' ' || *p == '\t') p++;
4353
4354     for (j = 0; j < 4; j++) {
4355         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4356         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4357
4358     d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4359     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4360
4361         if (strlen(p) > MAX_DCL_SYMBOL) {
4362             p += MAX_DCL_SYMBOL;
4363         } else {
4364             p += strlen(p);
4365         }
4366     }
4367     _ckvmssts_noperl(sys$setast(0));
4368     info->next=open_pipes;  /* prepend to list */
4369     open_pipes=info;
4370     _ckvmssts_noperl(sys$setast(1));
4371     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4372      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4373      * have SYS$COMMAND if we need it.
4374      */
4375     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4376                       0, &info->pid, &info->completion,
4377                       0, popen_completion_ast,info,0,0,0));
4378
4379     /* if we were using a tempfile, close it now */
4380
4381     if (tpipe) fclose(tpipe);
4382
4383     /* once the subprocess is spawned, it has copied the symbols and
4384        we can get rid of ours */
4385
4386     for (j = 0; j < 4; j++) {
4387         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4388         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4389     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4390     }
4391     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4392     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4393     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4394     vms_execfree(vmscmd);
4395
4396 #ifdef PERL_IMPLICIT_CONTEXT
4397     if (aTHX)
4398 #endif
4399     PL_forkprocess = info->pid;
4400
4401     ret_fp = info->fp;
4402     if (wait) {
4403          dSAVEDERRNO;
4404          int done = 0;
4405          while (!done) {
4406              _ckvmssts_noperl(sys$setast(0));
4407              done = info->done;
4408              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4409              _ckvmssts_noperl(sys$setast(1));
4410              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4411          }
4412         *psts = info->completion;
4413 /* Caller thinks it is open and tries to close it. */
4414 /* This causes some problems, as it changes the error status */
4415 /*        my_pclose(info->fp); */
4416
4417          /* If we did not have a file pointer open, then we have to */
4418          /* clean up here or eventually we will run out of something */
4419          SAVE_ERRNO;
4420          if (info->fp == NULL) {
4421              my_pclose_pinfo(aTHX_ info);
4422          }
4423          RESTORE_ERRNO;
4424
4425     } else {
4426         *psts = info->pid;
4427     }
4428     return ret_fp;
4429 }  /* end of safe_popen */
4430
4431
4432 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4433 PerlIO *
4434 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4435 {
4436     int sts;
4437     TAINT_ENV();
4438     TAINT_PROPER("popen");
4439     PERL_FLUSHALL_FOR_CHILD;
4440     return safe_popen(aTHX_ cmd,mode,&sts);
4441 }
4442
4443 /*}}}*/
4444
4445
4446 /* Routine to close and cleanup a pipe info structure */
4447
4448 static I32
4449 my_pclose_pinfo(pTHX_ pInfo info) {
4450
4451     unsigned long int retsts;
4452     int done, n;
4453     pInfo next, last;
4454
4455     /* If we were writing to a subprocess, insure that someone reading from
4456      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4457      * produce an EOF record in the mailbox.
4458      *
4459      *  well, at least sometimes it *does*, so we have to watch out for
4460      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4461      */
4462      if (info->fp) {
4463         if (!info->useFILE
4464 #if defined(USE_ITHREADS)
4465           && my_perl
4466 #endif
4467 #ifdef USE_PERLIO
4468           && PL_perlio_fd_refcnt
4469 #endif
4470            )
4471             PerlIO_flush(info->fp);
4472         else
4473             fflush((FILE *)info->fp);
4474     }
4475
4476     _ckvmssts(sys$setast(0));
4477      info->closing = TRUE;
4478      done = info->done && info->in_done && info->out_done && info->err_done;
4479      /* hanging on write to Perl's input? cancel it */
4480      if (info->mode == 'r' && info->out && !info->out_done) {
4481         if (info->out->chan_out) {
4482             _ckvmssts(sys$cancel(info->out->chan_out));
4483             if (!info->out->chan_in) {   /* EOF generation, need AST */
4484                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4485             }
4486         }
4487      }
4488      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4489          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4490                            0, 0, 0, 0, 0, 0));
4491     _ckvmssts(sys$setast(1));
4492     if (info->fp) {
4493      if (!info->useFILE
4494 #if defined(USE_ITHREADS)
4495          && my_perl
4496 #endif
4497 #ifdef USE_PERLIO
4498          && PL_perlio_fd_refcnt
4499 #endif
4500         )
4501         PerlIO_close(info->fp);
4502      else
4503         fclose((FILE *)info->fp);
4504     }
4505      /*
4506         we have to wait until subprocess completes, but ALSO wait until all
4507         the i/o completes...otherwise we'll be freeing the "info" structure
4508         that the i/o ASTs could still be using...
4509      */
4510
4511      while (!done) {
4512          _ckvmssts(sys$setast(0));
4513          done = info->done && info->in_done && info->out_done && info->err_done;
4514          if (!done) _ckvmssts(sys$clref(pipe_ef));
4515          _ckvmssts(sys$setast(1));
4516          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4517      }
4518      retsts = info->completion;
4519
4520     /* remove from list of open pipes */
4521     _ckvmssts(sys$setast(0));
4522     last = NULL;
4523     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4524         if (next == info)
4525             break;
4526     }
4527
4528     if (last)
4529         last->next = info->next;
4530     else
4531         open_pipes = info->next;
4532     _ckvmssts(sys$setast(1));
4533
4534     /* free buffers and structures */
4535
4536     if (info->in) {
4537         if (info->in->buf) {
4538             n = info->in->bufsize * sizeof(char);
4539             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4540         }
4541         n = sizeof(Pipe);
4542         _ckvmssts(lib$free_vm(&n, &info->in));
4543     }
4544     if (info->out) {
4545         if (info->out->buf) {
4546             n = info->out->bufsize * sizeof(char);
4547             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4548         }
4549         n = sizeof(Pipe);
4550         _ckvmssts(lib$free_vm(&n, &info->out));
4551     }
4552     if (info->err) {
4553         if (info->err->buf) {
4554             n = info->err->bufsize * sizeof(char);
4555             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4556         }
4557         n = sizeof(Pipe);
4558         _ckvmssts(lib$free_vm(&n, &info->err));
4559     }
4560     n = sizeof(Info);
4561     _ckvmssts(lib$free_vm(&n, &info));
4562
4563     return retsts;
4564 }
4565
4566
4567 /*{{{  I32 my_pclose(PerlIO *fp)*/
4568 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4569 {
4570     pInfo info, last = NULL;
4571     I32 ret_status;
4572
4573     /* Fixme - need ast and mutex protection here */
4574     for (info = open_pipes; info != NULL; last = info, info = info->next)
4575         if (info->fp == fp) break;
4576
4577     if (info == NULL) {  /* no such pipe open */
4578       set_errno(ECHILD); /* quoth POSIX */
4579       set_vaxc_errno(SS$_NONEXPR);
4580       return -1;
4581     }
4582
4583     ret_status = my_pclose_pinfo(aTHX_ info);
4584
4585     return ret_status;
4586
4587 }  /* end of my_pclose() */
4588
4589 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4590   /* Roll our own prototype because we want this regardless of whether
4591    * _VMS_WAIT is defined.
4592    */
4593
4594 #ifdef __cplusplus
4595 extern "C" {
4596 #endif
4597   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4598 #ifdef __cplusplus
4599 }
4600 #endif
4601
4602 #endif
4603 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4604    created with popen(); otherwise partially emulate waitpid() unless
4605    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4606    Also check processes not considered by the CRTL waitpid().
4607  */
4608 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4609 Pid_t
4610 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4611 {
4612     pInfo info;
4613     int done;
4614     int sts;
4615     int j;
4616
4617     if (statusp) *statusp = 0;
4618
4619     for (info = open_pipes; info != NULL; info = info->next)
4620         if (info->pid == pid) break;
4621
4622     if (info != NULL) {  /* we know about this child */
4623       while (!info->done) {
4624           _ckvmssts(sys$setast(0));
4625           done = info->done;
4626           if (!done) _ckvmssts(sys$clref(pipe_ef));
4627           _ckvmssts(sys$setast(1));
4628           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4629       }
4630
4631       if (statusp) *statusp = info->completion;
4632       return pid;
4633     }
4634
4635     /* child that already terminated? */
4636
4637     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4638         if (closed_list[j].pid == pid) {
4639             if (statusp) *statusp = closed_list[j].completion;
4640             return pid;
4641         }
4642     }
4643
4644     /* fall through if this child is not one of our own pipe children */
4645
4646 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4647
4648       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4649        * in 7.2 did we get a version that fills in the VMS completion
4650        * status as Perl has always tried to do.
4651        */
4652
4653       sts = __vms_waitpid( pid, statusp, flags );
4654
4655       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4656          return sts;
4657
4658       /* If the real waitpid tells us the child does not exist, we
4659        * fall through here to implement waiting for a child that
4660        * was created by some means other than exec() (say, spawned
4661        * from DCL) or to wait for a process that is not a subprocess
4662        * of the current process.
4663        */
4664
4665 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4666
4667     {
4668       $DESCRIPTOR(intdsc,"0 00:00:01");
4669       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4670       unsigned long int pidcode = JPI$_PID, mypid;
4671       unsigned long int interval[2];
4672       unsigned int jpi_iosb[2];
4673       struct itmlst_3 jpilist[2] = {
4674           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4675           {                      0,         0,                 0, 0}
4676       };
4677
4678       if (pid <= 0) {
4679         /* Sorry folks, we don't presently implement rooting around for
4680            the first child we can find, and we definitely don't want to
4681            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4682          */
4683         set_errno(ENOTSUP);
4684         return -1;
4685       }
4686
4687       /* Get the owner of the child so I can warn if it's not mine. If the
4688        * process doesn't exist or I don't have the privs to look at it,
4689        * I can go home early.
4690        */
4691       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4692       if (sts & 1) sts = jpi_iosb[0];
4693       if (!(sts & 1)) {
4694         switch (sts) {
4695             case SS$_NONEXPR:
4696                 set_errno(ECHILD);
4697                 break;
4698             case SS$_NOPRIV:
4699                 set_errno(EACCES);
4700                 break;
4701             default:
4702                 _ckvmssts(sts);
4703         }
4704         set_vaxc_errno(sts);
4705         return -1;
4706       }
4707
4708       if (ckWARN(WARN_EXEC)) {
4709         /* remind folks they are asking for non-standard waitpid behavior */
4710         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4711         if (ownerpid != mypid)
4712           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4713                       "waitpid: process %x is not a child of process %x",
4714                       pid,mypid);
4715       }
4716
4717       /* simply check on it once a second until it's not there anymore. */
4718
4719       _ckvmssts(sys$bintim(&intdsc,interval));
4720       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4721             _ckvmssts(sys$schdwk(0,0,interval,0));
4722             _ckvmssts(sys$hiber());
4723       }
4724       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4725
4726       _ckvmssts(sts);
4727       return pid;
4728     }
4729 }  /* end of waitpid() */
4730 /*}}}*/
4731 /*}}}*/
4732 /*}}}*/
4733
4734 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4735 char *
4736 my_gconvert(double val, int ndig, int trail, char *buf)
4737 {
4738   static char __gcvtbuf[DBL_DIG+1];
4739   char *loc;
4740
4741   loc = buf ? buf : __gcvtbuf;
4742
4743   if (val) {
4744     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4745     return gcvt(val,ndig,loc);
4746   }
4747   else {
4748     loc[0] = '0'; loc[1] = '\0';
4749     return loc;
4750   }
4751
4752 }
4753 /*}}}*/
4754
4755 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4756 static int
4757 rms_free_search_context(struct FAB * fab)
4758 {
4759     struct NAM * nam;
4760
4761     nam = fab->fab$l_nam;
4762     nam->nam$b_nop |= NAM$M_SYNCHK;
4763     nam->nam$l_rlf = NULL;
4764     fab->fab$b_dns = 0;
4765     return sys$parse(fab, NULL, NULL);
4766 }
4767
4768 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4769 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4770 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4771 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4772 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4773 #define rms_nam_esll(nam) nam.nam$b_esl
4774 #define rms_nam_esl(nam) nam.nam$b_esl
4775 #define rms_nam_name(nam) nam.nam$l_name
4776 #define rms_nam_namel(nam) nam.nam$l_name
4777 #define rms_nam_type(nam) nam.nam$l_type
4778 #define rms_nam_typel(nam) nam.nam$l_type
4779 #define rms_nam_ver(nam) nam.nam$l_ver
4780 #define rms_nam_verl(nam) nam.nam$l_ver
4781 #define rms_nam_rsll(nam) nam.nam$b_rsl
4782 #define rms_nam_rsl(nam) nam.nam$b_rsl
4783 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4784 #define rms_set_fna(fab, nam, name, size) \
4785         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4786 #define rms_get_fna(fab, nam) fab.fab$l_fna
4787 #define rms_set_dna(fab, nam, name, size) \
4788         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4789 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4790 #define rms_set_esa(nam, name, size) \
4791         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4792 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4793         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4794 #define rms_set_rsa(nam, name, size) \
4795         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4796 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4797         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4798 #define rms_nam_name_type_l_size(nam) \
4799         (nam.nam$b_name + nam.nam$b_type)
4800 #else
4801 static int
4802 rms_free_search_context(struct FAB * fab)
4803 {
4804     struct NAML * nam;
4805
4806     nam = fab->fab$l_naml;
4807     nam->naml$b_nop |= NAM$M_SYNCHK;
4808     nam->naml$l_rlf = NULL;
4809     nam->naml$l_long_defname_size = 0;
4810
4811     fab->fab$b_dns = 0;
4812     return sys$parse(fab, NULL, NULL);
4813 }
4814
4815 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4816 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4817 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4818 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4819 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4820 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4821 #define rms_nam_esl(nam) nam.naml$b_esl
4822 #define rms_nam_name(nam) nam.naml$l_name
4823 #define rms_nam_namel(nam) nam.naml$l_long_name
4824 #define rms_nam_type(nam) nam.naml$l_type
4825 #define rms_nam_typel(nam) nam.naml$l_long_type
4826 #define rms_nam_ver(nam) nam.naml$l_ver
4827 #define rms_nam_verl(nam) nam.naml$l_long_ver
4828 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4829 #define rms_nam_rsl(nam) nam.naml$b_rsl
4830 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4831 #define rms_set_fna(fab, nam, name, size) \
4832         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4833         nam.naml$l_long_filename_size = size; \
4834         nam.naml$l_long_filename = name;}
4835 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4836 #define rms_set_dna(fab, nam, name, size) \
4837         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4838         nam.naml$l_long_defname_size = size; \
4839         nam.naml$l_long_defname = name; }
4840 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4841 #define rms_set_esa(nam, name, size) \
4842         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4843         nam.naml$l_long_expand_alloc = size; \
4844         nam.naml$l_long_expand = name; }
4845 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4846         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4847         nam.naml$l_long_expand = l_name; \
4848         nam.naml$l_long_expand_alloc = l_size; }
4849 #define rms_set_rsa(nam, name, size) \
4850         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4851         nam.naml$l_long_result = name; \
4852         nam.naml$l_long_result_alloc = size; }
4853 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4854         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4855         nam.naml$l_long_result = l_name; \
4856         nam.naml$l_long_result_alloc = l_size; }
4857 #define rms_nam_name_type_l_size(nam) \
4858         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4859 #endif
4860
4861
4862 /* rms_erase
4863  * The CRTL for 8.3 and later can create symbolic links in any mode,
4864  * however in 8.3 the unlink/remove/delete routines will only properly handle
4865  * them if one of the PCP modes is active.
4866  */
4867 static int
4868 rms_erase(const char * vmsname)
4869 {
4870   int status;
4871   struct FAB myfab = cc$rms_fab;
4872   rms_setup_nam(mynam);
4873
4874   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4875   rms_bind_fab_nam(myfab, mynam);
4876
4877 #ifdef NAML$M_OPEN_SPECIAL
4878   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4879 #endif
4880
4881   status = sys$erase(&myfab, 0, 0);
4882
4883   return status;
4884 }
4885
4886
4887 static int
4888 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4889                     const struct dsc$descriptor_s * vms_dst_dsc,
4890                     unsigned long flags)
4891 {
4892     /*  VMS and UNIX handle file permissions differently and the
4893      * the same ACL trick may be needed for renaming files,
4894      * especially if they are directories.
4895      */
4896
4897    /* todo: get kill_file and rename to share common code */
4898    /* I can not find online documentation for $change_acl
4899     * it appears to be replaced by $set_security some time ago */
4900
4901     const unsigned int access_mode = 0;
4902     $DESCRIPTOR(obj_file_dsc,"FILE");
4903     char *vmsname;
4904     char *rslt;
4905     unsigned long int jpicode = JPI$_UIC;
4906     int aclsts, fndsts, rnsts = -1;
4907     unsigned int ctx = 0;
4908     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4909     struct dsc$descriptor_s * clean_dsc;
4910
4911     struct myacedef {
4912         unsigned char myace$b_length;
4913         unsigned char myace$b_type;
4914         unsigned short int myace$w_flags;
4915         unsigned long int myace$l_access;
4916         unsigned long int myace$l_ident;
4917     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4918              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4919              0},
4920              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4921
4922     struct item_list_3
4923         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4924                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4925                       {0,0,0,0}},
4926         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4927         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4928                      {0,0,0,0}};
4929
4930
4931     /* Expand the input spec using RMS, since we do not want to put
4932      * ACLs on the target of a symbolic link */
4933     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
4934     if (vmsname == NULL)
4935         return SS$_INSFMEM;
4936
4937     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4938                         vmsname,
4939                         PERL_RMSEXPAND_M_SYMLINK);
4940     if (rslt == NULL) {
4941         PerlMem_free(vmsname);
4942         return SS$_INSFMEM;
4943     }
4944
4945     /* So we get our own UIC to use as a rights identifier,
4946      * and the insert an ACE at the head of the ACL which allows us
4947      * to delete the file.
4948      */
4949     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4950
4951     fildsc.dsc$w_length = strlen(vmsname);
4952     fildsc.dsc$a_pointer = vmsname;
4953     ctx = 0;
4954     newace.myace$l_ident = oldace.myace$l_ident;
4955     rnsts = SS$_ABORT;
4956
4957     /* Grab any existing ACEs with this identifier in case we fail */
4958     clean_dsc = &fildsc;
4959     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4960                                &fildsc,
4961                                NULL,
4962                                OSS$M_WLOCK,
4963                                findlst,
4964                                &ctx,
4965                                &access_mode);
4966
4967     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4968         /* Add the new ACE . . . */
4969
4970         /* if the sys$get_security succeeded, then ctx is valid, and the
4971          * object/file descriptors will be ignored.  But otherwise they
4972          * are needed
4973          */
4974         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4975                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4976         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4977             set_errno(EVMSERR);
4978             set_vaxc_errno(aclsts);
4979             PerlMem_free(vmsname);
4980             return aclsts;
4981         }
4982
4983         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4984                                 NULL, NULL,
4985                                 &flags,
4986                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4987
4988         if ($VMS_STATUS_SUCCESS(rnsts)) {
4989             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4990         }
4991
4992         /* Put things back the way they were. */
4993         ctx = 0;
4994         aclsts = sys$get_security(&obj_file_dsc,
4995                                   clean_dsc,
4996                                   NULL,
4997                                   OSS$M_WLOCK,
4998                                   findlst,
4999                                   &ctx,
5000                                   &access_mode);
5001
5002         if ($VMS_STATUS_SUCCESS(aclsts)) {
5003         int sec_flags;
5004
5005             sec_flags = 0;
5006             if (!$VMS_STATUS_SUCCESS(fndsts))
5007                 sec_flags = OSS$M_RELCTX;
5008
5009             /* Get rid of the new ACE */
5010             aclsts = sys$set_security(NULL, NULL, NULL,
5011                                   sec_flags, dellst, &ctx, &access_mode);
5012
5013             /* If there was an old ACE, put it back */
5014             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5015                 addlst[0].bufadr = &oldace;
5016                 aclsts = sys$set_security(NULL, NULL, NULL,
5017                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5018                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5019                     set_errno(EVMSERR);
5020                     set_vaxc_errno(aclsts);
5021                     rnsts = aclsts;
5022                 }
5023             } else {
5024             int aclsts2;
5025
5026                 /* Try to clear the lock on the ACL list */
5027                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5028                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5029
5030                 /* Rename errors are most important */
5031                 if (!$VMS_STATUS_SUCCESS(rnsts))
5032                     aclsts = rnsts;
5033                 set_errno(EVMSERR);
5034                 set_vaxc_errno(aclsts);
5035                 rnsts = aclsts;
5036             }
5037         }
5038         else {
5039             if (aclsts != SS$_ACLEMPTY)
5040                 rnsts = aclsts;
5041         }
5042     }
5043     else
5044         rnsts = fndsts;
5045
5046     PerlMem_free(vmsname);
5047     return rnsts;
5048 }
5049
5050
5051 /*{{{int rename(const char *, const char * */
5052 /* Not exactly what X/Open says to do, but doing it absolutely right
5053  * and efficiently would require a lot more work.  This should be close
5054  * enough to pass all but the most strict X/Open compliance test.
5055  */
5056 int
5057 Perl_rename(pTHX_ const char *src, const char * dst)
5058 {
5059     int retval;
5060     int pre_delete = 0;
5061     int src_sts;
5062     int dst_sts;
5063     Stat_t src_st;
5064     Stat_t dst_st;
5065
5066     /* Validate the source file */
5067     src_sts = flex_lstat(src, &src_st);
5068     if (src_sts != 0) {
5069
5070         /* No source file or other problem */
5071         return src_sts;
5072     }
5073     if (src_st.st_devnam[0] == 0)  {
5074         /* This may be possible so fail if it is seen. */
5075         errno = EIO;
5076         return -1;
5077     }
5078
5079     dst_sts = flex_lstat(dst, &dst_st);
5080     if (dst_sts == 0) {
5081
5082         if (dst_st.st_dev != src_st.st_dev) {
5083             /* Must be on the same device */
5084             errno = EXDEV;
5085             return -1;
5086         }
5087
5088         /* VMS_INO_T_COMPARE is true if the inodes are different
5089          * to match the output of memcmp
5090          */
5091
5092         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5093             /* That was easy, the files are the same! */
5094             return 0;
5095         }
5096
5097         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5098             /* If source is a directory, so must be dest */
5099                 errno = EISDIR;
5100                 return -1;
5101         }
5102
5103     }
5104
5105
5106     if ((dst_sts == 0) &&
5107         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5108
5109         /* We have issues here if vms_unlink_all_versions is set
5110          * If the destination exists, and is not a directory, then
5111          * we must delete in advance.
5112          *
5113          * If the src is a directory, then we must always pre-delete
5114          * the destination.
5115          *
5116          * If we successfully delete the dst in advance, and the rename fails
5117          * X/Open requires that errno be EIO.
5118          *
5119          */
5120
5121         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5122             int d_sts;
5123             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5124                                      S_ISDIR(dst_st.st_mode));
5125
5126            /* Need to delete all versions ? */
5127            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5128                 int i = 0;
5129
5130                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5131                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5132                     if (d_sts != 0)
5133                         break;
5134                     i++;
5135
5136                     /* Make sure that we do not loop forever */
5137                     if (i > 32767) {
5138                         errno = EIO;
5139                         d_sts = -1;
5140                         break;
5141                     }
5142                 }
5143            }
5144
5145             if (d_sts != 0)
5146                 return d_sts;
5147
5148             /* We killed the destination, so only errno now is EIO */
5149             pre_delete = 1;
5150         }
5151     }
5152
5153     /* Originally the idea was to call the CRTL rename() and only
5154      * try the lib$rename_file if it failed.
5155      * It turns out that there are too many variants in what the
5156      * the CRTL rename might do, so only use lib$rename_file
5157      */
5158     retval = -1;
5159
5160     {
5161         /* Is the source and dest both in VMS format */
5162         /* if the source is a directory, then need to fileify */
5163         /*  and dest must be a directory or non-existent. */
5164
5165         char * vms_dst;
5166         int sts;
5167         char * ret_str;
5168         unsigned long flags;
5169         struct dsc$descriptor_s old_file_dsc;
5170         struct dsc$descriptor_s new_file_dsc;
5171
5172         /* We need to modify the src and dst depending
5173          * on if one or more of them are directories.
5174          */
5175
5176         vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
5177         if (vms_dst == NULL)
5178             _ckvmssts_noperl(SS$_INSFMEM);
5179
5180         if (S_ISDIR(src_st.st_mode)) {
5181         char * ret_str;
5182         char * vms_dir_file;
5183
5184             vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
5185             if (vms_dir_file == NULL)
5186                 _ckvmssts_noperl(SS$_INSFMEM);
5187
5188             /* If the dest is a directory, we must remove it */
5189             if (dst_sts == 0) {
5190                 int d_sts;
5191                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5192                 if (d_sts != 0) {
5193                     PerlMem_free(vms_dst);
5194                     errno = EIO;
5195                     return d_sts;
5196                 }
5197
5198                 pre_delete = 1;
5199             }
5200
5201            /* The dest must be a VMS file specification */
5202            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5203            if (ret_str == NULL) {
5204                 PerlMem_free(vms_dst);
5205                 errno = EIO;
5206                 return -1;
5207            }
5208
5209             /* The source must be a file specification */
5210             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5211             if (ret_str == NULL) {
5212                 PerlMem_free(vms_dst);
5213                 PerlMem_free(vms_dir_file);
5214                 errno = EIO;
5215                 return -1;
5216             }
5217             PerlMem_free(vms_dst);
5218             vms_dst = vms_dir_file;
5219
5220         } else {
5221             /* File to file or file to new dir */
5222
5223             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5224                 /* VMS pathify a dir target */
5225                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5226                 if (ret_str == NULL) {
5227                     PerlMem_free(vms_dst);
5228                     errno = EIO;
5229                     return -1;
5230                 }
5231             } else {
5232                 char * v_spec, * r_spec, * d_spec, * n_spec;
5233                 char * e_spec, * vs_spec;
5234                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5235
5236                 /* fileify a target VMS file specification */
5237                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5238                 if (ret_str == NULL) {
5239                     PerlMem_free(vms_dst);
5240                     errno = EIO;
5241                     return -1;
5242                 }
5243
5244                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5245                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5246                              &e_len, &vs_spec, &vs_len);
5247                 if (sts == 0) {
5248                      if (e_len == 0) {
5249                          /* Get rid of the version */
5250                          if (vs_len != 0) {
5251                              *vs_spec = '\0';
5252                          }
5253                          /* Need to specify a '.' so that the extension */
5254                          /* is not inherited */
5255                          strcat(vms_dst,".");
5256                      }
5257                 }
5258             }
5259         }
5260
5261         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5262         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5263         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5264         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5265
5266         new_file_dsc.dsc$a_pointer = vms_dst;
5267         new_file_dsc.dsc$w_length = strlen(vms_dst);
5268         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5269         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5270
5271         flags = 0;
5272 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5273         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5274 #endif
5275
5276         sts = lib$rename_file(&old_file_dsc,
5277                               &new_file_dsc,
5278                               NULL, NULL,
5279                               &flags,
5280                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5281         if (!$VMS_STATUS_SUCCESS(sts)) {
5282
5283            /* We could have failed because VMS style permissions do not
5284             * permit renames that UNIX will allow.  Just like the hack
5285             * in for kill_file.
5286             */
5287            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5288         }
5289
5290         PerlMem_free(vms_dst);
5291         if (!$VMS_STATUS_SUCCESS(sts)) {
5292             errno = EIO;
5293             return -1;
5294         }
5295         retval = 0;
5296     }
5297
5298     if (vms_unlink_all_versions) {
5299         /* Now get rid of any previous versions of the source file that
5300          * might still exist
5301          */
5302         int i = 0;
5303         dSAVEDERRNO;
5304         SAVE_ERRNO;
5305         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5306                                    S_ISDIR(src_st.st_mode));
5307         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5308              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5309                                        S_ISDIR(src_st.st_mode));
5310              if (src_sts != 0)
5311                  break;
5312              i++;
5313
5314              /* Make sure that we do not loop forever */
5315              if (i > 32767) {
5316                  src_sts = -1;
5317                  break;
5318              }
5319         }
5320         RESTORE_ERRNO;
5321     }
5322
5323     /* We deleted the destination, so must force the error to be EIO */
5324     if ((retval != 0) && (pre_delete != 0))
5325         errno = EIO;
5326
5327     return retval;
5328 }
5329 /*}}}*/
5330
5331
5332 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5333 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5334  * to expand file specification.  Allows for a single default file
5335  * specification and a simple mask of options.  If outbuf is non-NULL,
5336  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5337  * the resultant file specification is placed.  If outbuf is NULL, the
5338  * resultant file specification is placed into a static buffer.
5339  * The third argument, if non-NULL, is taken to be a default file
5340  * specification string.  The fourth argument is unused at present.
5341  * rmesexpand() returns the address of the resultant string if
5342  * successful, and NULL on error.
5343  *
5344  * New functionality for previously unused opts value:
5345  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5346  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5347  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5348  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5349  */
5350 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5351
5352 static char *
5353 int_rmsexpand
5354    (const char *filespec,
5355     char *outbuf,
5356     const char *defspec,
5357     unsigned opts,
5358     int * fs_utf8,
5359     int * dfs_utf8)
5360 {
5361   char * ret_spec;
5362   const char * in_spec;
5363   char * spec_buf;
5364   const char * def_spec;
5365   char * vmsfspec, *vmsdefspec;
5366   char * esa;
5367   char * esal = NULL;
5368   char * outbufl;
5369   struct FAB myfab = cc$rms_fab;
5370   rms_setup_nam(mynam);
5371   STRLEN speclen;
5372   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5373   int sts;
5374
5375   /* temp hack until UTF8 is actually implemented */
5376   if (fs_utf8 != NULL)
5377     *fs_utf8 = 0;
5378
5379   if (!filespec || !*filespec) {
5380     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5381     return NULL;
5382   }
5383
5384   vmsfspec = NULL;
5385   vmsdefspec = NULL;
5386   outbufl = NULL;
5387
5388   in_spec = filespec;
5389   isunix = 0;
5390   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5391       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5392       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5393
5394       /* If this is a UNIX file spec, convert it to VMS */
5395       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5396                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5397                            &e_len, &vs_spec, &vs_len);
5398       if (sts != 0) {
5399           isunix = 1;
5400           char * ret_spec;
5401
5402           vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5403           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5404           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5405           if (ret_spec == NULL) {
5406               PerlMem_free(vmsfspec);
5407               return NULL;
5408           }
5409           in_spec = (const char *)vmsfspec;
5410
5411           /* Unless we are forcing to VMS format, a UNIX input means
5412            * UNIX output, and that requires long names to be used
5413            */
5414           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5415 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5416               opts |= PERL_RMSEXPAND_M_LONG;
5417 #else
5418               NOOP;
5419 #endif
5420           else
5421               isunix = 0;
5422       }
5423
5424   }
5425
5426   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5427   rms_bind_fab_nam(myfab, mynam);
5428
5429   /* Process the default file specification if present */
5430   def_spec = defspec;
5431   if (defspec && *defspec) {
5432     int t_isunix;
5433     t_isunix = is_unix_filespec(defspec);
5434     if (t_isunix) {
5435       vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5436       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5437       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5438
5439       if (ret_spec == NULL) {
5440           /* Clean up and bail */
5441           PerlMem_free(vmsdefspec);
5442           if (vmsfspec != NULL)
5443               PerlMem_free(vmsfspec);
5444               return NULL;
5445           }
5446           def_spec = (const char *)vmsdefspec;
5447       }
5448       rms_set_dna(myfab, mynam,
5449                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5450   }
5451
5452   /* Now we need the expansion buffers */
5453   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
5454   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5455 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5456   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
5457   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5458 #endif
5459   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5460
5461   /* If a NAML block is used RMS always writes to the long and short
5462    * addresses unless you suppress the short name.
5463    */
5464 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5465   outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
5466   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5467 #endif
5468    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5469
5470 #ifdef NAM$M_NO_SHORT_UPCASE
5471   if (decc_efs_case_preserve)
5472     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5473 #endif
5474
5475    /* We may not want to follow symbolic links */
5476 #ifdef NAML$M_OPEN_SPECIAL
5477   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5478     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5479 #endif
5480
5481   /* First attempt to parse as an existing file */
5482   retsts = sys$parse(&myfab,0,0);
5483   if (!(retsts & STS$K_SUCCESS)) {
5484
5485     /* Could not find the file, try as syntax only if error is not fatal */
5486     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5487     if (retsts == RMS$_DNF ||
5488         retsts == RMS$_DIR ||
5489         retsts == RMS$_DEV ||
5490         retsts == RMS$_PRV) {
5491       retsts = sys$parse(&myfab,0,0);
5492       if (retsts & STS$K_SUCCESS) goto int_expanded;
5493     }
5494
5495      /* Still could not parse the file specification */
5496     /*----------------------------------------------*/
5497     sts = rms_free_search_context(&myfab); /* Free search context */
5498     if (vmsdefspec != NULL)
5499         PerlMem_free(vmsdefspec);
5500     if (vmsfspec != NULL)
5501         PerlMem_free(vmsfspec);
5502     if (outbufl != NULL)
5503         PerlMem_free(outbufl);
5504     PerlMem_free(esa);
5505     if (esal != NULL)
5506         PerlMem_free(esal);
5507     set_vaxc_errno(retsts);
5508     if      (retsts == RMS$_PRV) set_errno(EACCES);
5509     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5510     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5511     else                         set_errno(EVMSERR);
5512     return NULL;
5513   }
5514   retsts = sys$search(&myfab,0,0);
5515   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5516     sts = rms_free_search_context(&myfab); /* Free search context */
5517     if (vmsdefspec != NULL)
5518         PerlMem_free(vmsdefspec);
5519     if (vmsfspec != NULL)
5520         PerlMem_free(vmsfspec);
5521     if (outbufl != NULL)
5522         PerlMem_free(outbufl);
5523     PerlMem_free(esa);
5524     if (esal != NULL)
5525         PerlMem_free(esal);
5526     set_vaxc_errno(retsts);
5527     if      (retsts == RMS$_PRV) set_errno(EACCES);
5528     else                         set_errno(EVMSERR);
5529     return NULL;
5530   }
5531
5532   /* If the input filespec contained any lowercase characters,
5533    * downcase the result for compatibility with Unix-minded code. */
5534 int_expanded:
5535   if (!decc_efs_case_preserve) {
5536     char * tbuf;
5537     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5538       if (islower(*tbuf)) { haslower = 1; break; }
5539   }
5540
5541    /* Is a long or a short name expected */
5542   /*------------------------------------*/
5543   spec_buf = NULL;
5544 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5545   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5546     if (rms_nam_rsll(mynam)) {
5547         spec_buf = outbufl;
5548         speclen = rms_nam_rsll(mynam);
5549     }
5550     else {
5551         spec_buf = esal; /* Not esa */
5552         speclen = rms_nam_esll(mynam);
5553     }
5554   }
5555   else {
5556 #endif
5557     if (rms_nam_rsl(mynam)) {
5558         spec_buf = outbuf;
5559         speclen = rms_nam_rsl(mynam);
5560     }
5561     else {
5562         spec_buf = esa; /* Not esal */
5563         speclen = rms_nam_esl(mynam);
5564     }
5565 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5566   }
5567 #endif
5568   spec_buf[speclen] = '\0';
5569
5570   /* Trim off null fields added by $PARSE
5571    * If type > 1 char, must have been specified in original or default spec
5572    * (not true for version; $SEARCH may have added version of existing file).
5573    */
5574   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5575   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5576     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5577              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5578   }
5579   else {
5580     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5581              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5582   }
5583   if (trimver || trimtype) {
5584     if (defspec && *defspec) {
5585       char *defesal = NULL;
5586       char *defesa = NULL;
5587       defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5588       if (defesa != NULL) {
5589         struct FAB deffab = cc$rms_fab;
5590 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5591         defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5592         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5593 #endif
5594         rms_setup_nam(defnam);
5595
5596         rms_bind_fab_nam(deffab, defnam);
5597
5598         /* Cast ok */
5599         rms_set_fna
5600             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5601
5602         /* RMS needs the esa/esal as a work area if wildcards are involved */
5603         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5604
5605         rms_clear_nam_nop(defnam);
5606         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5607 #ifdef NAM$M_NO_SHORT_UPCASE
5608         if (decc_efs_case_preserve)
5609           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5610 #endif
5611 #ifdef NAML$M_OPEN_SPECIAL
5612         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5613           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5614 #endif
5615         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5616           if (trimver) {
5617              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5618           }
5619           if (trimtype) {
5620             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5621           }
5622         }
5623         if (defesal != NULL)
5624             PerlMem_free(defesal);
5625         PerlMem_free(defesa);
5626       } else {
5627           _ckvmssts_noperl(SS$_INSFMEM);
5628       }
5629     }
5630     if (trimver) {
5631       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5632         if (*(rms_nam_verl(mynam)) != '\"')
5633           speclen = rms_nam_verl(mynam) - spec_buf;
5634       }
5635       else {
5636         if (*(rms_nam_ver(mynam)) != '\"')
5637           speclen = rms_nam_ver(mynam) - spec_buf;
5638       }
5639     }
5640     if (trimtype) {
5641       /* If we didn't already trim version, copy down */
5642       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5643         if (speclen > rms_nam_verl(mynam) - spec_buf)
5644           memmove
5645            (rms_nam_typel(mynam),
5646             rms_nam_verl(mynam),
5647             speclen - (rms_nam_verl(mynam) - spec_buf));
5648           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5649       }
5650       else {
5651         if (speclen > rms_nam_ver(mynam) - spec_buf)
5652           memmove
5653            (rms_nam_type(mynam),
5654             rms_nam_ver(mynam),
5655             speclen - (rms_nam_ver(mynam) - spec_buf));
5656           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5657       }
5658     }
5659   }
5660
5661    /* Done with these copies of the input files */
5662   /*-------------------------------------------*/
5663   if (vmsfspec != NULL)
5664         PerlMem_free(vmsfspec);
5665   if (vmsdefspec != NULL)
5666         PerlMem_free(vmsdefspec);
5667
5668   /* If we just had a directory spec on input, $PARSE "helpfully"
5669    * adds an empty name and type for us */
5670 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5671   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5672     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5673         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5674         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5675       speclen = rms_nam_namel(mynam) - spec_buf;
5676   }
5677   else
5678 #endif
5679   {
5680     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5681         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5682         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5683       speclen = rms_nam_name(mynam) - spec_buf;
5684   }
5685
5686   /* Posix format specifications must have matching quotes */
5687   if (speclen < (VMS_MAXRSS - 1)) {
5688     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5689       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5690         spec_buf[speclen] = '\"';
5691         speclen++;
5692       }
5693     }
5694   }
5695   spec_buf[speclen] = '\0';
5696   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5697
5698   /* Have we been working with an expanded, but not resultant, spec? */
5699   /* Also, convert back to Unix syntax if necessary. */
5700   {
5701   int rsl;
5702
5703 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5704     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5705       rsl = rms_nam_rsll(mynam);
5706     } else
5707 #endif
5708     {
5709       rsl = rms_nam_rsl(mynam);
5710     }
5711     if (!rsl) {
5712       /* rsl is not present, it means that spec_buf is either */
5713       /* esa or esal, and needs to be copied to outbuf */
5714       /* convert to Unix if desired */
5715       if (isunix) {
5716         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5717       } else {
5718         /* VMS file specs are not in UTF-8 */
5719         if (fs_utf8 != NULL)
5720             *fs_utf8 = 0;
5721         my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5722         ret_spec = outbuf;
5723       }
5724     }
5725     else {
5726       /* Now spec_buf is either outbuf or outbufl */
5727       /* We need the result into outbuf */
5728       if (isunix) {
5729            /* If we need this in UNIX, then we need another buffer */
5730            /* to keep things in order */
5731            char * src;
5732            char * new_src = NULL;
5733            if (spec_buf == outbuf) {
5734                new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
5735                my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5736            } else {
5737                src = spec_buf;
5738            }
5739            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5740            if (new_src) {
5741                PerlMem_free(new_src);
5742            }
5743       } else {
5744            /* VMS file specs are not in UTF-8 */
5745            if (fs_utf8 != NULL)
5746                *fs_utf8 = 0;
5747
5748            /* Copy the buffer if needed */
5749            if (outbuf != spec_buf)
5750                my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5751            ret_spec = outbuf;
5752       }
5753     }
5754   }
5755
5756   /* Need to clean up the search context */
5757   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5758   sts = rms_free_search_context(&myfab); /* Free search context */
5759
5760   /* Clean up the extra buffers */
5761   if (esal != NULL)
5762       PerlMem_free(esal);
5763   PerlMem_free(esa);
5764   if (outbufl != NULL)
5765      PerlMem_free(outbufl);
5766
5767   /* Return the result */
5768   return ret_spec;
5769 }
5770
5771 /* Common simple case - Expand an already VMS spec */
5772 static char *
5773 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5774     opts |= PERL_RMSEXPAND_M_VMS_IN;
5775     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5776 }
5777
5778 /* Common simple case - Expand to a VMS spec */
5779 static char *
5780 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5781     opts |= PERL_RMSEXPAND_M_VMS;
5782     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5783 }
5784
5785
5786 /* Entry point used by perl routines */
5787 static char *
5788 mp_do_rmsexpand
5789    (pTHX_ const char *filespec,
5790     char *outbuf,
5791     int ts,
5792     const char *defspec,
5793     unsigned opts,
5794     int * fs_utf8,
5795     int * dfs_utf8)
5796 {
5797     static char __rmsexpand_retbuf[VMS_MAXRSS];
5798     char * expanded, *ret_spec, *ret_buf;
5799
5800     expanded = NULL;
5801     ret_buf = outbuf;
5802     if (ret_buf == NULL) {
5803         if (ts) {
5804             Newx(expanded, VMS_MAXRSS, char);
5805             if (expanded == NULL)
5806                 _ckvmssts(SS$_INSFMEM);
5807             ret_buf = expanded;
5808         } else {
5809             ret_buf = __rmsexpand_retbuf;
5810         }
5811     }
5812
5813
5814     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5815                              opts, fs_utf8,  dfs_utf8);
5816
5817     if (ret_spec == NULL) {
5818        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5819        if (expanded)
5820            Safefree(expanded);
5821     }
5822
5823     return ret_spec;
5824 }
5825 /*}}}*/
5826 /* External entry points */
5827 char *
5828 Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5829 {
5830     return do_rmsexpand(spec, buf, 0, def, opt, NULL, NULL);
5831 }
5832
5833 char *
5834 Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5835 {
5836     return do_rmsexpand(spec, buf, 1, def, opt, NULL, NULL);
5837 }
5838
5839 char *
5840 Perl_rmsexpand_utf8(pTHX_ const char *spec, char *buf, const char *def,
5841                     unsigned opt, int * fs_utf8, int * dfs_utf8)
5842 {
5843     return do_rmsexpand(spec, buf, 0, def, opt, fs_utf8, dfs_utf8);
5844 }
5845
5846 char *
5847 Perl_rmsexpand_utf8_ts(pTHX_ const char *spec, char *buf, const char *def,
5848                        unsigned opt, int * fs_utf8, int * dfs_utf8)
5849 {
5850     return do_rmsexpand(spec, buf, 1, def, opt, fs_utf8, dfs_utf8);
5851 }
5852
5853
5854 /*
5855 ** The following routines are provided to make life easier when
5856 ** converting among VMS-style and Unix-style directory specifications.
5857 ** All will take input specifications in either VMS or Unix syntax. On
5858 ** failure, all return NULL.  If successful, the routines listed below
5859 ** return a pointer to a buffer containing the appropriately
5860 ** reformatted spec (and, therefore, subsequent calls to that routine
5861 ** will clobber the result), while the routines of the same names with
5862 ** a _ts suffix appended will return a pointer to a mallocd string
5863 ** containing the appropriately reformatted spec.
5864 ** In all cases, only explicit syntax is altered; no check is made that
5865 ** the resulting string is valid or that the directory in question
5866 ** actually exists.
5867 **
5868 **   fileify_dirspec() - convert a directory spec into the name of the
5869 **     directory file (i.e. what you can stat() to see if it's a dir).
5870 **     The style (VMS or Unix) of the result is the same as the style
5871 **     of the parameter passed in.
5872 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5873 **     what you prepend to a filename to indicate what directory it's in).
5874 **     The style (VMS or Unix) of the result is the same as the style
5875 **     of the parameter passed in.
5876 **   tounixpath() - convert a directory spec into a Unix-style path.
5877 **   tovmspath() - convert a directory spec into a VMS-style path.
5878 **   tounixspec() - convert any file spec into a Unix-style file spec.
5879 **   tovmsspec() - convert any file spec into a VMS-style spec.
5880 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5881 **
5882 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5883 ** Permission is given to distribute this code as part of the Perl
5884 ** standard distribution under the terms of the GNU General Public
5885 ** License or the Perl Artistic License.  Copies of each may be
5886 ** found in the Perl standard distribution.
5887  */
5888
5889 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5890 static char *
5891 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5892 {
5893     unsigned long int dirlen, retlen, hasfilename = 0;
5894     char *cp1, *cp2, *lastdir;
5895     char *trndir, *vmsdir;
5896     unsigned short int trnlnm_iter_count;
5897     int sts;
5898     if (utf8_fl != NULL)
5899         *utf8_fl = 0;
5900
5901     if (!dir || !*dir) {
5902       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5903     }
5904     dirlen = strlen(dir);
5905     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5906     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5907       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5908         dir = "/sys$disk";
5909         dirlen = 9;
5910       }
5911       else
5912         dirlen = 1;
5913     }
5914     if (dirlen > (VMS_MAXRSS - 1)) {
5915       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5916       return NULL;
5917     }
5918     trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5919     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5920     if (!strpbrk(dir+1,"/]>:")  &&
5921         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5922       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5923       trnlnm_iter_count = 0;
5924       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
5925         trnlnm_iter_count++;
5926         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5927       }
5928       dirlen = strlen(trndir);
5929     }
5930     else {
5931       memcpy(trndir, dir, dirlen);
5932       trndir[dirlen] = '\0';
5933     }
5934
5935     /* At this point we are done with *dir and use *trndir which is a
5936      * copy that can be modified.  *dir must not be modified.
5937      */
5938
5939     /* If we were handed a rooted logical name or spec, treat it like a
5940      * simple directory, so that
5941      *    $ Define myroot dev:[dir.]
5942      *    ... do_fileify_dirspec("myroot",buf,1) ...
5943      * does something useful.
5944      */
5945     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5946       trndir[--dirlen] = '\0';
5947       trndir[dirlen-1] = ']';
5948     }
5949     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5950       trndir[--dirlen] = '\0';
5951       trndir[dirlen-1] = '>';
5952     }
5953
5954     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5955       /* If we've got an explicit filename, we can just shuffle the string. */
5956       if (*(cp1+1)) hasfilename = 1;
5957       /* Similarly, we can just back up a level if we've got multiple levels
5958          of explicit directories in a VMS spec which ends with directories. */
5959       else {
5960         for (cp2 = cp1; cp2 > trndir; cp2--) {
5961           if (*cp2 == '.') {
5962             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5963 /* fix-me, can not scan EFS file specs backward like this */
5964               *cp2 = *cp1; *cp1 = '\0';
5965               hasfilename = 1;
5966               break;
5967             }
5968           }
5969           if (*cp2 == '[' || *cp2 == '<') break;
5970         }
5971       }
5972     }
5973
5974     vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5975     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5976     cp1 = strpbrk(trndir,"]:>");
5977     if (cp1 && *(cp1+1) == ':')   /* DECNet node spec with :: */
5978         cp1 = strpbrk(cp1+2,"]:>");
5979
5980     if (hasfilename || !cp1) { /* filename present or not VMS */
5981
5982       if (trndir[0] == '.') {
5983         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5984           PerlMem_free(trndir);
5985           PerlMem_free(vmsdir);
5986           return int_fileify_dirspec("[]", buf, NULL);
5987         }
5988         else if (trndir[1] == '.' &&
5989                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5990           PerlMem_free(trndir);
5991           PerlMem_free(vmsdir);
5992           return int_fileify_dirspec("[-]", buf, NULL);
5993         }
5994       }
5995       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5996         dirlen -= 1;                 /* to last element */
5997         lastdir = strrchr(trndir,'/');
5998       }
5999       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6000         /* If we have "/." or "/..", VMSify it and let the VMS code
6001          * below expand it, rather than repeating the code to handle
6002          * relative components of a filespec here */
6003         do {
6004           if (*(cp1+2) == '.') cp1++;
6005           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6006             char * ret_chr;
6007             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6008                 PerlMem_free(trndir);
6009                 PerlMem_free(vmsdir);
6010                 return NULL;
6011             }
6012             if (strchr(vmsdir,'/') != NULL) {
6013               /* If int_tovmsspec() returned it, it must have VMS syntax
6014                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6015                * the time to check this here only so we avoid a recursion
6016                * loop; otherwise, gigo.
6017                */
6018               PerlMem_free(trndir);
6019               PerlMem_free(vmsdir);
6020               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6021               return NULL;
6022             }
6023             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6024                 PerlMem_free(trndir);
6025                 PerlMem_free(vmsdir);
6026                 return NULL;
6027             }
6028             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6029             PerlMem_free(trndir);
6030             PerlMem_free(vmsdir);
6031             return ret_chr;
6032           }
6033           cp1++;
6034         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6035         lastdir = strrchr(trndir,'/');
6036       }
6037       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6038         char * ret_chr;
6039         /* Ditto for specs that end in an MFD -- let the VMS code
6040          * figure out whether it's a real device or a rooted logical. */
6041
6042         /* This should not happen any more.  Allowing the fake /000000
6043          * in a UNIX pathname causes all sorts of problems when trying
6044          * to run in UNIX emulation.  So the VMS to UNIX conversions
6045          * now remove the fake /000000 directories.
6046          */
6047
6048         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6049         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6050             PerlMem_free(trndir);
6051             PerlMem_free(vmsdir);
6052             return NULL;
6053         }
6054         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6055             PerlMem_free(trndir);
6056             PerlMem_free(vmsdir);
6057             return NULL;
6058         }
6059         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6060         PerlMem_free(trndir);
6061         PerlMem_free(vmsdir);
6062         return ret_chr;
6063       }
6064       else {
6065
6066         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6067              !(lastdir = cp1 = strrchr(trndir,']')) &&
6068              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6069
6070         cp2 = strrchr(cp1,'.');
6071         if (cp2) {
6072             int e_len, vs_len = 0;
6073             int is_dir = 0;
6074             char * cp3;
6075             cp3 = strchr(cp2,';');
6076             e_len = strlen(cp2);
6077             if (cp3) {
6078                 vs_len = strlen(cp3);
6079                 e_len = e_len - vs_len;
6080             }
6081             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6082             if (!is_dir) {
6083                 if (!decc_efs_charset) {
6084                     /* If this is not EFS, then not a directory */
6085                     PerlMem_free(trndir);
6086                     PerlMem_free(vmsdir);
6087                     set_errno(ENOTDIR);
6088                     set_vaxc_errno(RMS$_DIR);
6089                     return NULL;
6090                 }
6091             } else {
6092                 /* Ok, here we have an issue, technically if a .dir shows */
6093                 /* from inside a directory, then we should treat it as */
6094                 /* xxx^.dir.dir.  But we do not have that context at this */
6095                 /* point unless this is totally restructured, so we remove */
6096                 /* The .dir for now, and fix this better later */
6097                 dirlen = cp2 - trndir;
6098             }
6099             if (decc_efs_charset && !strchr(trndir,'/')) {
6100                 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6101                 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6102
6103                 for (; cp4 > cp1; cp4--) {
6104                     if (*cp4 == '.') {
6105                         if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6106                             memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6107                             *cp4 = '^';
6108                             dirlen++;
6109                         }
6110                     }
6111                 }
6112             }
6113         }
6114
6115       }
6116
6117       retlen = dirlen + 6;
6118       memcpy(buf, trndir, dirlen);
6119       buf[dirlen] = '\0';
6120
6121       /* We've picked up everything up to the directory file name.
6122          Now just add the type and version, and we're set. */
6123       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6124           strcat(buf,".dir");
6125       else
6126           strcat(buf,".DIR");
6127       if (!decc_filename_unix_no_version)
6128           strcat(buf,";1");
6129       PerlMem_free(trndir);
6130       PerlMem_free(vmsdir);
6131       return buf;
6132     }
6133     else {  /* VMS-style directory spec */
6134
6135       char *esa, *esal, term, *cp;
6136       char *my_esa;
6137       int my_esa_len;
6138       unsigned long int cmplen, haslower = 0;
6139       struct FAB dirfab = cc$rms_fab;
6140       rms_setup_nam(savnam);
6141       rms_setup_nam(dirnam);
6142
6143       esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
6144       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6145       esal = NULL;
6146 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6147       esal = (char *)PerlMem_malloc(VMS_MAXRSS);
6148       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6149 #endif
6150       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6151       rms_bind_fab_nam(dirfab, dirnam);
6152       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6153       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6154 #ifdef NAM$M_NO_SHORT_UPCASE
6155       if (decc_efs_case_preserve)
6156         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6157 #endif
6158
6159       for (cp = trndir; *cp; cp++)
6160         if (islower(*cp)) { haslower = 1; break; }
6161       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6162         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6163             (dirfab.fab$l_sts == RMS$_DNF) ||
6164             (dirfab.fab$l_sts == RMS$_PRV)) {
6165             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6166             sts = sys$parse(&dirfab);
6167         }
6168         if (!sts) {
6169           PerlMem_free(esa);
6170           if (esal != NULL)
6171               PerlMem_free(esal);
6172           PerlMem_free(trndir);
6173           PerlMem_free(vmsdir);
6174           set_errno(EVMSERR);
6175           set_vaxc_errno(dirfab.fab$l_sts);
6176           return NULL;
6177         }
6178       }
6179       else {
6180         savnam = dirnam;
6181         /* Does the file really exist? */
6182         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6183           /* Yes; fake the fnb bits so we'll check type below */
6184           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6185         }
6186         else { /* No; just work with potential name */
6187           if (dirfab.fab$l_sts    == RMS$_FNF
6188               || dirfab.fab$l_sts == RMS$_DNF
6189               || dirfab.fab$l_sts == RMS$_FND)
6190                 dirnam = savnam;
6191           else {
6192             int fab_sts;
6193             fab_sts = dirfab.fab$l_sts;
6194             sts = rms_free_search_context(&dirfab);
6195             PerlMem_free(esa);
6196             if (esal != NULL)
6197                 PerlMem_free(esal);
6198             PerlMem_free(trndir);
6199             PerlMem_free(vmsdir);
6200             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6201             return NULL;
6202           }
6203         }
6204       }
6205
6206       /* Make sure we are using the right buffer */
6207 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6208       if (esal != NULL) {
6209         my_esa = esal;
6210         my_esa_len = rms_nam_esll(dirnam);
6211       } else {
6212 #endif
6213         my_esa = esa;
6214         my_esa_len = rms_nam_esl(dirnam);
6215 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6216       }
6217 #endif
6218       my_esa[my_esa_len] = '\0';
6219       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6220         cp1 = strchr(my_esa,']');
6221         if (!cp1) cp1 = strchr(my_esa,'>');
6222         if (cp1) {  /* Should always be true */
6223           my_esa_len -= cp1 - my_esa - 1;
6224           memmove(my_esa, cp1 + 1, my_esa_len);
6225         }
6226       }
6227       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6228         /* Yep; check version while we're at it, if it's there. */
6229         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6230         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6231           /* Something other than .DIR[;1].  Bzzt. */
6232           sts = rms_free_search_context(&dirfab);
6233           PerlMem_free(esa);
6234           if (esal != NULL)
6235              PerlMem_free(esal);
6236           PerlMem_free(trndir);
6237           PerlMem_free(vmsdir);
6238           set_errno(ENOTDIR);
6239           set_vaxc_errno(RMS$_DIR);
6240           return NULL;
6241         }
6242       }
6243
6244       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6245         /* They provided at least the name; we added the type, if necessary, */
6246         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6247         sts = rms_free_search_context(&dirfab);
6248         PerlMem_free(trndir);
6249         PerlMem_free(esa);
6250         if (esal != NULL)
6251             PerlMem_free(esal);
6252         PerlMem_free(vmsdir);
6253         return buf;
6254       }
6255       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6256         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6257         *cp1 = '\0';
6258         my_esa_len -= 9;
6259       }
6260       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6261       if (cp1 == NULL) { /* should never happen */
6262         sts = rms_free_search_context(&dirfab);
6263         PerlMem_free(trndir);
6264         PerlMem_free(esa);
6265         if (esal != NULL)
6266             PerlMem_free(esal);
6267         PerlMem_free(vmsdir);
6268         return NULL;
6269       }
6270       term = *cp1;
6271       *cp1 = '\0';
6272       retlen = strlen(my_esa);
6273       cp1 = strrchr(my_esa,'.');
6274       /* ODS-5 directory specifications can have extra "." in them. */
6275       /* Fix-me, can not scan EFS file specifications backwards */
6276       while (cp1 != NULL) {
6277         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6278           break;
6279         else {
6280            cp1--;
6281            while ((cp1 > my_esa) && (*cp1 != '.'))
6282              cp1--;
6283         }
6284         if (cp1 == my_esa)
6285           cp1 = NULL;
6286       }
6287
6288       if ((cp1) != NULL) {
6289         /* There's more than one directory in the path.  Just roll back. */
6290         *cp1 = term;
6291         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6292       }
6293       else {
6294         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6295           /* Go back and expand rooted logical name */
6296           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6297 #ifdef NAM$M_NO_SHORT_UPCASE
6298           if (decc_efs_case_preserve)
6299             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6300 #endif
6301           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6302             sts = rms_free_search_context(&dirfab);
6303             PerlMem_free(esa);
6304             if (esal != NULL)
6305                 PerlMem_free(esal);
6306             PerlMem_free(trndir);
6307             PerlMem_free(vmsdir);
6308             set_errno(EVMSERR);
6309             set_vaxc_errno(dirfab.fab$l_sts);
6310             return NULL;
6311           }
6312
6313           /* This changes the length of the string of course */
6314           if (esal != NULL) {
6315               my_esa_len = rms_nam_esll(dirnam);
6316           } else {
6317               my_esa_len = rms_nam_esl(dirnam);
6318           }
6319
6320           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6321           cp1 = strstr(my_esa,"][");
6322           if (!cp1) cp1 = strstr(my_esa,"]<");
6323           dirlen = cp1 - my_esa;
6324           memcpy(buf, my_esa, dirlen);
6325           if (!strncmp(cp1+2,"000000]",7)) {
6326             buf[dirlen-1] = '\0';
6327             /* fix-me Not full ODS-5, just extra dots in directories for now */
6328             cp1 = buf + dirlen - 1;
6329             while (cp1 > buf)
6330             {
6331               if (*cp1 == '[')
6332                 break;
6333               if (*cp1 == '.') {
6334                 if (*(cp1-1) != '^')
6335                   break;
6336               }
6337               cp1--;
6338             }
6339             if (*cp1 == '.') *cp1 = ']';
6340             else {
6341               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6342               memmove(cp1+1,"000000]",7);
6343             }
6344           }
6345           else {
6346             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6347             buf[retlen] = '\0';
6348             /* Convert last '.' to ']' */
6349             cp1 = buf+retlen-1;
6350             while (*cp != '[') {
6351               cp1--;
6352               if (*cp1 == '.') {
6353                 /* Do not trip on extra dots in ODS-5 directories */
6354                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6355                 break;
6356               }
6357             }
6358             if (*cp1 == '.') *cp1 = ']';
6359             else {
6360               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6361               memmove(cp1+1,"000000]",7);
6362             }
6363           }
6364         }
6365         else {  /* This is a top-level dir.  Add the MFD to the path. */
6366           cp1 = strrchr(my_esa, ':');
6367           assert(cp1);
6368           memmove(buf, my_esa, cp1 - my_esa + 1);
6369           memmove(buf + (cp1 - my_esa) + 1, "[000000]", 8);
6370           memmove(buf + (cp1 - my_esa) + 9, cp1 + 2, retlen - (cp1 - my_esa + 2));
6371           buf[retlen + 7] = '\0';  /* We've inserted '000000]' */
6372         }
6373       }
6374       sts = rms_free_search_context(&dirfab);
6375       /* We've set up the string up through the filename.  Add the
6376          type and version, and we're done. */
6377       strcat(buf,".DIR;1");
6378
6379       /* $PARSE may have upcased filespec, so convert output to lower
6380        * case if input contained any lowercase characters. */
6381       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6382       PerlMem_free(trndir);
6383       PerlMem_free(esa);
6384       if (esal != NULL)
6385         PerlMem_free(esal);
6386       PerlMem_free(vmsdir);
6387       return buf;
6388     }
6389 }  /* end of int_fileify_dirspec() */
6390
6391
6392 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6393 static char *
6394 mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6395 {
6396     static char __fileify_retbuf[VMS_MAXRSS];
6397     char * fileified, *ret_spec, *ret_buf;
6398
6399     fileified = NULL;
6400     ret_buf = buf;
6401     if (ret_buf == NULL) {
6402         if (ts) {
6403             Newx(fileified, VMS_MAXRSS, char);
6404             if (fileified == NULL)
6405                 _ckvmssts(SS$_INSFMEM);
6406             ret_buf = fileified;
6407         } else {
6408             ret_buf = __fileify_retbuf;
6409         }
6410     }
6411
6412     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6413
6414     if (ret_spec == NULL) {
6415        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6416        if (fileified)
6417            Safefree(fileified);
6418     }
6419
6420     return ret_spec;
6421 }  /* end of do_fileify_dirspec() */
6422 /*}}}*/
6423
6424 /* External entry points */
6425 char *
6426 Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6427 {
6428     return do_fileify_dirspec(dir, buf, 0, NULL);
6429 }
6430
6431 char *
6432 Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6433 {
6434     return do_fileify_dirspec(dir, buf, 1, NULL);
6435 }
6436
6437 char *
6438 Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6439 {
6440     return do_fileify_dirspec(dir, buf, 0, utf8_fl);
6441 }
6442
6443 char *
6444 Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6445 {
6446     return do_fileify_dirspec(dir, buf, 1, utf8_fl);
6447 }
6448
6449 static char *
6450 int_pathify_dirspec_simple(const char * dir, char * buf,
6451     char * v_spec, int v_len, char * r_spec, int r_len,
6452     char * d_spec, int d_len, char * n_spec, int n_len,
6453     char * e_spec, int e_len, char * vs_spec, int vs_len)
6454 {
6455
6456     /* VMS specification - Try to do this the simple way */
6457     if ((v_len + r_len > 0) || (d_len > 0)) {
6458         int is_dir;
6459
6460         /* No name or extension component, already a directory */
6461         if ((n_len + e_len + vs_len) == 0) {
6462             strcpy(buf, dir);
6463             return buf;
6464         }
6465
6466         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6467         /* This results from catfile() being used instead of catdir() */
6468         /* So even though it should not work, we need to allow it */
6469
6470         /* If this is .DIR;1 then do a simple conversion */
6471         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6472         if (is_dir || (e_len == 0) && (d_len > 0)) {
6473              int len;
6474              len = v_len + r_len + d_len - 1;
6475              char dclose = d_spec[d_len - 1];
6476              memcpy(buf, dir, len);
6477              buf[len] = '.';
6478              len++;
6479              memcpy(&buf[len], n_spec, n_len);
6480              len += n_len;
6481              buf[len] = dclose;
6482              buf[len + 1] = '\0';
6483              return buf;
6484         }
6485
6486 #ifdef HAS_SYMLINK
6487         else if (d_len > 0) {
6488             /* In the olden days, a directory needed to have a .DIR */
6489             /* extension to be a valid directory, but now it could  */
6490             /* be a symbolic link */
6491             int len;
6492             len = v_len + r_len + d_len - 1;
6493             char dclose = d_spec[d_len - 1];
6494             memcpy(buf, dir, len);
6495             buf[len] = '.';
6496             len++;
6497             memcpy(&buf[len], n_spec, n_len);
6498             len += n_len;
6499             if (e_len > 0) {
6500                 if (decc_efs_charset) {
6501                     if (e_len == 4
6502                         && (toupper(e_spec[1]) == 'D')
6503                         && (toupper(e_spec[2]) == 'I')
6504                         && (toupper(e_spec[3]) == 'R')) {
6505
6506                         /* Corner case: directory spec with invalid version.
6507                          * Valid would have followed is_dir path above.
6508                          */
6509                         SETERRNO(ENOTDIR, RMS$_DIR);
6510                         return NULL;
6511                     }
6512                     else {
6513                         buf[len] = '^';
6514                         len++;
6515                         memcpy(&buf[len], e_spec, e_len);
6516                         len += e_len;
6517                     }
6518                 }
6519                 else {
6520                     SETERRNO(ENOTDIR, RMS$_DIR);
6521                     return NULL;
6522                 }
6523             }
6524             buf[len] = dclose;
6525             buf[len + 1] = '\0';
6526             return buf;
6527         }
6528 #else
6529         else {
6530             set_vaxc_errno(RMS$_DIR);
6531             set_errno(ENOTDIR);
6532             return NULL;
6533         }
6534 #endif
6535     }
6536     set_vaxc_errno(RMS$_DIR);
6537     set_errno(ENOTDIR);
6538     return NULL;
6539 }
6540
6541
6542 /* Internal routine to make sure or convert a directory to be in a */
6543 /* path specification.  No utf8 flag because it is not changed or used */
6544 static char *
6545 int_pathify_dirspec(const char *dir, char *buf)
6546 {
6547     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6548     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6549     char * exp_spec, *ret_spec;
6550     char * trndir;
6551     unsigned short int trnlnm_iter_count;
6552     STRLEN trnlen;
6553     int need_to_lower;
6554
6555     if (vms_debug_fileify) {
6556         if (dir == NULL)
6557             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6558         else
6559             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6560     }
6561
6562     /* We may need to lower case the result if we translated  */
6563     /* a logical name or got the current working directory */
6564     need_to_lower = 0;
6565
6566     if (!dir || !*dir) {
6567       set_errno(EINVAL);
6568       set_vaxc_errno(SS$_BADPARAM);
6569       return NULL;
6570     }
6571
6572     trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
6573     if (trndir == NULL)
6574         _ckvmssts_noperl(SS$_INSFMEM);
6575
6576     /* If no directory specified use the current default */
6577     if (*dir)
6578         my_strlcpy(trndir, dir, VMS_MAXRSS);
6579     else {
6580         getcwd(trndir, VMS_MAXRSS - 1);
6581         need_to_lower = 1;
6582     }
6583
6584     /* now deal with bare names that could be logical names */
6585     trnlnm_iter_count = 0;
6586     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6587            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6588         trnlnm_iter_count++;
6589         need_to_lower = 1;
6590         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6591             break;
6592         trnlen = strlen(trndir);
6593
6594         /* Trap simple rooted lnms, and return lnm:[000000] */
6595         if (!strcmp(trndir+trnlen-2,".]")) {
6596             my_strlcpy(buf, dir, VMS_MAXRSS);
6597             strcat(buf, ":[000000]");
6598             PerlMem_free(trndir);
6599
6600             if (vms_debug_fileify) {
6601                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6602             }
6603             return buf;
6604         }
6605     }
6606
6607     /* At this point we do not work with *dir, but the copy in  *trndir */
6608
6609     if (need_to_lower && !decc_efs_case_preserve) {
6610         /* Legacy mode, lower case the returned value */
6611         __mystrtolower(trndir);
6612     }
6613
6614
6615     /* Some special cases, '..', '.' */
6616     sts = 0;
6617     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6618        /* Force UNIX filespec */
6619        sts = 1;
6620
6621     } else {
6622         /* Is this Unix or VMS format? */
6623         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6624                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6625                              &e_len, &vs_spec, &vs_len);
6626         if (sts == 0) {
6627
6628             /* Just a filename? */
6629             if ((v_len + r_len + d_len) == 0) {
6630
6631                 /* Now we have a problem, this could be Unix or VMS */
6632                 /* We have to guess.  .DIR usually means VMS */
6633
6634                 /* In UNIX report mode, the .DIR extension is removed */
6635                 /* if one shows up, it is for a non-directory or a directory */
6636                 /* in EFS charset mode */
6637
6638                 /* So if we are in Unix report mode, assume that this */
6639                 /* is a relative Unix directory specification */
6640
6641                 sts = 1;
6642                 if (!decc_filename_unix_report && decc_efs_charset) {
6643                     int is_dir;
6644                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6645
6646                     if (is_dir) {
6647                         /* Traditional mode, assume .DIR is directory */
6648                         buf[0] = '[';
6649                         buf[1] = '.';
6650                         memcpy(&buf[2], n_spec, n_len);
6651                         buf[n_len + 2] = ']';
6652                         buf[n_len + 3] = '\0';
6653                         PerlMem_free(trndir);
6654                         if (vms_debug_fileify) {
6655                             fprintf(stderr,
6656                                     "int_pathify_dirspec: buf = %s\n",
6657                                     buf);
6658                         }
6659                         return buf;
6660                     }
6661                 }
6662             }
6663         }
6664     }
6665     if (sts == 0) {
6666         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6667             v_spec, v_len, r_spec, r_len,
6668             d_spec, d_len, n_spec, n_len,
6669             e_spec, e_len, vs_spec, vs_len);
6670
6671         if (ret_spec != NULL) {
6672             PerlMem_free(trndir);
6673             if (vms_debug_fileify) {
6674                 fprintf(stderr,
6675                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6676             }
6677             return ret_spec;
6678         }
6679
6680         /* Simple way did not work, which means that a logical name */
6681         /* was present for the directory specification.             */
6682         /* Need to use an rmsexpand variant to decode it completely */
6683         exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
6684         if (exp_spec == NULL)
6685             _ckvmssts_noperl(SS$_INSFMEM);
6686
6687         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6688         if (ret_spec != NULL) {
6689             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6690                                  &r_spec, &r_len, &d_spec, &d_len,
6691                                  &n_spec, &n_len, &e_spec,
6692                                  &e_len, &vs_spec, &vs_len);
6693             if (sts == 0) {
6694                 ret_spec = int_pathify_dirspec_simple(
6695                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6696                     d_spec, d_len, n_spec, n_len,
6697                     e_spec, e_len, vs_spec, vs_len);
6698
6699                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6700                     /* Legacy mode, lower case the returned value */
6701                     __mystrtolower(ret_spec);
6702                 }
6703             } else {
6704                 set_vaxc_errno(RMS$_DIR);
6705                 set_errno(ENOTDIR);
6706                 ret_spec = NULL;
6707             }
6708         }
6709         PerlMem_free(exp_spec);
6710         PerlMem_free(trndir);
6711         if (vms_debug_fileify) {
6712             if (ret_spec == NULL)
6713                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6714             else
6715                 fprintf(stderr,
6716                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6717         }
6718         return ret_spec;
6719
6720     } else {
6721         /* Unix specification, Could be trivial conversion, */
6722         /* but have to deal with trailing '.dir' or extra '.' */
6723
6724         char * lastdot;
6725         char * lastslash;
6726         int is_dir;
6727         STRLEN dir_len = strlen(trndir);
6728
6729         lastslash = strrchr(trndir, '/');
6730         if (lastslash == NULL)
6731             lastslash = trndir;
6732         else
6733             lastslash++;
6734
6735         lastdot = NULL;
6736
6737         /* '..' or '.' are valid directory components */
6738         is_dir = 0;
6739         if (lastslash[0] == '.') {
6740             if (lastslash[1] == '\0') {
6741                is_dir = 1;
6742             } else if (lastslash[1] == '.') {
6743                 if (lastslash[2] == '\0') {
6744                     is_dir = 1;
6745                 } else {
6746                     /* And finally allow '...' */
6747                     if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6748                         is_dir = 1;
6749                     }
6750                 }
6751             }
6752         }
6753
6754         if (!is_dir) {
6755            lastdot = strrchr(lastslash, '.');
6756         }
6757         if (lastdot != NULL) {
6758             STRLEN e_len;
6759              /* '.dir' is discarded, and any other '.' is invalid */
6760             e_len = strlen(lastdot);
6761
6762             is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6763
6764             if (is_dir) {
6765                 dir_len = dir_len - 4;
6766             }
6767         }
6768
6769         my_strlcpy(buf, trndir, VMS_MAXRSS);
6770         if (buf[dir_len - 1] != '/') {
6771             buf[dir_len] = '/';
6772             buf[dir_len + 1] = '\0';
6773         }
6774
6775         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6776         if (!decc_efs_charset) {
6777              int dir_start = 0;
6778              char * str = buf;
6779              if (str[0] == '.') {
6780                  char * dots = str;
6781                  int cnt = 1;
6782                  while ((dots[cnt] == '.') && (cnt < 3))
6783                      cnt++;
6784                  if (cnt <= 3) {
6785                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6786                          dir_start = 1;
6787                          str += cnt;
6788                      }
6789                  }
6790              }
6791              for (; *str; ++str) {
6792                  while (*str == '/') {
6793                      dir_start = 1;
6794                      *str++;
6795                  }
6796                  if (dir_start) {
6797
6798                      /* Have to skip up to three dots which could be */
6799                      /* directories, 3 dots being a VMS extension for Perl */
6800                      char * dots = str;
6801                      int cnt = 0;
6802                      while ((dots[cnt] == '.') && (cnt < 3)) {
6803                          cnt++;
6804                      }
6805                      if (dots[cnt] == '\0')
6806                          break;
6807                      if ((cnt > 1) && (dots[cnt] != '/')) {
6808                          dir_start = 0;
6809                      } else {
6810                          str += cnt;
6811                      }
6812
6813                      /* too many dots? */
6814                      if ((cnt == 0) || (cnt > 3)) {
6815                          dir_start = 0;
6816                      }
6817                  }
6818                  if (!dir_start && (*str == '.')) {
6819                      *str = '_';
6820                  }
6821              }
6822         }
6823         PerlMem_free(trndir);
6824         ret_spec = buf;
6825         if (vms_debug_fileify) {
6826             if (ret_spec == NULL)
6827                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6828             else
6829                 fprintf(stderr,
6830                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6831         }
6832         return ret_spec;
6833     }
6834 }
6835
6836 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6837 static char *
6838 mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6839 {
6840     static char __pathify_retbuf[VMS_MAXRSS];
6841     char * pathified, *ret_spec, *ret_buf;
6842
6843     pathified = NULL;
6844     ret_buf = buf;
6845     if (ret_buf == NULL) {
6846         if (ts) {
6847             Newx(pathified, VMS_MAXRSS, char);
6848             if (pathified == NULL)
6849                 _ckvmssts(SS$_INSFMEM);
6850             ret_buf = pathified;
6851         } else {
6852             ret_buf = __pathify_retbuf;
6853         }
6854     }
6855
6856     ret_spec = int_pathify_dirspec(dir, ret_buf);
6857
6858     if (ret_spec == NULL) {
6859        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6860        if (pathified)
6861            Safefree(pathified);
6862     }
6863
6864     return ret_spec;
6865
6866 }  /* end of do_pathify_dirspec() */
6867
6868
6869 /* External entry points */
6870 char *
6871 Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6872 {
6873     return do_pathify_dirspec(dir, buf, 0, NULL);
6874 }
6875
6876 char *
6877 Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6878 {
6879     return do_pathify_dirspec(dir, buf, 1, NULL);
6880 }
6881
6882 char *
6883 Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6884 {
6885     return do_pathify_dirspec(dir, buf, 0, utf8_fl);
6886 }
6887
6888 char *
6889 Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6890 {
6891     return do_pathify_dirspec(dir, buf, 1, utf8_fl);
6892 }
6893
6894 /* Internal tounixspec routine that does not use a thread context */
6895 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6896 static char *
6897 int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6898 {
6899   char *dirend, *cp1, *cp3, *tmp;
6900   const char *cp2;
6901   int dirlen;
6902   unsigned short int trnlnm_iter_count;
6903   int cmp_rslt, outchars_added;
6904   if (utf8_fl != NULL)
6905     *utf8_fl = 0;
6906
6907   if (vms_debug_fileify) {
6908       if (spec == NULL)
6909           fprintf(stderr, "int_tounixspec: spec = NULL\n");
6910       else
6911           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6912   }
6913
6914
6915   if (spec == NULL) {
6916       set_errno(EINVAL);
6917       set_vaxc_errno(SS$_BADPARAM);
6918       return NULL;
6919   }
6920   if (strlen(spec) > (VMS_MAXRSS-1)) {
6921       set_errno(E2BIG);
6922       set_vaxc_errno(SS$_BUFFEROVF);
6923       return NULL;
6924   }
6925
6926   /* New VMS specific format needs translation
6927    * glob passes filenames with trailing '\n' and expects this preserved.
6928    */
6929   if (decc_posix_compliant_pathnames) {
6930     if (strncmp(spec, "\"^UP^", 5) == 0) {
6931       char * uspec;
6932       char *tunix;
6933       int tunix_len;
6934       int nl_flag;
6935
6936       tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
6937       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6938       tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
6939       nl_flag = 0;
6940       if (tunix[tunix_len - 1] == '\n') {
6941         tunix[tunix_len - 1] = '\"';
6942         tunix[tunix_len] = '\0';
6943         tunix_len--;
6944         nl_flag = 1;
6945       }
6946       uspec = decc$translate_vms(tunix);
6947       PerlMem_free(tunix);
6948       if ((int)uspec > 0) {
6949         my_strlcpy(rslt, uspec, VMS_MAXRSS);
6950         if (nl_flag) {
6951           strcat(rslt,"\n");
6952         }
6953         else {
6954           /* If we can not translate it, makemaker wants as-is */
6955           my_strlcpy(rslt, spec, VMS_MAXRSS);
6956         }
6957         return rslt;
6958       }
6959     }
6960   }
6961
6962   cmp_rslt = 0; /* Presume VMS */
6963   cp1 = strchr(spec, '/');
6964   if (cp1 == NULL)
6965     cmp_rslt = 0;
6966
6967     /* Look for EFS ^/ */
6968     if (decc_efs_charset) {
6969       while (cp1 != NULL) {
6970         cp2 = cp1 - 1;
6971         if (*cp2 != '^') {
6972           /* Found illegal VMS, assume UNIX */
6973           cmp_rslt = 1;
6974           break;
6975         }
6976       cp1++;
6977       cp1 = strchr(cp1, '/');
6978     }
6979   }
6980
6981   /* Look for "." and ".." */
6982   if (decc_filename_unix_report) {
6983     if (spec[0] == '.') {
6984       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6985         cmp_rslt = 1;
6986       }
6987       else {
6988         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6989           cmp_rslt = 1;
6990         }
6991       }
6992     }
6993   }
6994
6995   cp1 = rslt;
6996   cp2 = spec;
6997
6998   /* This is already UNIX or at least nothing VMS understands,
6999    * so all we can reasonably do is unescape extended chars.
7000    */
7001   if (cmp_rslt) {
7002     while (*cp2) {
7003         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7004         cp1 += outchars_added;
7005     }
7006     *cp1 = '\0';
7007     if (vms_debug_fileify) {
7008         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7009     }
7010     return rslt;
7011   }
7012
7013   dirend = strrchr(spec,']');
7014   if (dirend == NULL) dirend = strrchr(spec,'>');
7015   if (dirend == NULL) dirend = strchr(spec,':');
7016   if (dirend == NULL) {
7017     while (*cp2) {
7018         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7019         cp1 += outchars_added;
7020     }
7021     *cp1 = '\0';
7022     if (vms_debug_fileify) {
7023         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7024     }
7025     return rslt;
7026   }
7027
7028   /* Special case 1 - sys$posix_root = / */
7029   if (!decc_disable_posix_root) {
7030     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7031       *cp1 = '/';
7032       cp1++;
7033       cp2 = cp2 + 15;
7034       }
7035   }
7036
7037   /* Special case 2 - Convert NLA0: to /dev/null */
7038   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7039   if (cmp_rslt == 0) {
7040     strcpy(rslt, "/dev/null");
7041     cp1 = cp1 + 9;
7042     cp2 = cp2 + 5;
7043     if (spec[6] != '\0') {
7044       cp1[9] = '/';
7045       cp1++;
7046       cp2++;
7047     }
7048   }
7049
7050    /* Also handle special case "SYS$SCRATCH:" */
7051   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7052   tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
7053   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7054   if (cmp_rslt == 0) {
7055   int islnm;
7056
7057     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7058     if (!islnm) {
7059       strcpy(rslt, "/tmp");
7060       cp1 = cp1 + 4;
7061       cp2 = cp2 + 12;
7062       if (spec[12] != '\0') {
7063         cp1[4] = '/';
7064         cp1++;
7065         cp2++;
7066       }
7067     }
7068   }
7069
7070   if (*cp2 != '[' && *cp2 != '<') {
7071     *(cp1++) = '/';
7072   }
7073   else {  /* the VMS spec begins with directories */
7074     cp2++;
7075     if (*cp2 == ']' || *cp2 == '>') {
7076       *(cp1++) = '.';
7077       *(cp1++) = '/';
7078     }
7079     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7080       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7081         PerlMem_free(tmp);
7082         if (vms_debug_fileify) {
7083             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7084         }
7085         return NULL;
7086       }
7087       trnlnm_iter_count = 0;
7088       do {
7089         cp3 = tmp;
7090         while (*cp3 != ':' && *cp3) cp3++;
7091         *(cp3++) = '\0';
7092         if (strchr(cp3,']') != NULL) break;
7093         trnlnm_iter_count++;
7094         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7095       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7096       cp1 = rslt;
7097       cp3 = tmp;
7098       *(cp1++) = '/';
7099       while (*cp3) {
7100         *(cp1++) = *(cp3++);
7101         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7102             PerlMem_free(tmp);
7103             set_errno(ENAMETOOLONG);
7104             set_vaxc_errno(SS$_BUFFEROVF);
7105             if (vms_debug_fileify) {
7106                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7107             }
7108             return NULL; /* No room */
7109         }
7110       }
7111       *(cp1++) = '/';
7112     }
7113     if ((*cp2 == '^')) {
7114         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7115         cp1 += outchars_added;
7116     }
7117     else if ( *cp2 == '.') {
7118       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7119         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7120         cp2 += 3;
7121       }
7122       else cp2++;
7123     }
7124   }
7125   PerlMem_free(tmp);
7126   for (; cp2 <= dirend; cp2++) {
7127     if ((*cp2 == '^')) {
7128         /* EFS file escape -- unescape it. */
7129         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added) - 1;
7130         cp1 += outchars_added;
7131     }
7132     else if (*cp2 == ':') {
7133       *(cp1++) = '/';
7134       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7135     }
7136     else if (*cp2 == ']' || *cp2 == '>') {
7137       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7138     }
7139     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7140       *(cp1++) = '/';
7141       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7142         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7143                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7144         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7145             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7146       }
7147       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7148         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7149         cp2 += 2;
7150       }
7151     }
7152     else if (*cp2 == '-') {
7153       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7154         while (*cp2 == '-') {
7155           cp2++;
7156           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7157         }
7158         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7159                                                          /* filespecs like */
7160           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7161           if (vms_debug_fileify) {
7162               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7163           }
7164           return NULL;
7165         }
7166       }
7167       else *(cp1++) = *cp2;
7168     }
7169     else *(cp1++) = *cp2;
7170   }
7171   /* Translate the rest of the filename. */
7172   while (*cp2) {
7173       int dot_seen = 0;
7174       switch(*cp2) {
7175       /* Fixme - for compatibility with the CRTL we should be removing */
7176       /* spaces from the file specifications, but this may show that */
7177       /* some tests that were appearing to pass are not really passing */
7178       case '%':
7179           cp2++;
7180           *(cp1++) = '?';
7181           break;
7182       case '^':
7183           cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7184           cp1 += outchars_added;
7185           break;
7186       case ';':
7187           if (decc_filename_unix_no_version) {
7188               /* Easy, drop the version */
7189               while (*cp2)
7190                   cp2++;
7191               break;
7192           } else {
7193               /* Punt - passing the version as a dot will probably */
7194               /* break perl in weird ways, but so did passing */
7195               /* through the ; as a version.  Follow the CRTL and */
7196               /* hope for the best. */
7197               cp2++;
7198               *(cp1++) = '.';
7199           }
7200           break;
7201       case '.':
7202           if (dot_seen) {
7203               /* We will need to fix this properly later */
7204               /* As Perl may be installed on an ODS-5 volume, but not */
7205               /* have the EFS_CHARSET enabled, it still may encounter */
7206               /* filenames with extra dots in them, and a precedent got */
7207               /* set which allowed them to work, that we will uphold here */
7208               /* If extra dots are present in a name and no ^ is on them */
7209               /* VMS assumes that the first one is the extension delimiter */
7210               /* the rest have an implied ^. */
7211
7212               /* this is also a conflict as the . is also a version */
7213               /* delimiter in VMS, */
7214
7215               *(cp1++) = *(cp2++);
7216               break;
7217           }
7218           dot_seen = 1;
7219           /* This is an extension */
7220           if (decc_readdir_dropdotnotype) {
7221               cp2++;
7222               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7223                   /* Drop the dot for the extension */
7224                   break;
7225               } else {
7226                   *(cp1++) = '.';
7227               }
7228               break;
7229           }
7230       default:
7231           *(cp1++) = *(cp2++);
7232       }
7233   }
7234   *cp1 = '\0';
7235
7236   /* This still leaves /000000/ when working with a
7237    * VMS device root or concealed root.
7238    */
7239   {
7240       int ulen;
7241       char * zeros;
7242
7243       ulen = strlen(rslt);
7244
7245       /* Get rid of "000000/ in rooted filespecs */
7246       if (ulen > 7) {
7247         zeros = strstr(rslt, "/000000/");
7248         if (zeros != NULL) {
7249           int mlen;
7250           mlen = ulen - (zeros - rslt) - 7;
7251           memmove(zeros, &zeros[7], mlen);
7252           ulen = ulen - 7;
7253           rslt[ulen] = '\0';
7254         }
7255       }
7256   }
7257
7258   if (vms_debug_fileify) {
7259       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7260   }
7261   return rslt;
7262
7263 }  /* end of int_tounixspec() */
7264
7265
7266 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7267 static char *
7268 mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7269 {
7270     static char __tounixspec_retbuf[VMS_MAXRSS];
7271     char * unixspec, *ret_spec, *ret_buf;
7272
7273     unixspec = NULL;
7274     ret_buf = buf;
7275     if (ret_buf == NULL) {
7276         if (ts) {
7277             Newx(unixspec, VMS_MAXRSS, char);
7278             if (unixspec == NULL)
7279                 _ckvmssts(SS$_INSFMEM);
7280             ret_buf = unixspec;
7281         } else {
7282             ret_buf = __tounixspec_retbuf;
7283         }
7284     }
7285
7286     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7287
7288     if (ret_spec == NULL) {
7289        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7290        if (unixspec)
7291            Safefree(unixspec);
7292     }
7293
7294     return ret_spec;
7295
7296 }  /* end of do_tounixspec() */
7297 /*}}}*/
7298 /* External entry points */
7299 char *
7300 Perl_tounixspec(pTHX_ const char *spec, char *buf)
7301 {
7302     return do_tounixspec(spec, buf, 0, NULL);
7303 }
7304
7305 char *
7306 Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7307 {
7308     return do_tounixspec(spec,buf,1, NULL);
7309 }
7310
7311 char *
7312 Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7313 {
7314     return do_tounixspec(spec,buf,0, utf8_fl);
7315 }
7316
7317 char *
7318 Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7319 {
7320     return do_tounixspec(spec,buf,1, utf8_fl);
7321 }
7322
7323 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7324
7325 /*
7326  This procedure is used to identify if a path is based in either
7327  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7328  it returns the OpenVMS format directory for it.
7329
7330  It is expecting specifications of only '/' or '/xxxx/'
7331
7332  If a posix root does not exist, or 'xxxx' is not a directory
7333  in the posix root, it returns a failure.
7334
7335  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7336
7337  It is used only internally by posix_to_vmsspec_hardway().
7338  */
7339
7340 static int
7341 posix_root_to_vms(char *vmspath, int vmspath_len,
7342                   const char *unixpath, const int * utf8_fl)
7343 {
7344   int sts;
7345   struct FAB myfab = cc$rms_fab;
7346   rms_setup_nam(mynam);
7347   struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7348   struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7349   char * esa, * esal, * rsa, * rsal;
7350   int dir_flag;
7351   int unixlen;
7352
7353   dir_flag = 0;
7354   vmspath[0] = '\0';
7355   unixlen = strlen(unixpath);
7356   if (unixlen == 0) {
7357     return RMS$_FNF;
7358   }
7359
7360 #if __CRTL_VER >= 80200000
7361   /* If not a posix spec already, convert it */
7362   if (decc_posix_compliant_pathnames) {
7363     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7364       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7365     }
7366     else {
7367       /* This is already a VMS specification, no conversion */
7368       unixlen--;
7369       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7370     }
7371   }
7372   else
7373 #endif
7374   {
7375      int path_len;
7376      int i,j;
7377
7378      /* Check to see if this is under the POSIX root */
7379      if (decc_disable_posix_root) {
7380         return RMS$_FNF;
7381      }
7382
7383      /* Skip leading / */
7384      if (unixpath[0] == '/') {
7385         unixpath++;
7386         unixlen--;
7387      }
7388
7389
7390      strcpy(vmspath,"SYS$POSIX_ROOT:");
7391
7392      /* If this is only the / , or blank, then... */
7393      if (unixpath[0] == '\0') {
7394         /* by definition, this is the answer */
7395         return SS$_NORMAL;
7396      }
7397
7398      /* Need to look up a directory */
7399      vmspath[15] = '[';
7400      vmspath[16] = '\0';
7401
7402      /* Copy and add '^' escape characters as needed */
7403      j = 16;
7404      i = 0;
7405      while (unixpath[i] != 0) {
7406      int k;
7407
7408         j += copy_expand_unix_filename_escape
7409             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7410         i += k;
7411      }
7412
7413      path_len = strlen(vmspath);
7414      if (vmspath[path_len - 1] == '/')
7415         path_len--;
7416      vmspath[path_len] = ']';
7417      path_len++;
7418      vmspath[path_len] = '\0';
7419
7420   }
7421   vmspath[vmspath_len] = 0;
7422   if (unixpath[unixlen - 1] == '/')
7423   dir_flag = 1;
7424   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7425   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7426   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7427   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7428   rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7429   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7430   rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7431   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7432   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7433   rms_bind_fab_nam(myfab, mynam);
7434   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7435   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7436   if (decc_efs_case_preserve)
7437     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7438 #ifdef NAML$M_OPEN_SPECIAL
7439   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7440 #endif
7441
7442   /* Set up the remaining naml fields */
7443   sts = sys$parse(&myfab);
7444
7445   /* It failed! Try again as a UNIX filespec */
7446   if (!(sts & 1)) {
7447     PerlMem_free(esal);
7448     PerlMem_free(esa);
7449     PerlMem_free(rsal);
7450     PerlMem_free(rsa);
7451     return sts;
7452   }
7453
7454    /* get the Device ID and the FID */
7455    sts = sys$search(&myfab);
7456
7457    /* These are no longer needed */
7458    PerlMem_free(esa);
7459    PerlMem_free(rsal);
7460    PerlMem_free(rsa);
7461
7462    /* on any failure, returned the POSIX ^UP^ filespec */
7463    if (!(sts & 1)) {
7464       PerlMem_free(esal);
7465       return sts;
7466    }
7467    specdsc.dsc$a_pointer = vmspath;
7468    specdsc.dsc$w_length = vmspath_len;
7469
7470    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7471    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7472    sts = lib$fid_to_name
7473       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7474
7475   /* on any failure, returned the POSIX ^UP^ filespec */
7476   if (!(sts & 1)) {
7477      /* This can happen if user does not have permission to read directories */
7478      if (strncmp(unixpath,"\"^UP^",5) != 0)
7479        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7480      else
7481        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7482   }
7483   else {
7484     vmspath[specdsc.dsc$w_length] = 0;
7485
7486     /* Are we expecting a directory? */
7487     if (dir_flag != 0) {
7488     int i;
7489     char *eptr;
7490
7491       eptr = NULL;
7492
7493       i = specdsc.dsc$w_length - 1;
7494       while (i > 0) {
7495       int zercnt;
7496         zercnt = 0;
7497         /* Version must be '1' */
7498         if (vmspath[i--] != '1')
7499           break;
7500         /* Version delimiter is one of ".;" */
7501         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7502           break;
7503         i--;
7504         if (vmspath[i--] != 'R')
7505           break;
7506         if (vmspath[i--] != 'I')
7507           break;
7508         if (vmspath[i--] != 'D')
7509           break;
7510         if (vmspath[i--] != '.')
7511           break;
7512         eptr = &vmspath[i+1];
7513         while (i > 0) {
7514           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7515             if (vmspath[i-1] != '^') {
7516               if (zercnt != 6) {
7517                 *eptr = vmspath[i];
7518                 eptr[1] = '\0';
7519                 vmspath[i] = '.';
7520                 break;
7521               }
7522               else {
7523                 /* Get rid of 6 imaginary zero directory filename */
7524                 vmspath[i+1] = '\0';
7525               }
7526             }
7527           }
7528           if (vmspath[i] == '0')
7529             zercnt++;
7530           else
7531             zercnt = 10;
7532           i--;
7533         }
7534         break;
7535       }
7536     }
7537   }
7538   PerlMem_free(esal);
7539   return sts;
7540 }
7541
7542 /* /dev/mumble needs to be handled special.
7543    /dev/null becomes NLA0:, And there is the potential for other stuff
7544    like /dev/tty which may need to be mapped to something.
7545 */
7546
7547 static int
7548 slash_dev_special_to_vms(const char *unixptr, char *vmspath, int vmspath_len)
7549 {
7550     char * nextslash;
7551     int len;
7552     int cmp;
7553
7554     unixptr += 4;
7555     nextslash = strchr(unixptr, '/');
7556     len = strlen(unixptr);
7557     if (nextslash != NULL)
7558         len = nextslash - unixptr;
7559     cmp = strncmp("null", unixptr, 5);
7560     if (cmp == 0) {
7561         if (vmspath_len >= 6) {
7562             strcpy(vmspath, "_NLA0:");
7563             return SS$_NORMAL;
7564         }
7565     }
7566     return 0;
7567 }
7568
7569
7570 /* The built in routines do not understand perl's special needs, so
7571     doing a manual conversion from UNIX to VMS
7572
7573     If the utf8_fl is not null and points to a non-zero value, then
7574     treat 8 bit characters as UTF-8.
7575
7576     The sequence starting with '$(' and ending with ')' will be passed
7577     through with out interpretation instead of being escaped.
7578
7579   */
7580 static int
7581 posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath,
7582                          int dir_flag, int * utf8_fl)
7583 {
7584
7585   char *esa;
7586   const char *unixptr;
7587   const char *unixend;
7588   char *vmsptr;
7589   const char *lastslash;
7590   const char *lastdot;
7591   int unixlen;
7592   int vmslen;
7593   int dir_start;
7594   int dir_dot;
7595   int quoted;
7596   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7597   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7598
7599   if (utf8_fl != NULL)
7600     *utf8_fl = 0;
7601
7602   unixptr = unixpath;
7603   dir_dot = 0;
7604
7605   /* Ignore leading "/" characters */
7606   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7607     unixptr++;
7608   }
7609   unixlen = strlen(unixptr);
7610
7611   /* Do nothing with blank paths */
7612   if (unixlen == 0) {
7613     vmspath[0] = '\0';
7614     return SS$_NORMAL;
7615   }
7616
7617   quoted = 0;
7618   /* This could have a "^UP^ on the front */
7619   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7620     quoted = 1;
7621     unixptr+= 5;
7622     unixlen-= 5;
7623   }
7624
7625   lastslash = strrchr(unixptr,'/');
7626   lastdot = strrchr(unixptr,'.');
7627   unixend = strrchr(unixptr,'\"');
7628   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7629     unixend = unixptr + unixlen;
7630   }
7631
7632   /* last dot is last dot or past end of string */
7633   if (lastdot == NULL)
7634     lastdot = unixptr + unixlen;
7635
7636   /* if no directories, set last slash to beginning of string */
7637   if (lastslash == NULL) {
7638     lastslash = unixptr;
7639   }
7640   else {
7641     /* Watch out for trailing "." after last slash, still a directory */
7642     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7643       lastslash = unixptr + unixlen;
7644     }
7645
7646     /* Watch out for trailing ".." after last slash, still a directory */
7647     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7648       lastslash = unixptr + unixlen;
7649     }
7650
7651     /* dots in directories are aways escaped */
7652     if (lastdot < lastslash)
7653       lastdot = unixptr + unixlen;
7654   }
7655
7656   /* if (unixptr < lastslash) then we are in a directory */
7657
7658   dir_start = 0;
7659
7660   vmsptr = vmspath;
7661   vmslen = 0;
7662
7663   /* Start with the UNIX path */
7664   if (*unixptr != '/') {
7665     /* relative paths */
7666
7667     /* If allowing logical names on relative pathnames, then handle here */
7668     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7669         !decc_posix_compliant_pathnames) {
7670     char * nextslash;
7671     int seg_len;
7672     char * trn;
7673     int islnm;
7674
7675         /* Find the next slash */
7676         nextslash = strchr(unixptr,'/');
7677
7678         esa = (char *)PerlMem_malloc(vmspath_len);
7679         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7680
7681         trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7682         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7683
7684         if (nextslash != NULL) {
7685
7686             seg_len = nextslash - unixptr;
7687             memcpy(esa, unixptr, seg_len);
7688             esa[seg_len] = 0;
7689         }
7690         else {
7691             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7692         }
7693         /* trnlnm(section) */
7694         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7695
7696         if (islnm) {
7697             /* Now fix up the directory */
7698
7699             /* Split up the path to find the components */
7700             sts = vms_split_path
7701                   (trn,
7702                    &v_spec,
7703                    &v_len,
7704                    &r_spec,
7705                    &r_len,
7706                    &d_spec,
7707                    &d_len,
7708                    &n_spec,
7709                    &n_len,
7710                    &e_spec,
7711                    &e_len,
7712                    &vs_spec,
7713                    &vs_len);
7714
7715             while (sts == 0) {
7716             int cmp;
7717
7718                 /* A logical name must be a directory  or the full
7719                    specification.  It is only a full specification if
7720                    it is the only component */
7721                 if ((unixptr[seg_len] == '\0') ||
7722                     (unixptr[seg_len+1] == '\0')) {
7723
7724                     /* Is a directory being required? */
7725                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7726                         /* Not a logical name */
7727                         break;
7728                     }
7729
7730
7731                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7732                         /* This must be a directory */
7733                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7734                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7735                             vmsptr[vmslen] = ':';
7736                             vmslen++;
7737                             vmsptr[vmslen] = '\0';
7738                             return SS$_NORMAL;
7739                         }
7740                     }
7741
7742                 }
7743
7744
7745                 /* must be dev/directory - ignore version */
7746                 if ((n_len + e_len) != 0)
7747                     break;
7748
7749                 /* transfer the volume */
7750                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7751                     memcpy(vmsptr, v_spec, v_len);
7752                     vmsptr += v_len;
7753                     vmsptr[0] = '\0';
7754                     vmslen += v_len;
7755                 }
7756
7757                 /* unroot the rooted directory */
7758                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7759                     r_spec[0] = '[';
7760                     r_spec[r_len - 1] = ']';
7761
7762                     /* This should not be there, but nothing is perfect */
7763                     if (r_len > 9) {
7764                         cmp = strcmp(&r_spec[1], "000000.");
7765                         if (cmp == 0) {
7766                             r_spec += 7;
7767                             r_spec[7] = '[';
7768                             r_len -= 7;
7769                             if (r_len == 2)
7770                                 r_len = 0;
7771                         }
7772                     }
7773                     if (r_len > 0) {
7774                         memcpy(vmsptr, r_spec, r_len);
7775                         vmsptr += r_len;
7776                         vmslen += r_len;
7777                         vmsptr[0] = '\0';
7778                     }
7779                 }
7780                 /* Bring over the directory. */
7781                 if ((d_len > 0) &&
7782                     ((d_len + vmslen) < vmspath_len)) {
7783                     d_spec[0] = '[';
7784                     d_spec[d_len - 1] = ']';
7785                     if (d_len > 9) {
7786                         cmp = strcmp(&d_spec[1], "000000.");
7787                         if (cmp == 0) {
7788                             d_spec += 7;
7789                             d_spec[7] = '[';
7790                             d_len -= 7;
7791                             if (d_len == 2)
7792                                 d_len = 0;
7793                         }
7794                     }
7795
7796                     if (r_len > 0) {
7797                         /* Remove the redundant root */
7798                         if (r_len > 0) {
7799                             /* remove the ][ */
7800                             vmsptr--;
7801                             vmslen--;
7802                             d_spec++;
7803                             d_len--;
7804                         }
7805                         memcpy(vmsptr, d_spec, d_len);
7806                             vmsptr += d_len;
7807                             vmslen += d_len;
7808                             vmsptr[0] = '\0';
7809                     }
7810                 }
7811                 break;
7812             }
7813         }
7814
7815         PerlMem_free(esa);
7816         PerlMem_free(trn);
7817     }
7818
7819     if (lastslash > unixptr) {
7820     int dotdir_seen;
7821
7822       /* skip leading ./ */
7823       dotdir_seen = 0;
7824       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7825         dotdir_seen = 1;
7826         unixptr++;
7827         unixptr++;
7828       }
7829
7830       /* Are we still in a directory? */
7831       if (unixptr <= lastslash) {
7832         *vmsptr++ = '[';
7833         vmslen = 1;
7834         dir_start = 1;
7835
7836         /* if not backing up, then it is relative forward. */
7837         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7838               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7839           *vmsptr++ = '.';
7840           vmslen++;
7841           dir_dot = 1;
7842           }
7843        }
7844        else {
7845          if (dotdir_seen) {
7846            /* Perl wants an empty directory here to tell the difference
7847             * between a DCL command and a filename
7848             */
7849           *vmsptr++ = '[';
7850           *vmsptr++ = ']';
7851           vmslen = 2;
7852         }
7853       }
7854     }
7855     else {
7856       /* Handle two special files . and .. */
7857       if (unixptr[0] == '.') {
7858         if (&unixptr[1] == unixend) {
7859           *vmsptr++ = '[';
7860           *vmsptr++ = ']';
7861           vmslen += 2;
7862           *vmsptr++ = '\0';
7863           return SS$_NORMAL;
7864         }
7865         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7866           *vmsptr++ = '[';
7867           *vmsptr++ = '-';
7868           *vmsptr++ = ']';
7869           vmslen += 3;
7870           *vmsptr++ = '\0';
7871           return SS$_NORMAL;
7872         }
7873       }
7874     }
7875   }
7876   else {        /* Absolute PATH handling */
7877   int sts;
7878   char * nextslash;
7879   int seg_len;
7880     /* Need to find out where root is */
7881
7882     /* In theory, this procedure should never get an absolute POSIX pathname
7883      * that can not be found on the POSIX root.
7884      * In practice, that can not be relied on, and things will show up
7885      * here that are a VMS device name or concealed logical name instead.
7886      * So to make things work, this procedure must be tolerant.
7887      */
7888     esa = (char *)PerlMem_malloc(vmspath_len);
7889     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7890
7891     sts = SS$_NORMAL;
7892     nextslash = strchr(&unixptr[1],'/');
7893     seg_len = 0;
7894     if (nextslash != NULL) {
7895       int cmp;
7896       seg_len = nextslash - &unixptr[1];
7897       my_strlcpy(vmspath, unixptr, seg_len + 2);
7898       cmp = 1;
7899       if (seg_len == 3) {
7900         cmp = strncmp(vmspath, "dev", 4);
7901         if (cmp == 0) {
7902             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7903             if (sts == SS$_NORMAL)
7904                 return SS$_NORMAL;
7905         }
7906       }
7907       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7908     }
7909
7910     if ($VMS_STATUS_SUCCESS(sts)) {
7911       /* This is verified to be a real path */
7912
7913       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7914       if ($VMS_STATUS_SUCCESS(sts)) {
7915         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
7916         vmsptr = vmspath + vmslen;
7917         unixptr++;
7918         if (unixptr < lastslash) {
7919         char * rptr;
7920           vmsptr--;
7921           *vmsptr++ = '.';
7922           dir_start = 1;
7923           dir_dot = 1;
7924           if (vmslen > 7) {
7925           int cmp;
7926             rptr = vmsptr - 7;
7927             cmp = strcmp(rptr,"000000.");
7928             if (cmp == 0) {
7929               vmslen -= 7;
7930               vmsptr -= 7;
7931               vmsptr[1] = '\0';
7932             } /* removing 6 zeros */
7933           } /* vmslen < 7, no 6 zeros possible */
7934         } /* Not in a directory */
7935       } /* Posix root found */
7936       else {
7937         /* No posix root, fall back to default directory */
7938         strcpy(vmspath, "SYS$DISK:[");
7939         vmsptr = &vmspath[10];
7940         vmslen = 10;
7941         if (unixptr > lastslash) {
7942            *vmsptr = ']';
7943            vmsptr++;
7944            vmslen++;
7945         }
7946         else {
7947            dir_start = 1;
7948         }
7949       }
7950     } /* end of verified real path handling */
7951     else {
7952     int add_6zero;
7953     int islnm;
7954
7955       /* Ok, we have a device or a concealed root that is not in POSIX
7956        * or we have garbage.  Make the best of it.
7957        */
7958
7959       /* Posix to VMS destroyed this, so copy it again */
7960       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
7961       vmslen = strlen(vmspath); /* We know we're truncating. */
7962       vmsptr = &vmsptr[vmslen];
7963       islnm = 0;
7964
7965       /* Now do we need to add the fake 6 zero directory to it? */
7966       add_6zero = 1;
7967       if ((*lastslash == '/') && (nextslash < lastslash)) {
7968         /* No there is another directory */
7969         add_6zero = 0;
7970       }
7971       else {
7972       int trnend;
7973       int cmp;
7974
7975         /* now we have foo:bar or foo:[000000]bar to decide from */
7976         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7977
7978         if (!islnm && !decc_posix_compliant_pathnames) {
7979
7980             cmp = strncmp("bin", vmspath, 4);
7981             if (cmp == 0) {
7982                 /* bin => SYS$SYSTEM: */
7983                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7984             }
7985             else {
7986                 /* tmp => SYS$SCRATCH: */
7987                 cmp = strncmp("tmp", vmspath, 4);
7988                 if (cmp == 0) {
7989                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7990                 }
7991             }
7992         }
7993
7994         trnend = islnm ? islnm - 1 : 0;
7995
7996         /* if this was a logical name, ']' or '>' must be present */
7997         /* if not a logical name, then assume a device and hope. */
7998         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7999
8000         /* if log name and trailing '.' then rooted - treat as device */
8001         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8002
8003         /* Fix me, if not a logical name, a device lookup should be
8004          * done to see if the device is file structured.  If the device
8005          * is not file structured, the 6 zeros should not be put on.
8006          *
8007          * As it is, perl is occasionally looking for dev:[000000]tty.
8008          * which looks a little strange.
8009          *
8010          * Not that easy to detect as "/dev" may be file structured with
8011          * special device files.
8012          */
8013
8014         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
8015             (&nextslash[1] == unixend)) {
8016           /* No real directory present */
8017           add_6zero = 1;
8018         }
8019       }
8020
8021       /* Put the device delimiter on */
8022       *vmsptr++ = ':';
8023       vmslen++;
8024       unixptr = nextslash;
8025       unixptr++;
8026
8027       /* Start directory if needed */
8028       if (!islnm || add_6zero) {
8029         *vmsptr++ = '[';
8030         vmslen++;
8031         dir_start = 1;
8032       }
8033
8034       /* add fake 000000] if needed */
8035       if (add_6zero) {
8036         *vmsptr++ = '0';
8037         *vmsptr++ = '0';
8038         *vmsptr++ = '0';
8039         *vmsptr++ = '0';
8040         *vmsptr++ = '0';
8041         *vmsptr++ = '0';
8042         *vmsptr++ = ']';
8043         vmslen += 7;
8044         dir_start = 0;
8045       }
8046
8047     } /* non-POSIX translation */
8048     PerlMem_free(esa);
8049   } /* End of relative/absolute path handling */
8050
8051   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8052     int dash_flag;
8053     int in_cnt;
8054     int out_cnt;
8055
8056     dash_flag = 0;
8057
8058     if (dir_start != 0) {
8059
8060       /* First characters in a directory are handled special */
8061       while ((*unixptr == '/') ||
8062              ((*unixptr == '.') &&
8063               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8064                 (&unixptr[1]==unixend)))) {
8065       int loop_flag;
8066
8067         loop_flag = 0;
8068
8069         /* Skip redundant / in specification */
8070         while ((*unixptr == '/') && (dir_start != 0)) {
8071           loop_flag = 1;
8072           unixptr++;
8073           if (unixptr == lastslash)
8074             break;
8075         }
8076         if (unixptr == lastslash)
8077           break;
8078
8079         /* Skip redundant ./ characters */
8080         while ((*unixptr == '.') &&
8081                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8082           loop_flag = 1;
8083           unixptr++;
8084           if (unixptr == lastslash)
8085             break;
8086           if (*unixptr == '/')
8087             unixptr++;
8088         }
8089         if (unixptr == lastslash)
8090           break;
8091
8092         /* Skip redundant ../ characters */
8093         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8094              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8095           /* Set the backing up flag */
8096           loop_flag = 1;
8097           dir_dot = 0;
8098           dash_flag = 1;
8099           *vmsptr++ = '-';
8100           vmslen++;
8101           unixptr++; /* first . */
8102           unixptr++; /* second . */
8103           if (unixptr == lastslash)
8104             break;
8105           if (*unixptr == '/') /* The slash */
8106             unixptr++;
8107         }
8108         if (unixptr == lastslash)
8109           break;
8110
8111         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8112         /* Not needed when VMS is pretending to be UNIX. */
8113
8114         /* Is this loop stuck because of too many dots? */
8115         if (loop_flag == 0) {
8116           /* Exit the loop and pass the rest through */
8117           break;
8118         }
8119       }
8120
8121       /* Are we done with directories yet? */
8122       if (unixptr >= lastslash) {
8123
8124         /* Watch out for trailing dots */
8125         if (dir_dot != 0) {
8126             vmslen --;
8127             vmsptr--;
8128         }
8129         *vmsptr++ = ']';
8130         vmslen++;
8131         dash_flag = 0;
8132         dir_start = 0;
8133         if (*unixptr == '/')
8134           unixptr++;
8135       }
8136       else {
8137         /* Have we stopped backing up? */
8138         if (dash_flag) {
8139           *vmsptr++ = '.';
8140           vmslen++;
8141           dash_flag = 0;
8142           /* dir_start continues to be = 1 */
8143         }
8144         if (*unixptr == '-') {
8145           *vmsptr++ = '^';
8146           *vmsptr++ = *unixptr++;
8147           vmslen += 2;
8148           dir_start = 0;
8149
8150           /* Now are we done with directories yet? */
8151           if (unixptr >= lastslash) {
8152
8153             /* Watch out for trailing dots */
8154             if (dir_dot != 0) {
8155               vmslen --;
8156               vmsptr--;
8157             }
8158
8159             *vmsptr++ = ']';
8160             vmslen++;
8161             dash_flag = 0;
8162             dir_start = 0;
8163           }
8164         }
8165       }
8166     }
8167
8168     /* All done? */
8169     if (unixptr >= unixend)
8170       break;
8171
8172     /* Normal characters - More EFS work probably needed */
8173     dir_start = 0;
8174     dir_dot = 0;
8175
8176     switch(*unixptr) {
8177     case '/':
8178         /* remove multiple / */
8179         while (unixptr[1] == '/') {
8180            unixptr++;
8181         }
8182         if (unixptr == lastslash) {
8183           /* Watch out for trailing dots */
8184           if (dir_dot != 0) {
8185             vmslen --;
8186             vmsptr--;
8187           }
8188           *vmsptr++ = ']';
8189         }
8190         else {
8191           dir_start = 1;
8192           *vmsptr++ = '.';
8193           dir_dot = 1;
8194
8195           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8196           /* Not needed when VMS is pretending to be UNIX. */
8197
8198         }
8199         dash_flag = 0;
8200         if (unixptr != unixend)
8201           unixptr++;
8202         vmslen++;
8203         break;
8204     case '.':
8205         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8206             (&unixptr[1] == unixend)) {
8207           *vmsptr++ = '^';
8208           *vmsptr++ = '.';
8209           vmslen += 2;
8210           unixptr++;
8211
8212           /* trailing dot ==> '^..' on VMS */
8213           if (unixptr == unixend) {
8214             *vmsptr++ = '.';
8215             vmslen++;
8216             unixptr++;
8217           }
8218           break;
8219         }
8220
8221         *vmsptr++ = *unixptr++;
8222         vmslen ++;
8223         break;
8224     case '"':
8225         if (quoted && (&unixptr[1] == unixend)) {
8226             unixptr++;
8227             break;
8228         }
8229         in_cnt = copy_expand_unix_filename_escape
8230                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8231         vmsptr += out_cnt;
8232         unixptr += in_cnt;
8233         break;
8234     case '~':
8235     case ';':
8236     case '\\':
8237     case '?':
8238     case ' ':
8239     default:
8240         in_cnt = copy_expand_unix_filename_escape
8241                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8242         vmsptr += out_cnt;
8243         unixptr += in_cnt;
8244         break;
8245     }
8246   }
8247
8248   /* Make sure directory is closed */
8249   if (unixptr == lastslash) {
8250     char *vmsptr2;
8251     vmsptr2 = vmsptr - 1;
8252
8253     if (*vmsptr2 != ']') {
8254       *vmsptr2--;
8255
8256       /* directories do not end in a dot bracket */
8257       if (*vmsptr2 == '.') {
8258         vmsptr2--;
8259
8260         /* ^. is allowed */
8261         if (*vmsptr2 != '^') {
8262           vmsptr--; /* back up over the dot */
8263         }
8264       }
8265       *vmsptr++ = ']';
8266     }
8267   }
8268   else {
8269     char *vmsptr2;
8270     /* Add a trailing dot if a file with no extension */
8271     vmsptr2 = vmsptr - 1;
8272     if ((vmslen > 1) &&
8273         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8274         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8275         *vmsptr++ = '.';
8276         vmslen++;
8277     }
8278   }
8279
8280   *vmsptr = '\0';
8281   return SS$_NORMAL;
8282 }
8283 #endif
8284
8285 /* A convenience macro for copying dots in filenames and escaping
8286  * them when they haven't already been escaped, with guards to
8287  * avoid checking before the start of the buffer or advancing
8288  * beyond the end of it (allowing room for the NUL terminator).
8289  */
8290 #define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
8291     if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8292           || ((vmsefsdot) == (vmsefsbuf))) \
8293          && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
8294        ) { \
8295         *((vmsefsdot)++) = '^'; \
8296     } \
8297     if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8298         *((vmsefsdot)++) = '.'; \
8299 } STMT_END
8300
8301 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8302 static char *
8303 int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag)
8304 {
8305   char *dirend;
8306   char *lastdot;
8307   char *cp1;
8308   const char *cp2;
8309   unsigned long int infront = 0, hasdir = 1;
8310   int rslt_len;
8311   int no_type_seen;
8312   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8313   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8314
8315   if (vms_debug_fileify) {
8316       if (path == NULL)
8317           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8318       else
8319           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8320   }
8321
8322   if (path == NULL) {
8323       /* If we fail, we should be setting errno */
8324       set_errno(EINVAL);
8325       set_vaxc_errno(SS$_BADPARAM);
8326       return NULL;
8327   }
8328   rslt_len = VMS_MAXRSS-1;
8329
8330   /* '.' and '..' are "[]" and "[-]" for a quick check */
8331   if (path[0] == '.') {
8332     if (path[1] == '\0') {
8333       strcpy(rslt,"[]");
8334       if (utf8_flag != NULL)
8335         *utf8_flag = 0;
8336       return rslt;
8337     }
8338     else {
8339       if (path[1] == '.' && path[2] == '\0') {
8340         strcpy(rslt,"[-]");
8341         if (utf8_flag != NULL)
8342            *utf8_flag = 0;
8343         return rslt;
8344       }
8345     }
8346   }
8347
8348    /* Posix specifications are now a native VMS format */
8349   /*--------------------------------------------------*/
8350 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8351   if (decc_posix_compliant_pathnames) {
8352     if (strncmp(path,"\"^UP^",5) == 0) {
8353       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8354       return rslt;
8355     }
8356   }
8357 #endif
8358
8359   /* This is really the only way to see if this is already in VMS format */
8360   sts = vms_split_path
8361        (path,
8362         &v_spec,
8363         &v_len,
8364         &r_spec,
8365         &r_len,
8366         &d_spec,
8367         &d_len,
8368         &n_spec,
8369         &n_len,
8370         &e_spec,
8371         &e_len,
8372         &vs_spec,
8373         &vs_len);
8374   if (sts == 0) {
8375     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8376        replacement, because the above parse just took care of most of
8377        what is needed to do vmspath when the specification is already
8378        in VMS format.
8379
8380        And if it is not already, it is easier to do the conversion as
8381        part of this routine than to call this routine and then work on
8382        the result.
8383      */
8384
8385     /* If VMS punctuation was found, it is already VMS format */
8386     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8387       if (utf8_flag != NULL)
8388         *utf8_flag = 0;
8389       my_strlcpy(rslt, path, VMS_MAXRSS);
8390       if (vms_debug_fileify) {
8391           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8392       }
8393       return rslt;
8394     }
8395     /* Now, what to do with trailing "." cases where there is no
8396        extension?  If this is a UNIX specification, and EFS characters
8397        are enabled, then the trailing "." should be converted to a "^.".
8398        But if this was already a VMS specification, then it should be
8399        left alone.
8400
8401        So in the case of ambiguity, leave the specification alone.
8402      */
8403
8404
8405     /* If there is a possibility of UTF8, then if any UTF8 characters
8406         are present, then they must be converted to VTF-7
8407      */
8408     if (utf8_flag != NULL)
8409       *utf8_flag = 0;
8410     my_strlcpy(rslt, path, VMS_MAXRSS);
8411     if (vms_debug_fileify) {
8412         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8413     }
8414     return rslt;
8415   }
8416
8417   dirend = strrchr(path,'/');
8418
8419   if (dirend == NULL) {
8420      /* If we get here with no Unix directory delimiters, then this is an
8421       * ambiguous file specification, such as a Unix glob specification, a
8422       * shell or make macro, or a filespec that would be valid except for
8423       * unescaped extended characters.  The safest thing if it's a macro
8424       * is to pass it through as-is.
8425       */
8426       if (strstr(path, "$(")) {
8427           my_strlcpy(rslt, path, VMS_MAXRSS);
8428           if (vms_debug_fileify) {
8429               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8430           }
8431           return rslt;
8432       }
8433       hasdir = 0;
8434   }
8435   else if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8436     if (!*(dirend+2)) dirend +=2;
8437     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8438     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8439   }
8440
8441   cp1 = rslt;
8442   cp2 = path;
8443   lastdot = strrchr(cp2,'.');
8444   if (*cp2 == '/') {
8445     char *trndev;
8446     int islnm, rooted;
8447     STRLEN trnend;
8448
8449     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8450     if (!*(cp2+1)) {
8451       if (decc_disable_posix_root) {
8452         strcpy(rslt,"sys$disk:[000000]");
8453       }
8454       else {
8455         strcpy(rslt,"sys$posix_root:[000000]");
8456       }
8457       if (utf8_flag != NULL)
8458         *utf8_flag = 0;
8459       if (vms_debug_fileify) {
8460           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8461       }
8462       return rslt;
8463     }
8464     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8465     *cp1 = '\0';
8466     trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8467     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8468     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8469
8470      /* DECC special handling */
8471     if (!islnm) {
8472       if (strcmp(rslt,"bin") == 0) {
8473         strcpy(rslt,"sys$system");
8474         cp1 = rslt + 10;
8475         *cp1 = 0;
8476         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8477       }
8478       else if (strcmp(rslt,"tmp") == 0) {
8479         strcpy(rslt,"sys$scratch");
8480         cp1 = rslt + 11;
8481         *cp1 = 0;
8482         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8483       }
8484       else if (!decc_disable_posix_root) {
8485         strcpy(rslt, "sys$posix_root");
8486         cp1 = rslt + 14;
8487         *cp1 = 0;
8488         cp2 = path;
8489         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8490         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8491       }
8492       else if (strcmp(rslt,"dev") == 0) {
8493         if (strncmp(cp2,"/null", 5) == 0) {
8494           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8495             strcpy(rslt,"NLA0");
8496             cp1 = rslt + 4;
8497             *cp1 = 0;
8498             cp2 = cp2 + 5;
8499             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8500           }
8501         }
8502       }
8503     }
8504
8505     trnend = islnm ? strlen(trndev) - 1 : 0;
8506     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8507     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8508     /* If the first element of the path is a logical name, determine
8509      * whether it has to be translated so we can add more directories. */
8510     if (!islnm || rooted) {
8511       *(cp1++) = ':';
8512       *(cp1++) = '[';
8513       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8514       else cp2++;
8515     }
8516     else {
8517       if (cp2 != dirend) {
8518         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8519         cp1 = rslt + trnend;
8520         if (*cp2 != 0) {
8521           *(cp1++) = '.';
8522           cp2++;
8523         }
8524       }
8525       else {
8526         if (decc_disable_posix_root) {
8527           *(cp1++) = ':';
8528           hasdir = 0;
8529         }
8530       }
8531     }
8532     PerlMem_free(trndev);
8533   }
8534   else if (hasdir) {
8535     *(cp1++) = '[';
8536     if (*cp2 == '.') {
8537       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8538         cp2 += 2;         /* skip over "./" - it's redundant */
8539         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8540       }
8541       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8542         *(cp1++) = '-';                                 /* "../" --> "-" */
8543         cp2 += 3;
8544       }
8545       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8546                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8547         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8548         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8549         cp2 += 4;
8550       }
8551       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8552         /* Escape the extra dots in EFS file specifications */
8553         *(cp1++) = '^';
8554       }
8555       if (cp2 > dirend) cp2 = dirend;
8556     }
8557     else *(cp1++) = '.';
8558   }
8559   for (; cp2 < dirend; cp2++) {
8560     if (*cp2 == '/') {
8561       if (*(cp2-1) == '/') continue;
8562       if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
8563       infront = 0;
8564     }
8565     else if (!infront && *cp2 == '.') {
8566       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8567       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8568       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8569         if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
8570         else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
8571         else {
8572           *(cp1++) = '-';
8573         }
8574         cp2 += 2;
8575         if (cp2 == dirend) break;
8576       }
8577       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8578                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8579         if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8580         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8581         if (!*(cp2+3)) {
8582           *(cp1++) = '.';  /* Simulate trailing '/' */
8583           cp2 += 2;  /* for loop will incr this to == dirend */
8584         }
8585         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8586       }
8587       else {
8588         if (decc_efs_charset == 0) {
8589           if (cp1 > rslt && *(cp1-1) == '^')
8590             cp1--;         /* remove the escape, if any */
8591           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8592         }
8593         else {
8594           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8595         }
8596       }
8597     }
8598     else {
8599       if (!infront && cp1 > rslt && *(cp1-1) == '-')  *(cp1++) = '.';
8600       if (*cp2 == '.') {
8601         if (decc_efs_charset == 0) {
8602           if (cp1 > rslt && *(cp1-1) == '^')
8603             cp1--;         /* remove the escape, if any */
8604           *(cp1++) = '_';
8605         }
8606         else {
8607           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8608         }
8609       }
8610       else {
8611         int out_cnt;
8612         cp2 += copy_expand_unix_filename_escape(cp1, cp2, &out_cnt, utf8_flag);
8613         cp2--; /* we're in a loop that will increment this */
8614         cp1 += out_cnt;
8615       }
8616       infront = 1;
8617     }
8618   }
8619   if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8620   if (hasdir) *(cp1++) = ']';
8621   if (*cp2 && *cp2 == '/') cp2++;  /* check in case we ended with trailing '/' */
8622   no_type_seen = 0;
8623   if (cp2 > lastdot)
8624     no_type_seen = 1;
8625   while (*cp2) {
8626     switch(*cp2) {
8627     case '?':
8628         if (decc_efs_charset == 0)
8629           *(cp1++) = '%';
8630         else
8631           *(cp1++) = '?';
8632         cp2++;
8633     case ' ':
8634         if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
8635             *(cp1)++ = '^';
8636         *(cp1)++ = '_';
8637         cp2++;
8638         break;
8639     case '.':
8640         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8641             decc_readdir_dropdotnotype) {
8642           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8643           cp2++;
8644
8645           /* trailing dot ==> '^..' on VMS */
8646           if (*cp2 == '\0') {
8647             *(cp1++) = '.';
8648             no_type_seen = 0;
8649           }
8650         }
8651         else {
8652           *(cp1++) = *(cp2++);
8653           no_type_seen = 0;
8654         }
8655         break;
8656     case '$':
8657          /* This could be a macro to be passed through */
8658         *(cp1++) = *(cp2++);
8659         if (*cp2 == '(') {
8660         const char * save_cp2;
8661         char * save_cp1;
8662         int is_macro;
8663
8664             /* paranoid check */
8665             save_cp2 = cp2;
8666             save_cp1 = cp1;
8667             is_macro = 0;
8668
8669             /* Test through */
8670             *(cp1++) = *(cp2++);
8671             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8672                 *(cp1++) = *(cp2++);
8673                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8674                     *(cp1++) = *(cp2++);
8675                 }
8676                 if (*cp2 == ')') {
8677                     *(cp1++) = *(cp2++);
8678                     is_macro = 1;
8679                 }
8680             }
8681             if (is_macro == 0) {
8682                 /* Not really a macro - never mind */
8683                 cp2 = save_cp2;
8684                 cp1 = save_cp1;
8685             }
8686         }
8687         break;
8688     case '\"':
8689     case '~':
8690     case '`':
8691     case '!':
8692     case '#':
8693     case '%':
8694     case '^':
8695         /* Don't escape again if following character is
8696          * already something we escape.
8697          */
8698         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8699             *(cp1++) = *(cp2++);
8700             break;
8701         }
8702         /* But otherwise fall through and escape it. */
8703     case '&':
8704     case '(':
8705     case ')':
8706     case '=':
8707     case '+':
8708     case '\'':
8709     case '@':
8710     case '[':
8711     case ']':
8712     case '{':
8713     case '}':
8714     case ':':
8715     case '\\':
8716     case '|':
8717     case '<':
8718     case '>':
8719         if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */
8720             *(cp1++) = '^';
8721         *(cp1++) = *(cp2++);
8722         break;
8723     case ';':
8724         /* If it doesn't look like the beginning of a version number,
8725          * or we've been promised there are no version numbers, then
8726          * escape it.
8727          */
8728         if (decc_filename_unix_no_version) {
8729           *(cp1++) = '^';
8730         }
8731         else {
8732           size_t all_nums = strspn(cp2+1, "0123456789");
8733           if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0')
8734             *(cp1++) = '^';
8735         }
8736         *(cp1++) = *(cp2++);
8737         break;
8738     default:
8739         *(cp1++) = *(cp2++);
8740     }
8741   }
8742   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8743   char *lcp1;
8744     lcp1 = cp1;
8745     lcp1--;
8746      /* Fix me for "^]", but that requires making sure that you do
8747       * not back up past the start of the filename
8748       */
8749     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8750       *cp1++ = '.';
8751   }
8752   *cp1 = '\0';
8753
8754   if (utf8_flag != NULL)
8755     *utf8_flag = 0;
8756   if (vms_debug_fileify) {
8757       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8758   }
8759   return rslt;
8760
8761 }  /* end of int_tovmsspec() */
8762
8763
8764 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8765 static char *
8766 mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag)
8767 {
8768     static char __tovmsspec_retbuf[VMS_MAXRSS];
8769     char * vmsspec, *ret_spec, *ret_buf;
8770
8771     vmsspec = NULL;
8772     ret_buf = buf;
8773     if (ret_buf == NULL) {
8774         if (ts) {
8775             Newx(vmsspec, VMS_MAXRSS, char);
8776             if (vmsspec == NULL)
8777                 _ckvmssts(SS$_INSFMEM);
8778             ret_buf = vmsspec;
8779         } else {
8780             ret_buf = __tovmsspec_retbuf;
8781         }
8782     }
8783
8784     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8785
8786     if (ret_spec == NULL) {
8787        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8788        if (vmsspec)
8789            Safefree(vmsspec);
8790     }
8791
8792     return ret_spec;
8793
8794 }  /* end of mp_do_tovmsspec() */
8795 /*}}}*/
8796 /* External entry points */
8797 char *
8798 Perl_tovmsspec(pTHX_ const char *path, char *buf)
8799 {
8800     return do_tovmsspec(path, buf, 0, NULL);
8801 }
8802
8803 char *
8804 Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8805 {
8806     return do_tovmsspec(path, buf, 1, NULL);
8807 }
8808
8809 char *
8810 Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8811 {
8812     return do_tovmsspec(path, buf, 0, utf8_fl);
8813 }
8814
8815 char *
8816 Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8817 {
8818     return do_tovmsspec(path, buf, 1, utf8_fl);
8819 }
8820
8821 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8822 /* Internal routine for use with out an explicit context present */
8823 static char *
8824 int_tovmspath(const char *path, char *buf, int * utf8_fl)
8825 {
8826     char * ret_spec, *pathified;
8827
8828     if (path == NULL)
8829         return NULL;
8830
8831     pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8832     if (pathified == NULL)
8833         _ckvmssts_noperl(SS$_INSFMEM);
8834
8835     ret_spec = int_pathify_dirspec(path, pathified);
8836
8837     if (ret_spec == NULL) {
8838         PerlMem_free(pathified);
8839         return NULL;
8840     }
8841
8842     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8843
8844     PerlMem_free(pathified);
8845     return ret_spec;
8846
8847 }
8848
8849 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8850 static char *
8851 mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
8852 {
8853   static char __tovmspath_retbuf[VMS_MAXRSS];
8854   int vmslen;
8855   char *pathified, *vmsified, *cp;
8856
8857   if (path == NULL) return NULL;
8858   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8859   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8860   if (int_pathify_dirspec(path, pathified) == NULL) {
8861     PerlMem_free(pathified);
8862     return NULL;
8863   }
8864
8865   vmsified = NULL;
8866   if (buf == NULL)
8867      Newx(vmsified, VMS_MAXRSS, char);
8868   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8869     PerlMem_free(pathified);
8870     if (vmsified) Safefree(vmsified);
8871     return NULL;
8872   }
8873   PerlMem_free(pathified);
8874   if (buf) {
8875     return buf;
8876   }
8877   else if (ts) {
8878     vmslen = strlen(vmsified);
8879     Newx(cp,vmslen+1,char);
8880     memcpy(cp,vmsified,vmslen);
8881     cp[vmslen] = '\0';
8882     Safefree(vmsified);
8883     return cp;
8884   }
8885   else {
8886     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8887     Safefree(vmsified);
8888     return __tovmspath_retbuf;
8889   }
8890
8891 }  /* end of do_tovmspath() */
8892 /*}}}*/
8893 /* External entry points */
8894 char *
8895 Perl_tovmspath(pTHX_ const char *path, char *buf)
8896 {
8897     return do_tovmspath(path, buf, 0, NULL);
8898 }
8899
8900 char *
8901 Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8902 {
8903     return do_tovmspath(path, buf, 1, NULL);
8904 }
8905
8906 char *
8907 Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8908 {
8909     return do_tovmspath(path, buf, 0, utf8_fl);
8910 }
8911
8912 char *
8913 Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8914 {
8915     return do_tovmspath(path, buf, 1, utf8_fl);
8916 }
8917
8918
8919 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8920 static char *
8921 mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
8922 {
8923   static char __tounixpath_retbuf[VMS_MAXRSS];
8924   int unixlen;
8925   char *pathified, *unixified, *cp;
8926
8927   if (path == NULL) return NULL;
8928   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8929   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8930   if (int_pathify_dirspec(path, pathified) == NULL) {
8931     PerlMem_free(pathified);
8932     return NULL;
8933   }
8934
8935   unixified = NULL;
8936   if (buf == NULL) {
8937       Newx(unixified, VMS_MAXRSS, char);
8938   }
8939   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8940     PerlMem_free(pathified);
8941     if (unixified) Safefree(unixified);
8942     return NULL;
8943   }
8944   PerlMem_free(pathified);
8945   if (buf) {
8946     return buf;
8947   }
8948   else if (ts) {
8949     unixlen = strlen(unixified);
8950     Newx(cp,unixlen+1,char);
8951     memcpy(cp,unixified,unixlen);
8952     cp[unixlen] = '\0';
8953     Safefree(unixified);
8954     return cp;
8955   }
8956   else {
8957     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
8958     Safefree(unixified);
8959     return __tounixpath_retbuf;
8960   }
8961
8962 }  /* end of do_tounixpath() */
8963 /*}}}*/
8964 /* External entry points */
8965 char *
8966 Perl_tounixpath(pTHX_ const char *path, char *buf)
8967 {
8968     return do_tounixpath(path, buf, 0, NULL);
8969 }
8970
8971 char *
8972 Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8973 {
8974     return do_tounixpath(path, buf, 1, NULL);
8975 }
8976
8977 char *
8978 Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8979 {
8980     return do_tounixpath(path, buf, 0, utf8_fl);
8981 }
8982
8983 char *
8984 Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8985 {
8986     return do_tounixpath(path, buf, 1, utf8_fl);
8987 }
8988
8989 /*
8990  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8991  *
8992  *****************************************************************************
8993  *                                                                           *
8994  *  Copyright (C) 1989-1994, 2007 by                                         *
8995  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8996  *                                                                           *
8997  *  Permission is hereby granted for the reproduction of this software       *
8998  *  on condition that this copyright notice is included in source            *
8999  *  distributions of the software.  The code may be modified and             *
9000  *  distributed under the same terms as Perl itself.                         *
9001  *                                                                           *
9002  *  27-Aug-1994 Modified for inclusion in perl5                              *
9003  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9004  *****************************************************************************
9005  */
9006
9007 /*
9008  * getredirection() is intended to aid in porting C programs
9009  * to VMS (Vax-11 C).  The native VMS environment does not support
9010  * '>' and '<' I/O redirection, or command line wild card expansion,
9011  * or a command line pipe mechanism using the '|' AND background
9012  * command execution '&'.  All of these capabilities are provided to any
9013  * C program which calls this procedure as the first thing in the
9014  * main program.
9015  * The piping mechanism will probably work with almost any 'filter' type
9016  * of program.  With suitable modification, it may useful for other
9017  * portability problems as well.
9018  *
9019  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9020  */
9021 struct list_item
9022     {
9023     struct list_item *next;
9024     char *value;
9025     };
9026
9027 static void add_item(struct list_item **head,
9028                      struct list_item **tail,
9029                      char *value,
9030                      int *count);
9031
9032 static void mp_expand_wild_cards(pTHX_ char *item,
9033                                 struct list_item **head,
9034                                 struct list_item **tail,
9035                                 int *count);
9036
9037 static int background_process(pTHX_ int argc, char **argv);
9038
9039 static void pipe_and_fork(pTHX_ char **cmargv);
9040
9041 /*{{{ void getredirection(int *ac, char ***av)*/
9042 static void
9043 mp_getredirection(pTHX_ int *ac, char ***av)
9044 /*
9045  * Process vms redirection arg's.  Exit if any error is seen.
9046  * If getredirection() processes an argument, it is erased
9047  * from the vector.  getredirection() returns a new argc and argv value.
9048  * In the event that a background command is requested (by a trailing "&"),
9049  * this routine creates a background subprocess, and simply exits the program.
9050  *
9051  * Warning: do not try to simplify the code for vms.  The code
9052  * presupposes that getredirection() is called before any data is
9053  * read from stdin or written to stdout.
9054  *
9055  * Normal usage is as follows:
9056  *
9057  *      main(argc, argv)
9058  *      int             argc;
9059  *      char            *argv[];
9060  *      {
9061  *              getredirection(&argc, &argv);
9062  *      }
9063  */
9064 {
9065     int                 argc = *ac;     /* Argument Count         */
9066     char                **argv = *av;   /* Argument Vector        */
9067     char                *ap;            /* Argument pointer       */
9068     int                 j;              /* argv[] index           */
9069     int                 item_count = 0; /* Count of Items in List */
9070     struct list_item    *list_head = 0; /* First Item in List       */
9071     struct list_item    *list_tail;     /* Last Item in List        */
9072     char                *in = NULL;     /* Input File Name          */
9073     char                *out = NULL;    /* Output File Name         */
9074     char                *outmode = "w"; /* Mode to Open Output File */
9075     char                *err = NULL;    /* Error File Name          */
9076     char                *errmode = "w"; /* Mode to Open Error File  */
9077     int                 cmargc = 0;     /* Piped Command Arg Count  */
9078     char                **cmargv = NULL;/* Piped Command Arg Vector */
9079
9080     /*
9081      * First handle the case where the last thing on the line ends with
9082      * a '&'.  This indicates the desire for the command to be run in a
9083      * subprocess, so we satisfy that desire.
9084      */
9085     ap = argv[argc-1];
9086     if (0 == strcmp("&", ap))
9087        exit(background_process(aTHX_ --argc, argv));
9088     if (*ap && '&' == ap[strlen(ap)-1])
9089         {
9090         ap[strlen(ap)-1] = '\0';
9091        exit(background_process(aTHX_ argc, argv));
9092         }
9093     /*
9094      * Now we handle the general redirection cases that involve '>', '>>',
9095      * '<', and pipes '|'.
9096      */
9097     for (j = 0; j < argc; ++j)
9098         {
9099         if (0 == strcmp("<", argv[j]))
9100             {
9101             if (j+1 >= argc)
9102                 {
9103                 fprintf(stderr,"No input file after < on command line");
9104                 exit(LIB$_WRONUMARG);
9105                 }
9106             in = argv[++j];
9107             continue;
9108             }
9109         if ('<' == *(ap = argv[j]))
9110             {
9111             in = 1 + ap;
9112             continue;
9113             }
9114         if (0 == strcmp(">", ap))
9115             {
9116             if (j+1 >= argc)
9117                 {
9118                 fprintf(stderr,"No output file after > on command line");
9119                 exit(LIB$_WRONUMARG);
9120                 }
9121             out = argv[++j];
9122             continue;
9123             }
9124         if ('>' == *ap)
9125             {
9126             if ('>' == ap[1])
9127                 {
9128                 outmode = "a";
9129                 if ('\0' == ap[2])
9130                     out = argv[++j];
9131                 else
9132                     out = 2 + ap;
9133                 }
9134             else
9135                 out = 1 + ap;
9136             if (j >= argc)
9137                 {
9138                 fprintf(stderr,"No output file after > or >> on command line");
9139                 exit(LIB$_WRONUMARG);
9140                 }
9141             continue;
9142             }
9143         if (('2' == *ap) && ('>' == ap[1]))
9144             {
9145             if ('>' == ap[2])
9146                 {
9147                 errmode = "a";
9148                 if ('\0' == ap[3])
9149                     err = argv[++j];
9150                 else
9151                     err = 3 + ap;
9152                 }
9153             else
9154                 if ('\0' == ap[2])
9155                     err = argv[++j];
9156                 else
9157                     err = 2 + ap;
9158             if (j >= argc)
9159                 {
9160                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9161                 exit(LIB$_WRONUMARG);
9162                 }
9163             continue;
9164             }
9165         if (0 == strcmp("|", argv[j]))
9166             {
9167             if (j+1 >= argc)
9168                 {
9169                 fprintf(stderr,"No command into which to pipe on command line");
9170                 exit(LIB$_WRONUMARG);
9171                 }
9172             cmargc = argc-(j+1);
9173             cmargv = &argv[j+1];
9174             argc = j;
9175             continue;
9176             }
9177         if ('|' == *(ap = argv[j]))
9178             {
9179             ++argv[j];
9180             cmargc = argc-j;
9181             cmargv = &argv[j];
9182             argc = j;
9183             continue;
9184             }
9185         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9186         }
9187     /*
9188      * Allocate and fill in the new argument vector, Some Unix's terminate
9189      * the list with an extra null pointer.
9190      */
9191     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9192     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9193     *av = argv;
9194     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9195         argv[j] = list_head->value;
9196     *ac = item_count;
9197     if (cmargv != NULL)
9198         {
9199         if (out != NULL)
9200             {
9201             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9202             exit(LIB$_INVARGORD);
9203             }
9204         pipe_and_fork(aTHX_ cmargv);
9205         }
9206
9207     /* Check for input from a pipe (mailbox) */
9208
9209     if (in == NULL && 1 == isapipe(0))
9210         {
9211         char mbxname[L_tmpnam];
9212         long int bufsize;
9213         long int dvi_item = DVI$_DEVBUFSIZ;
9214         $DESCRIPTOR(mbxnam, "");
9215         $DESCRIPTOR(mbxdevnam, "");
9216
9217         /* Input from a pipe, reopen it in binary mode to disable       */
9218         /* carriage control processing.                                 */
9219
9220         fgetname(stdin, mbxname, 1);
9221         mbxnam.dsc$a_pointer = mbxname;
9222         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9223         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9224         mbxdevnam.dsc$a_pointer = mbxname;
9225         mbxdevnam.dsc$w_length = sizeof(mbxname);
9226         dvi_item = DVI$_DEVNAM;
9227         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9228         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9229         set_errno(0);
9230         set_vaxc_errno(1);
9231         freopen(mbxname, "rb", stdin);
9232         if (errno != 0)
9233             {
9234             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9235             exit(vaxc$errno);
9236             }
9237         }
9238     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9239         {
9240         fprintf(stderr,"Can't open input file %s as stdin",in);
9241         exit(vaxc$errno);
9242         }
9243     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9244         {
9245         fprintf(stderr,"Can't open output file %s as stdout",out);
9246         exit(vaxc$errno);
9247         }
9248         if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
9249
9250     if (err != NULL) {
9251         if (strcmp(err,"&1") == 0) {
9252             dup2(fileno(stdout), fileno(stderr));
9253             vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
9254         } else {
9255         FILE *tmperr;
9256         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9257             {
9258             fprintf(stderr,"Can't open error file %s as stderr",err);
9259             exit(vaxc$errno);
9260             }
9261             fclose(tmperr);
9262            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9263                 {
9264                 exit(vaxc$errno);
9265                 }
9266             vmssetuserlnm("SYS$ERROR", err);
9267         }
9268         }
9269 #ifdef ARGPROC_DEBUG
9270     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9271     for (j = 0; j < *ac;  ++j)
9272         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9273 #endif
9274    /* Clear errors we may have hit expanding wildcards, so they don't
9275       show up in Perl's $! later */
9276    set_errno(0); set_vaxc_errno(1);
9277 }  /* end of getredirection() */
9278 /*}}}*/
9279
9280 static void
9281 add_item(struct list_item **head, struct list_item **tail, char *value, int *count)
9282 {
9283     if (*head == 0)
9284         {
9285         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9286         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9287         *tail = *head;
9288         }
9289     else {
9290         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9291         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9292         *tail = (*tail)->next;
9293         }
9294     (*tail)->value = value;
9295     ++(*count);
9296 }
9297
9298 static void
9299 mp_expand_wild_cards(pTHX_ char *item, struct list_item **head,
9300                      struct list_item **tail, int *count)
9301 {
9302     int expcount = 0;
9303     unsigned long int context = 0;
9304     int isunix = 0;
9305     int item_len = 0;
9306     char *had_version;
9307     char *had_device;
9308     int had_directory;
9309     char *devdir,*cp;
9310     char *vmsspec;
9311     $DESCRIPTOR(filespec, "");
9312     $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9313     $DESCRIPTOR(resultspec, "");
9314     unsigned long int lff_flags = 0;
9315     int sts;
9316     int rms_sts;
9317
9318 #ifdef VMS_LONGNAME_SUPPORT
9319     lff_flags = LIB$M_FIL_LONG_NAMES;
9320 #endif
9321
9322     for (cp = item; *cp; cp++) {
9323         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9324         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9325     }
9326     if (!*cp || isspace(*cp))
9327         {
9328         add_item(head, tail, item, count);
9329         return;
9330         }
9331     else
9332         {
9333      /* "double quoted" wild card expressions pass as is */
9334      /* From DCL that means using e.g.:                  */
9335      /* perl program """perl.*"""                        */
9336      item_len = strlen(item);
9337      if ( '"' == *item && '"' == item[item_len-1] )
9338        {
9339        item++;
9340        item[item_len-2] = '\0';
9341        add_item(head, tail, item, count);
9342        return;
9343        }
9344      }
9345     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9346     resultspec.dsc$b_class = DSC$K_CLASS_D;
9347     resultspec.dsc$a_pointer = NULL;
9348     vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9349     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9350     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9351       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9352     if (!isunix || !filespec.dsc$a_pointer)
9353       filespec.dsc$a_pointer = item;
9354     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9355     /*
9356      * Only return version specs, if the caller specified a version
9357      */
9358     had_version = strchr(item, ';');
9359     /*
9360      * Only return device and directory specs, if the caller specified either.
9361      */
9362     had_device = strchr(item, ':');
9363     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9364
9365     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9366                                  (&filespec, &resultspec, &context,
9367                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9368         {
9369         char *string;
9370         char *c;
9371
9372         string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9373         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9374         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9375         if (NULL == had_version)
9376             *(strrchr(string, ';')) = '\0';
9377         if ((!had_directory) && (had_device == NULL))
9378             {
9379             if (NULL == (devdir = strrchr(string, ']')))
9380                 devdir = strrchr(string, '>');
9381             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9382             }
9383         /*
9384          * Be consistent with what the C RTL has already done to the rest of
9385          * the argv items and lowercase all of these names.
9386          */
9387         if (!decc_efs_case_preserve) {
9388             for (c = string; *c; ++c)
9389             if (isupper(*c))
9390                 *c = tolower(*c);
9391         }
9392         if (isunix) trim_unixpath(string,item,1);
9393         add_item(head, tail, string, count);
9394         ++expcount;
9395     }
9396     PerlMem_free(vmsspec);
9397     if (sts != RMS$_NMF)
9398         {
9399         set_vaxc_errno(sts);
9400         switch (sts)
9401             {
9402             case RMS$_FNF: case RMS$_DNF:
9403                 set_errno(ENOENT); break;
9404             case RMS$_DIR:
9405                 set_errno(ENOTDIR); break;
9406             case RMS$_DEV:
9407                 set_errno(ENODEV); break;
9408             case RMS$_FNM: case RMS$_SYN:
9409                 set_errno(EINVAL); break;
9410             case RMS$_PRV:
9411                 set_errno(EACCES); break;
9412             default:
9413                 _ckvmssts_noperl(sts);
9414             }
9415         }
9416     if (expcount == 0)
9417         add_item(head, tail, item, count);
9418     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9419     _ckvmssts_noperl(lib$find_file_end(&context));
9420 }
9421
9422
9423 static void
9424 pipe_and_fork(pTHX_ char **cmargv)
9425 {
9426     PerlIO *fp;
9427     struct dsc$descriptor_s *vmscmd;
9428     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9429     int sts, j, l, ismcr, quote, tquote = 0;
9430
9431     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9432     vms_execfree(vmscmd);
9433
9434     j = l = 0;
9435     p = subcmd;
9436     q = cmargv[0];
9437     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9438               && toupper(*(q+2)) == 'R' && !*(q+3);
9439
9440     while (q && l < MAX_DCL_LINE_LENGTH) {
9441         if (!*q) {
9442             if (j > 0 && quote) {
9443                 *p++ = '"';
9444                 l++;
9445             }
9446             q = cmargv[++j];
9447             if (q) {
9448                 if (ismcr && j > 1) quote = 1;
9449                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9450                 *p++ = ' ';
9451                 l++;
9452                 if (quote || tquote) {
9453                     *p++ = '"';
9454                     l++;
9455                 }
9456             }
9457         } else {
9458             if ((quote||tquote) && *q == '"') {
9459                 *p++ = '"';
9460                 l++;
9461             }
9462             *p++ = *q++;
9463             l++;
9464         }
9465     }
9466     *p = '\0';
9467
9468     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9469     if (fp == NULL) {
9470         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9471     }
9472 }
9473
9474 static int
9475 background_process(pTHX_ int argc, char **argv)
9476 {
9477     char command[MAX_DCL_SYMBOL + 1] = "$";
9478     $DESCRIPTOR(value, "");
9479     static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9480     static $DESCRIPTOR(null, "NLA0:");
9481     static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9482     char pidstring[80];
9483     $DESCRIPTOR(pidstr, "");
9484     int pid;
9485     unsigned long int flags = 17, one = 1, retsts;
9486     int len;
9487
9488     len = my_strlcat(command, argv[0], sizeof(command));
9489     while (--argc && (len < MAX_DCL_SYMBOL))
9490         {
9491         my_strlcat(command, " \"", sizeof(command));
9492         my_strlcat(command, *(++argv), sizeof(command));
9493         len = my_strlcat(command, "\"", sizeof(command));
9494         }
9495     value.dsc$a_pointer = command;
9496     value.dsc$w_length = strlen(value.dsc$a_pointer);
9497     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9498     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9499     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9500         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9501     }
9502     else {
9503         _ckvmssts_noperl(retsts);
9504     }
9505 #ifdef ARGPROC_DEBUG
9506     PerlIO_printf(Perl_debug_log, "%s\n", command);
9507 #endif
9508     sprintf(pidstring, "%08X", pid);
9509     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9510     pidstr.dsc$a_pointer = pidstring;
9511     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9512     lib$set_symbol(&pidsymbol, &pidstr);
9513     return(SS$_NORMAL);
9514 }
9515 /*}}}*/
9516 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9517
9518
9519 /* OS-specific initialization at image activation (not thread startup) */
9520 /* Older VAXC header files lack these constants */
9521 #ifndef JPI$_RIGHTS_SIZE
9522 #  define JPI$_RIGHTS_SIZE 817
9523 #endif
9524 #ifndef KGB$M_SUBSYSTEM
9525 #  define KGB$M_SUBSYSTEM 0x8
9526 #endif
9527
9528 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9529
9530 /*{{{void vms_image_init(int *, char ***)*/
9531 void
9532 vms_image_init(int *argcp, char ***argvp)
9533 {
9534   int status;
9535   char eqv[LNM$C_NAMLENGTH+1] = "";
9536   unsigned int len, tabct = 8, tabidx = 0;
9537   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9538   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9539   unsigned short int dummy, rlen;
9540   struct dsc$descriptor_s **tabvec;
9541 #if defined(PERL_IMPLICIT_CONTEXT)
9542   pTHX = NULL;
9543 #endif
9544   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9545                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9546                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9547                                  {          0,                0,    0,      0} };
9548
9549 #ifdef KILL_BY_SIGPRC
9550     Perl_csighandler_init();
9551 #endif
9552
9553 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9554     /* This was moved from the pre-image init handler because on threaded */
9555     /* Perl it was always returning 0 for the default value. */
9556     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9557     if (status > 0) {
9558         int s;
9559         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9560         if (s > 0) {
9561             int initial;
9562             initial = decc$feature_get_value(s, 4);
9563             if (initial > 0) {
9564                 /* initial is: 0 if nothing has set the feature */
9565                 /*            -1 if initialized to default */
9566                 /*             1 if set by logical name */
9567                 /*             2 if set by decc$feature_set_value */
9568                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9569
9570                 /* If the value is not valid, force the feature off */
9571                 if (decc_disable_posix_root < 0) {
9572                     decc$feature_set_value(s, 1, 1);
9573                     decc_disable_posix_root = 1;
9574                 }
9575             }
9576             else {
9577                 /* Nothing has asked for it explicitly, so use our own default. */
9578                 decc_disable_posix_root = 1;
9579                 decc$feature_set_value(s, 1, 1);
9580             }
9581         }
9582     }
9583 #endif
9584
9585   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9586   _ckvmssts_noperl(iosb[0]);
9587   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9588     if (iprv[i]) {           /* Running image installed with privs? */
9589       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9590       will_taint = TRUE;
9591       break;
9592     }
9593   }
9594   /* Rights identifiers might trigger tainting as well. */
9595   if (!will_taint && (rlen || rsz)) {
9596     while (rlen < rsz) {
9597       /* We didn't get all the identifiers on the first pass.  Allocate a
9598        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9599        * were needed to hold all identifiers at time of last call; we'll
9600        * allocate that many unsigned long ints), and go back and get 'em.
9601        * If it gave us less than it wanted to despite ample buffer space,
9602        * something's broken.  Is your system missing a system identifier?
9603        */
9604       if (rsz <= jpilist[1].buflen) {
9605          /* Perl_croak accvios when used this early in startup. */
9606          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9607                          rsz, (unsigned long) jpilist[1].buflen,
9608                          "Check your rights database for corruption.\n");
9609          exit(SS$_ABORT);
9610       }
9611       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9612       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9613       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9614       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9615       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9616       _ckvmssts_noperl(iosb[0]);
9617     }
9618     mask = (unsigned long int *)jpilist[1].bufadr;
9619     /* Check attribute flags for each identifier (2nd longword); protected
9620      * subsystem identifiers trigger tainting.
9621      */
9622     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9623       if (mask[i] & KGB$M_SUBSYSTEM) {
9624         will_taint = TRUE;
9625         break;
9626       }
9627     }
9628     if (mask != rlst) PerlMem_free(mask);
9629   }
9630
9631   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9632    * logical, some versions of the CRTL will add a phanthom /000000/
9633    * directory.  This needs to be removed.
9634    */
9635   if (decc_filename_unix_report) {
9636     char * zeros;
9637     int ulen;
9638     ulen = strlen(argvp[0][0]);
9639     if (ulen > 7) {
9640       zeros = strstr(argvp[0][0], "/000000/");
9641       if (zeros != NULL) {
9642         int mlen;
9643         mlen = ulen - (zeros - argvp[0][0]) - 7;
9644         memmove(zeros, &zeros[7], mlen);
9645         ulen = ulen - 7;
9646         argvp[0][0][ulen] = '\0';
9647       }
9648     }
9649     /* It also may have a trailing dot that needs to be removed otherwise
9650      * it will be converted to VMS mode incorrectly.
9651      */
9652     ulen--;
9653     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9654       argvp[0][0][ulen] = '\0';
9655   }
9656
9657   /* We need to use this hack to tell Perl it should run with tainting,
9658    * since its tainting flag may be part of the PL_curinterp struct, which
9659    * hasn't been allocated when vms_image_init() is called.
9660    */
9661   if (will_taint) {
9662     char **newargv, **oldargv;
9663     oldargv = *argvp;
9664     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9665     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9666     newargv[0] = oldargv[0];
9667     newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9668     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9669     strcpy(newargv[1], "-T");
9670     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9671     (*argcp)++;
9672     newargv[*argcp] = NULL;
9673     /* We orphan the old argv, since we don't know where it's come from,
9674      * so we don't know how to free it.
9675      */
9676     *argvp = newargv;
9677   }
9678   else {  /* Did user explicitly request tainting? */
9679     int i;
9680     char *cp, **av = *argvp;
9681     for (i = 1; i < *argcp; i++) {
9682       if (*av[i] != '-') break;
9683       for (cp = av[i]+1; *cp; cp++) {
9684         if (*cp == 'T') { will_taint = 1; break; }
9685         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9686                   strchr("DFIiMmx",*cp)) break;
9687       }
9688       if (will_taint) break;
9689     }
9690   }
9691
9692   for (tabidx = 0;
9693        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9694        tabidx++) {
9695     if (!tabidx) {
9696       tabvec = (struct dsc$descriptor_s **)
9697             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9698       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9699     }
9700     else if (tabidx >= tabct) {
9701       tabct += 8;
9702       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9703       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9704     }
9705     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9706     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9707     tabvec[tabidx]->dsc$w_length  = len;
9708     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9709     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_S;
9710     tabvec[tabidx]->dsc$a_pointer = (char *)PerlMem_malloc(len + 1);
9711     if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9712     my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
9713   }
9714   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9715
9716   getredirection(argcp,argvp);
9717 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9718   {
9719 # include <reentrancy.h>
9720   decc$set_reentrancy(C$C_MULTITHREAD);
9721   }
9722 #endif
9723   return;
9724 }
9725 /*}}}*/
9726
9727
9728 /* trim_unixpath()
9729  * Trim Unix-style prefix off filespec, so it looks like what a shell
9730  * glob expansion would return (i.e. from specified prefix on, not
9731  * full path).  Note that returned filespec is Unix-style, regardless
9732  * of whether input filespec was VMS-style or Unix-style.
9733  *
9734  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9735  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9736  * vector of options; at present, only bit 0 is used, and if set tells
9737  * trim unixpath to try the current default directory as a prefix when
9738  * presented with a possibly ambiguous ... wildcard.
9739  *
9740  * Returns !=0 on success, with trimmed filespec replacing contents of
9741  * fspec, and 0 on failure, with contents of fpsec unchanged.
9742  */
9743 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9744 int
9745 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9746 {
9747   char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9748   int tmplen, reslen = 0, dirs = 0;
9749
9750   if (!wildspec || !fspec) return 0;
9751
9752   unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9753   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9754   tplate = unixwild;
9755   if (strpbrk(wildspec,"]>:") != NULL) {
9756     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9757         PerlMem_free(unixwild);
9758         return 0;
9759     }
9760   }
9761   else {
9762     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9763   }
9764   unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9765   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9766   if (strpbrk(fspec,"]>:") != NULL) {
9767     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9768         PerlMem_free(unixwild);
9769         PerlMem_free(unixified);
9770         return 0;
9771     }
9772     else base = unixified;
9773     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9774      * check to see that final result fits into (isn't longer than) fspec */
9775     reslen = strlen(fspec);
9776   }
9777   else base = fspec;
9778
9779   /* No prefix or absolute path on wildcard, so nothing to remove */
9780   if (!*tplate || *tplate == '/') {
9781     PerlMem_free(unixwild);
9782     if (base == fspec) {
9783         PerlMem_free(unixified);
9784         return 1;
9785     }
9786     tmplen = strlen(unixified);
9787     if (tmplen > reslen) {
9788         PerlMem_free(unixified);
9789         return 0;  /* not enough space */
9790     }
9791     /* Copy unixified resultant, including trailing NUL */
9792     memmove(fspec,unixified,tmplen+1);
9793     PerlMem_free(unixified);
9794     return 1;
9795   }
9796
9797   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9798   if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9799     for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9800     for (cp1 = end ;cp1 >= base; cp1--)
9801       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9802         { cp1++; break; }
9803     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9804     PerlMem_free(unixified);
9805     PerlMem_free(unixwild);
9806     return 1;
9807   }
9808   else {
9809     char *tpl, *lcres;
9810     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9811     int ells = 1, totells, segdirs, match;
9812     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9813                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9814
9815     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9816     totells = ells;
9817     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9818     tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9819     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9820     if (ellipsis == tplate && opts & 1) {
9821       /* Template begins with an ellipsis.  Since we can't tell how many
9822        * directory names at the front of the resultant to keep for an
9823        * arbitrary starting point, we arbitrarily choose the current
9824        * default directory as a starting point.  If it's there as a prefix,
9825        * clip it off.  If not, fall through and act as if the leading
9826        * ellipsis weren't there (i.e. return shortest possible path that
9827        * could match template).
9828        */
9829       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9830           PerlMem_free(tpl);
9831           PerlMem_free(unixified);
9832           PerlMem_free(unixwild);
9833           return 0;
9834       }
9835       if (!decc_efs_case_preserve) {
9836         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9837           if (_tolower(*cp1) != _tolower(*cp2)) break;
9838       }
9839       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9840       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9841       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9842         memmove(fspec,cp2+1,end - cp2);
9843         PerlMem_free(tpl);
9844         PerlMem_free(unixified);
9845         PerlMem_free(unixwild);
9846         return 1;
9847       }
9848     }
9849     /* First off, back up over constant elements at end of path */
9850     if (dirs) {
9851       for (front = end ; front >= base; front--)
9852          if (*front == '/' && !dirs--) { front++; break; }
9853     }
9854     lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9855     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9856     for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9857          cp1++,cp2++) {
9858             if (!decc_efs_case_preserve) {
9859                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9860             }
9861             else {
9862                 *cp2 = *cp1;
9863             }
9864     }
9865     if (cp1 != '\0') {
9866         PerlMem_free(tpl);
9867         PerlMem_free(unixified);
9868         PerlMem_free(unixwild);
9869         PerlMem_free(lcres);
9870         return 0;  /* Path too long. */
9871     }
9872     lcend = cp2;
9873     *cp2 = '\0';  /* Pick up with memcpy later */
9874     lcfront = lcres + (front - base);
9875     /* Now skip over each ellipsis and try to match the path in front of it. */
9876     while (ells--) {
9877       for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9878         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9879             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9880       if (cp1 < tplate) break; /* template started with an ellipsis */
9881       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9882         ellipsis = cp1; continue;
9883       }
9884       wilddsc.dsc$a_pointer = tpl;
9885       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9886       nextell = cp1;
9887       for (segdirs = 0, cp2 = tpl;
9888            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9889            cp1++, cp2++) {
9890          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9891          else {
9892             if (!decc_efs_case_preserve) {
9893               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9894             }
9895             else {
9896               *cp2 = *cp1;  /* else preserve case for match */
9897             }
9898          }
9899          if (*cp2 == '/') segdirs++;
9900       }
9901       if (cp1 != ellipsis - 1) {
9902           PerlMem_free(tpl);
9903           PerlMem_free(unixified);
9904           PerlMem_free(unixwild);
9905           PerlMem_free(lcres);
9906           return 0; /* Path too long */
9907       }
9908       /* Back up at least as many dirs as in template before matching */
9909       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9910         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9911       for (match = 0; cp1 > lcres;) {
9912         resdsc.dsc$a_pointer = cp1;
9913         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9914           match++;
9915           if (match == 1) lcfront = cp1;
9916         }
9917         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9918       }
9919       if (!match) {
9920         PerlMem_free(tpl);
9921         PerlMem_free(unixified);
9922         PerlMem_free(unixwild);
9923         PerlMem_free(lcres);
9924         return 0;  /* Can't find prefix ??? */
9925       }
9926       if (match > 1 && opts & 1) {
9927         /* This ... wildcard could cover more than one set of dirs (i.e.
9928          * a set of similar dir names is repeated).  If the template
9929          * contains more than 1 ..., upstream elements could resolve the
9930          * ambiguity, but it's not worth a full backtracking setup here.
9931          * As a quick heuristic, clip off the current default directory
9932          * if it's present to find the trimmed spec, else use the
9933          * shortest string that this ... could cover.
9934          */
9935         char def[NAM$C_MAXRSS+1], *st;
9936
9937         if (getcwd(def, sizeof def,0) == NULL) {
9938             PerlMem_free(unixified);
9939             PerlMem_free(unixwild);
9940             PerlMem_free(lcres);
9941             PerlMem_free(tpl);
9942             return 0;
9943         }
9944         if (!decc_efs_case_preserve) {
9945           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9946             if (_tolower(*cp1) != _tolower(*cp2)) break;
9947         }
9948         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9949         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9950         if (*cp1 == '\0' && *cp2 == '/') {
9951           memmove(fspec,cp2+1,end - cp2);
9952           PerlMem_free(tpl);
9953           PerlMem_free(unixified);
9954           PerlMem_free(unixwild);
9955           PerlMem_free(lcres);
9956           return 1;
9957         }
9958         /* Nope -- stick with lcfront from above and keep going. */
9959       }
9960     }
9961     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9962     PerlMem_free(tpl);
9963     PerlMem_free(unixified);
9964     PerlMem_free(unixwild);
9965     PerlMem_free(lcres);
9966     return 1;
9967   }
9968
9969 }  /* end of trim_unixpath() */
9970 /*}}}*/
9971
9972
9973 /*
9974  *  VMS readdir() routines.
9975  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9976  *
9977  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9978  *  Minor modifications to original routines.
9979  */
9980
9981 /* readdir may have been redefined by reentr.h, so make sure we get
9982  * the local version for what we do here.
9983  */
9984 #ifdef readdir
9985 # undef readdir
9986 #endif
9987 #if !defined(PERL_IMPLICIT_CONTEXT)
9988 # define readdir Perl_readdir
9989 #else
9990 # define readdir(a) Perl_readdir(aTHX_ a)
9991 #endif
9992
9993     /* Number of elements in vms_versions array */
9994 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9995
9996 /*
9997  *  Open a directory, return a handle for later use.
9998  */
9999 /*{{{ DIR *opendir(char*name) */
10000 DIR *
10001 Perl_opendir(pTHX_ const char *name)
10002 {
10003     DIR *dd;
10004     char *dir;
10005     Stat_t sb;
10006
10007     Newx(dir, VMS_MAXRSS, char);
10008     if (int_tovmspath(name, dir, NULL) == NULL) {
10009       Safefree(dir);
10010       return NULL;
10011     }
10012     /* Check access before stat; otherwise stat does not
10013      * accurately report whether it's a directory.
10014      */
10015     if (!strstr(dir, "::") /* sys$check_access doesn't do remotes */
10016         && !cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10017       /* cando_by_name has already set errno */
10018       Safefree(dir);
10019       return NULL;
10020     }
10021     if (flex_stat(dir,&sb) == -1) return NULL;
10022     if (!S_ISDIR(sb.st_mode)) {
10023       Safefree(dir);
10024       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10025       return NULL;
10026     }
10027     /* Get memory for the handle, and the pattern. */
10028     Newx(dd,1,DIR);
10029     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10030
10031     /* Fill in the fields; mainly playing with the descriptor. */
10032     sprintf(dd->pattern, "%s*.*",dir);
10033     Safefree(dir);
10034     dd->context = 0;
10035     dd->count = 0;
10036     dd->flags = 0;
10037     /* By saying we want the result of readdir() in unix format, we are really
10038      * saying we want all the escapes removed, translating characters that
10039      * must be escaped in a VMS-format name to their unescaped form, which is
10040      * presumably allowed in a Unix-format name.
10041      */
10042     dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
10043     dd->pat.dsc$a_pointer = dd->pattern;
10044     dd->pat.dsc$w_length = strlen(dd->pattern);
10045     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10046     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10047 #if defined(USE_ITHREADS)
10048     Newx(dd->mutex,1,perl_mutex);
10049     MUTEX_INIT( (perl_mutex *) dd->mutex );
10050 #else
10051     dd->mutex = NULL;
10052 #endif
10053
10054     return dd;
10055 }  /* end of opendir() */
10056 /*}}}*/
10057
10058 /*
10059  *  Set the flag to indicate we want versions or not.
10060  */
10061 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10062 void
10063 vmsreaddirversions(DIR *dd, int flag)
10064 {
10065     if (flag)
10066         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10067     else
10068         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10069 }
10070 /*}}}*/
10071
10072 /*
10073  *  Free up an opened directory.
10074  */
10075 /*{{{ void closedir(DIR *dd)*/
10076 void
10077 Perl_closedir(DIR *dd)
10078 {
10079     int sts;
10080
10081     sts = lib$find_file_end(&dd->context);
10082     Safefree(dd->pattern);
10083 #if defined(USE_ITHREADS)
10084     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10085     Safefree(dd->mutex);
10086 #endif
10087     Safefree(dd);
10088 }
10089 /*}}}*/
10090
10091 /*
10092  *  Collect all the version numbers for the current file.
10093  */
10094 static void
10095 collectversions(pTHX_ DIR *dd)
10096 {
10097     struct dsc$descriptor_s     pat;
10098     struct dsc$descriptor_s     res;
10099     struct dirent *e;
10100     char *p, *text, *buff;
10101     int i;
10102     unsigned long context, tmpsts;
10103
10104     /* Convenient shorthand. */
10105     e = &dd->entry;
10106
10107     /* Add the version wildcard, ignoring the "*.*" put on before */
10108     i = strlen(dd->pattern);
10109     Newx(text,i + e->d_namlen + 3,char);
10110     my_strlcpy(text, dd->pattern, i + 1);
10111     sprintf(&text[i - 3], "%s;*", e->d_name);
10112
10113     /* Set up the pattern descriptor. */
10114     pat.dsc$a_pointer = text;
10115     pat.dsc$w_length = i + e->d_namlen - 1;
10116     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10117     pat.dsc$b_class = DSC$K_CLASS_S;
10118
10119     /* Set up result descriptor. */
10120     Newx(buff, VMS_MAXRSS, char);
10121     res.dsc$a_pointer = buff;
10122     res.dsc$w_length = VMS_MAXRSS - 1;
10123     res.dsc$b_dtype = DSC$K_DTYPE_T;
10124     res.dsc$b_class = DSC$K_CLASS_S;
10125
10126     /* Read files, collecting versions. */
10127     for (context = 0, e->vms_verscount = 0;
10128          e->vms_verscount < VERSIZE(e);
10129          e->vms_verscount++) {
10130         unsigned long rsts;
10131         unsigned long flags = 0;
10132
10133 #ifdef VMS_LONGNAME_SUPPORT
10134         flags = LIB$M_FIL_LONG_NAMES;
10135 #endif
10136         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10137         if (tmpsts == RMS$_NMF || context == 0) break;
10138         _ckvmssts(tmpsts);
10139         buff[VMS_MAXRSS - 1] = '\0';
10140         if ((p = strchr(buff, ';')))
10141             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10142         else
10143             e->vms_versions[e->vms_verscount] = -1;
10144     }
10145
10146     _ckvmssts(lib$find_file_end(&context));
10147     Safefree(text);
10148     Safefree(buff);
10149
10150 }  /* end of collectversions() */
10151
10152 /*
10153  *  Read the next entry from the directory.
10154  */
10155 /*{{{ struct dirent *readdir(DIR *dd)*/
10156 struct dirent *
10157 Perl_readdir(pTHX_ DIR *dd)
10158 {
10159     struct dsc$descriptor_s     res;
10160     char *p, *buff;
10161     unsigned long int tmpsts;
10162     unsigned long rsts;
10163     unsigned long flags = 0;
10164     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10165     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10166
10167     /* Set up result descriptor, and get next file. */
10168     Newx(buff, VMS_MAXRSS, char);
10169     res.dsc$a_pointer = buff;
10170     res.dsc$w_length = VMS_MAXRSS - 1;
10171     res.dsc$b_dtype = DSC$K_DTYPE_T;
10172     res.dsc$b_class = DSC$K_CLASS_S;
10173
10174 #ifdef VMS_LONGNAME_SUPPORT
10175     flags = LIB$M_FIL_LONG_NAMES;
10176 #endif
10177
10178     tmpsts = lib$find_file
10179         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10180     if (dd->context == 0)
10181         tmpsts = RMS$_NMF;  /* None left. (should be set, but make sure) */
10182
10183     if (!(tmpsts & 1)) {
10184       switch (tmpsts) {
10185         case RMS$_NMF:
10186           break;  /* no more files considered success */
10187         case RMS$_PRV:
10188           SETERRNO(EACCES, tmpsts); break;
10189         case RMS$_DEV:
10190           SETERRNO(ENODEV, tmpsts); break;
10191         case RMS$_DIR:
10192           SETERRNO(ENOTDIR, tmpsts); break;
10193         case RMS$_FNF: case RMS$_DNF:
10194           SETERRNO(ENOENT, tmpsts); break;
10195         default:
10196           SETERRNO(EVMSERR, tmpsts);
10197       }
10198       Safefree(buff);
10199       return NULL;
10200     }
10201     dd->count++;
10202     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10203     buff[res.dsc$w_length] = '\0';
10204     p = buff + res.dsc$w_length;
10205     while (--p >= buff) if (!isspace(*p)) break;
10206     *p = '\0';
10207     if (!decc_efs_case_preserve) {
10208       for (p = buff; *p; p++) *p = _tolower(*p);
10209     }
10210
10211     /* Skip any directory component and just copy the name. */
10212     sts = vms_split_path
10213        (buff,
10214         &v_spec,
10215         &v_len,
10216         &r_spec,
10217         &r_len,
10218         &d_spec,
10219         &d_len,
10220         &n_spec,
10221         &n_len,
10222         &e_spec,
10223         &e_len,
10224         &vs_spec,
10225         &vs_len);
10226
10227     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10228
10229         /* In Unix report mode, remove the ".dir;1" from the name */
10230         /* if it is a real directory. */
10231         if (decc_filename_unix_report && decc_efs_charset) {
10232             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10233                 Stat_t statbuf;
10234                 int ret_sts;
10235
10236                 ret_sts = flex_lstat(buff, &statbuf);
10237                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10238                     e_len = 0;
10239                     e_spec[0] = 0;
10240                 }
10241             }
10242         }
10243
10244         /* Drop NULL extensions on UNIX file specification */
10245         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10246             e_len = 0;
10247             e_spec[0] = '\0';
10248         }
10249     }
10250
10251     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10252     dd->entry.d_name[n_len + e_len] = '\0';
10253     dd->entry.d_namlen = n_len + e_len;
10254
10255     /* Convert the filename to UNIX format if needed */
10256     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10257
10258         /* Translate the encoded characters. */
10259         /* Fixme: Unicode handling could result in embedded 0 characters */
10260         if (strchr(dd->entry.d_name, '^') != NULL) {
10261             char new_name[256];
10262             char * q;
10263             p = dd->entry.d_name;
10264             q = new_name;
10265             while (*p != 0) {
10266                 int inchars_read, outchars_added;
10267                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10268                 p += inchars_read;
10269                 q += outchars_added;
10270                 /* fix-me */
10271                 /* if outchars_added > 1, then this is a wide file specification */
10272                 /* Wide file specifications need to be passed in Perl */
10273                 /* counted strings apparently with a Unicode flag */
10274             }
10275             *q = 0;
10276             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10277         }
10278     }
10279
10280     dd->entry.vms_verscount = 0;
10281     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10282     Safefree(buff);
10283     return &dd->entry;
10284
10285 }  /* end of readdir() */
10286 /*}}}*/
10287
10288 /*
10289  *  Read the next entry from the directory -- thread-safe version.
10290  */
10291 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10292 int
10293 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10294 {
10295     int retval;
10296
10297     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10298
10299     entry = readdir(dd);
10300     *result = entry;
10301     retval = ( *result == NULL ? errno : 0 );
10302
10303     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10304
10305     return retval;
10306
10307 }  /* end of readdir_r() */
10308 /*}}}*/
10309
10310 /*
10311  *  Return something that can be used in a seekdir later.
10312  */
10313 /*{{{ long telldir(DIR *dd)*/
10314 long
10315 Perl_telldir(DIR *dd)
10316 {
10317     return dd->count;
10318 }
10319 /*}}}*/
10320
10321 /*
10322  *  Return to a spot where we used to be.  Brute force.
10323  */
10324 /*{{{ void seekdir(DIR *dd,long count)*/
10325 void
10326 Perl_seekdir(pTHX_ DIR *dd, long count)
10327 {
10328     int old_flags;
10329
10330     /* If we haven't done anything yet... */
10331     if (dd->count == 0)
10332         return;
10333
10334     /* Remember some state, and clear it. */
10335     old_flags = dd->flags;
10336     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10337     _ckvmssts(lib$find_file_end(&dd->context));
10338     dd->context = 0;
10339
10340     /* The increment is in readdir(). */
10341     for (dd->count = 0; dd->count < count; )
10342         readdir(dd);
10343
10344     dd->flags = old_flags;
10345
10346 }  /* end of seekdir() */
10347 /*}}}*/
10348
10349 /* VMS subprocess management
10350  *
10351  * my_vfork() - just a vfork(), after setting a flag to record that
10352  * the current script is trying a Unix-style fork/exec.
10353  *
10354  * vms_do_aexec() and vms_do_exec() are called in response to the
10355  * perl 'exec' function.  If this follows a vfork call, then they
10356  * call out the regular perl routines in doio.c which do an
10357  * execvp (for those who really want to try this under VMS).
10358  * Otherwise, they do exactly what the perl docs say exec should
10359  * do - terminate the current script and invoke a new command
10360  * (See below for notes on command syntax.)
10361  *
10362  * do_aspawn() and do_spawn() implement the VMS side of the perl
10363  * 'system' function.
10364  *
10365  * Note on command arguments to perl 'exec' and 'system': When handled
10366  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10367  * are concatenated to form a DCL command string.  If the first non-numeric
10368  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10369  * the command string is handed off to DCL directly.  Otherwise,
10370  * the first token of the command is taken as the filespec of an image
10371  * to run.  The filespec is expanded using a default type of '.EXE' and
10372  * the process defaults for device, directory, etc., and if found, the resultant
10373  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10374  * the command string as parameters.  This is perhaps a bit complicated,
10375  * but I hope it will form a happy medium between what VMS folks expect
10376  * from lib$spawn and what Unix folks expect from exec.
10377  */
10378
10379 static int vfork_called;
10380
10381 /*{{{int my_vfork(void)*/
10382 int
10383 my_vfork(void)
10384 {
10385   vfork_called++;
10386   return vfork();
10387 }
10388 /*}}}*/
10389
10390
10391 static void
10392 vms_execfree(struct dsc$descriptor_s *vmscmd)
10393 {
10394   if (vmscmd) {
10395       if (vmscmd->dsc$a_pointer) {
10396           PerlMem_free(vmscmd->dsc$a_pointer);
10397       }
10398       PerlMem_free(vmscmd);
10399   }
10400 }
10401
10402 static char *
10403 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10404 {
10405   char *junk, *tmps = NULL;
10406   size_t cmdlen = 0;
10407   size_t rlen;
10408   SV **idx;
10409   STRLEN n_a;
10410
10411   idx = mark;
10412   if (really) {
10413     tmps = SvPV(really,rlen);
10414     if (*tmps) {
10415       cmdlen += rlen + 1;
10416       idx++;
10417     }
10418   }
10419
10420   for (idx++; idx <= sp; idx++) {
10421     if (*idx) {
10422       junk = SvPVx(*idx,rlen);
10423       cmdlen += rlen ? rlen + 1 : 0;
10424     }
10425   }
10426   Newx(PL_Cmd, cmdlen+1, char);
10427
10428   if (tmps && *tmps) {
10429     my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10430     mark++;
10431   }
10432   else *PL_Cmd = '\0';
10433   while (++mark <= sp) {
10434     if (*mark) {
10435       char *s = SvPVx(*mark,n_a);
10436       if (!*s) continue;
10437       if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10438       my_strlcat(PL_Cmd, s, cmdlen+1);
10439     }
10440   }
10441   return PL_Cmd;
10442
10443 }  /* end of setup_argstr() */
10444
10445
10446 static unsigned long int
10447 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10448                    struct dsc$descriptor_s **pvmscmd)
10449 {
10450   char * vmsspec;
10451   char * resspec;
10452   char image_name[NAM$C_MAXRSS+1];
10453   char image_argv[NAM$C_MAXRSS+1];
10454   $DESCRIPTOR(defdsc,".EXE");
10455   $DESCRIPTOR(defdsc2,".");
10456   struct dsc$descriptor_s resdsc;
10457   struct dsc$descriptor_s *vmscmd;
10458   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10459   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10460   char *s, *rest, *cp, *wordbreak;
10461   char * cmd;
10462   int cmdlen;
10463   int isdcl;
10464
10465   vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10466   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10467
10468   /* vmsspec is a DCL command buffer, not just a filename */
10469   vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10470   if (vmsspec == NULL)
10471       _ckvmssts_noperl(SS$_INSFMEM);
10472
10473   resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10474   if (resspec == NULL)
10475       _ckvmssts_noperl(SS$_INSFMEM);
10476
10477   /* Make a copy for modification */
10478   cmdlen = strlen(incmd);
10479   cmd = (char *)PerlMem_malloc(cmdlen+1);
10480   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10481   my_strlcpy(cmd, incmd, cmdlen + 1);
10482   image_name[0] = 0;
10483   image_argv[0] = 0;
10484
10485   resdsc.dsc$a_pointer = resspec;
10486   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10487   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10488   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10489
10490   vmscmd->dsc$a_pointer = NULL;
10491   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10492   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10493   vmscmd->dsc$w_length = 0;
10494   if (pvmscmd) *pvmscmd = vmscmd;
10495
10496   if (suggest_quote) *suggest_quote = 0;
10497
10498   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10499     PerlMem_free(cmd);
10500     PerlMem_free(vmsspec);
10501     PerlMem_free(resspec);
10502     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10503   }
10504
10505   s = cmd;
10506
10507   while (*s && isspace(*s)) s++;
10508
10509   if (*s == '@' || *s == '$') {
10510     vmsspec[0] = *s;  rest = s + 1;
10511     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10512   }
10513   else { cp = vmsspec; rest = s; }
10514
10515   /* If the first word is quoted, then we need to unquote it and
10516    * escape spaces within it.  We'll expand into the resspec buffer,
10517    * then copy back into the cmd buffer, expanding the latter if
10518    * necessary.
10519    */
10520   if (*rest == '"') {
10521     char *cp2;
10522     char *r = rest;
10523     bool in_quote = 0;
10524     int clen = cmdlen;
10525     int soff = s - cmd;
10526
10527     for (cp2 = resspec;
10528          *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10529          rest++) {
10530
10531       if (*rest == ' ') {    /* Escape ' ' to '^_'. */
10532         *cp2 = '^';
10533         *(++cp2) = '_';
10534         cp2++;
10535         clen++;
10536       }
10537       else if (*rest == '"') {
10538         clen--;
10539         if (in_quote) {     /* Must be closing quote. */
10540           rest++;
10541           break;
10542         }
10543         in_quote = 1;
10544       }
10545       else {
10546         *cp2 = *rest;
10547         cp2++;
10548       }
10549     }
10550     *cp2 = '\0';
10551
10552     /* Expand the command buffer if necessary. */
10553     if (clen > cmdlen) {
10554       cmd = (char *)PerlMem_realloc(cmd, clen);
10555       if (cmd == NULL)
10556         _ckvmssts_noperl(SS$_INSFMEM);
10557       /* Where we are may have changed, so recompute offsets */
10558       r = cmd + (r - s - soff);
10559       rest = cmd + (rest - s - soff);
10560       s = cmd + soff;
10561     }
10562
10563     /* Shift the non-verb portion of the command (if any) up or
10564      * down as necessary.
10565      */
10566     if (*rest)
10567       memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10568
10569     /* Copy the unquoted and escaped command verb into place. */
10570     memcpy(r, resspec, cp2 - resspec);
10571     cmd[clen] = '\0';
10572     cmdlen = clen;
10573     rest = r;         /* Rewind for subsequent operations. */
10574   }
10575
10576   if (*rest == '.' || *rest == '/') {
10577     char *cp2;
10578     for (cp2 = resspec;
10579          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10580          rest++, cp2++) *cp2 = *rest;
10581     *cp2 = '\0';
10582     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10583       s = vmsspec;
10584
10585       /* When a UNIX spec with no file type is translated to VMS, */
10586       /* A trailing '.' is appended under ODS-5 rules.            */
10587       /* Here we do not want that trailing "." as it prevents     */
10588       /* Looking for a implied ".exe" type. */
10589       if (decc_efs_charset) {
10590           int i;
10591           i = strlen(vmsspec);
10592           if (vmsspec[i-1] == '.') {
10593               vmsspec[i-1] = '\0';
10594           }
10595       }
10596
10597       if (*rest) {
10598         for (cp2 = vmsspec + strlen(vmsspec);
10599              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10600              rest++, cp2++) *cp2 = *rest;
10601         *cp2 = '\0';
10602       }
10603     }
10604   }
10605   /* Intuit whether verb (first word of cmd) is a DCL command:
10606    *   - if first nonspace char is '@', it's a DCL indirection
10607    * otherwise
10608    *   - if verb contains a filespec separator, it's not a DCL command
10609    *   - if it doesn't, caller tells us whether to default to a DCL
10610    *     command, or to a local image unless told it's DCL (by leading '$')
10611    */
10612   if (*s == '@') {
10613       isdcl = 1;
10614       if (suggest_quote) *suggest_quote = 1;
10615   } else {
10616     char *filespec = strpbrk(s,":<[.;");
10617     rest = wordbreak = strpbrk(s," \"\t/");
10618     if (!wordbreak) wordbreak = s + strlen(s);
10619     if (*s == '$') check_img = 0;
10620     if (filespec && (filespec < wordbreak)) isdcl = 0;
10621     else isdcl = !check_img;
10622   }
10623
10624   if (!isdcl) {
10625     int rsts;
10626     imgdsc.dsc$a_pointer = s;
10627     imgdsc.dsc$w_length = wordbreak - s;
10628     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10629     if (!(retsts&1)) {
10630         _ckvmssts_noperl(lib$find_file_end(&cxt));
10631         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10632       if (!(retsts & 1) && *s == '$') {
10633         _ckvmssts_noperl(lib$find_file_end(&cxt));
10634         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10635         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10636         if (!(retsts&1)) {
10637           _ckvmssts_noperl(lib$find_file_end(&cxt));
10638           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10639         }
10640       }
10641     }
10642     _ckvmssts_noperl(lib$find_file_end(&cxt));
10643
10644     if (retsts & 1) {
10645       FILE *fp;
10646       s = resspec;
10647       while (*s && !isspace(*s)) s++;
10648       *s = '\0';
10649
10650       /* check that it's really not DCL with no file extension */
10651       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10652       if (fp) {
10653         char b[256] = {0,0,0,0};
10654         read(fileno(fp), b, 256);
10655         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10656         if (isdcl) {
10657           int shebang_len;
10658
10659           /* Check for script */
10660           shebang_len = 0;
10661           if ((b[0] == '#') && (b[1] == '!'))
10662              shebang_len = 2;
10663 #ifdef ALTERNATE_SHEBANG
10664           else {
10665             shebang_len = strlen(ALTERNATE_SHEBANG);
10666             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10667               char * perlstr;
10668                 perlstr = strstr("perl",b);
10669                 if (perlstr == NULL)
10670                   shebang_len = 0;
10671             }
10672             else
10673               shebang_len = 0;
10674           }
10675 #endif
10676
10677           if (shebang_len > 0) {
10678           int i;
10679           int j;
10680           char tmpspec[NAM$C_MAXRSS + 1];
10681
10682             i = shebang_len;
10683              /* Image is following after white space */
10684             /*--------------------------------------*/
10685             while (isprint(b[i]) && isspace(b[i]))
10686                 i++;
10687
10688             j = 0;
10689             while (isprint(b[i]) && !isspace(b[i])) {
10690                 tmpspec[j++] = b[i++];
10691                 if (j >= NAM$C_MAXRSS)
10692                    break;
10693             }
10694             tmpspec[j] = '\0';
10695
10696              /* There may be some default parameters to the image */
10697             /*---------------------------------------------------*/
10698             j = 0;
10699             while (isprint(b[i])) {
10700                 image_argv[j++] = b[i++];
10701                 if (j >= NAM$C_MAXRSS)
10702                    break;
10703             }
10704             while ((j > 0) && !isprint(image_argv[j-1]))
10705                 j--;
10706             image_argv[j] = 0;
10707
10708             /* It will need to be converted to VMS format and validated */
10709             if (tmpspec[0] != '\0') {
10710               char * iname;
10711
10712                /* Try to find the exact program requested to be run */
10713               /*---------------------------------------------------*/
10714               iname = int_rmsexpand
10715                  (tmpspec, image_name, ".exe",
10716                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10717               if (iname != NULL) {
10718                 if (cando_by_name_int
10719                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10720                   /* MCR prefix needed */
10721                   isdcl = 0;
10722                 }
10723                 else {
10724                    /* Try again with a null type */
10725                   /*----------------------------*/
10726                   iname = int_rmsexpand
10727                     (tmpspec, image_name, ".",
10728                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10729                   if (iname != NULL) {
10730                     if (cando_by_name_int
10731                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10732                       /* MCR prefix needed */
10733                       isdcl = 0;
10734                     }
10735                   }
10736                 }
10737
10738                  /* Did we find the image to run the script? */
10739                 /*------------------------------------------*/
10740                 if (isdcl) {
10741                   char *tchr;
10742
10743                    /* Assume DCL or foreign command exists */
10744                   /*--------------------------------------*/
10745                   tchr = strrchr(tmpspec, '/');
10746                   if (tchr != NULL) {
10747                     tchr++;
10748                   }
10749                   else {
10750                     tchr = tmpspec;
10751                   }
10752                   my_strlcpy(image_name, tchr, sizeof(image_name));
10753                 }
10754               }
10755             }
10756           }
10757         }
10758         fclose(fp);
10759       }
10760       if (check_img && isdcl) {
10761           PerlMem_free(cmd);
10762           PerlMem_free(resspec);
10763           PerlMem_free(vmsspec);
10764           return RMS$_FNF;
10765       }
10766
10767       if (cando_by_name(S_IXUSR,0,resspec)) {
10768         vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10769         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10770         if (!isdcl) {
10771             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10772             if (image_name[0] != 0) {
10773                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10774                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10775             }
10776         } else if (image_name[0] != 0) {
10777             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10778             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10779         } else {
10780             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10781         }
10782         if (suggest_quote) *suggest_quote = 1;
10783
10784         /* If there is an image name, use original command */
10785         if (image_name[0] == 0)
10786             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10787         else {
10788             rest = cmd;
10789             while (*rest && isspace(*rest)) rest++;
10790         }
10791
10792         if (image_argv[0] != 0) {
10793           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10794           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10795         }
10796         if (rest) {
10797            int rest_len;
10798            int vmscmd_len;
10799
10800            rest_len = strlen(rest);
10801            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10802            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10803               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10804            else
10805              retsts = CLI$_BUFOVF;
10806         }
10807         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10808         PerlMem_free(cmd);
10809         PerlMem_free(vmsspec);
10810         PerlMem_free(resspec);
10811         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10812       }
10813       else
10814         retsts = RMS$_PRV;
10815     }
10816   }
10817   /* It's either a DCL command or we couldn't find a suitable image */
10818   vmscmd->dsc$w_length = strlen(cmd);
10819
10820   vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10821   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10822
10823   PerlMem_free(cmd);
10824   PerlMem_free(resspec);
10825   PerlMem_free(vmsspec);
10826
10827   /* check if it's a symbol (for quoting purposes) */
10828   if (suggest_quote && !*suggest_quote) {
10829     int iss;
10830     char equiv[LNM$C_NAMLENGTH];
10831     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10832     eqvdsc.dsc$a_pointer = equiv;
10833
10834     iss = lib$get_symbol(vmscmd,&eqvdsc);
10835     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10836   }
10837   if (!(retsts & 1)) {
10838     /* just hand off status values likely to be due to user error */
10839     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10840         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10841        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10842     else { _ckvmssts_noperl(retsts); }
10843   }
10844
10845   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10846
10847 }  /* end of setup_cmddsc() */
10848
10849
10850 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10851 bool
10852 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10853 {
10854   bool exec_sts;
10855   char * cmd;
10856
10857   if (sp > mark) {
10858     if (vfork_called) {           /* this follows a vfork - act Unixish */
10859       vfork_called--;
10860       if (vfork_called < 0) {
10861         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10862         vfork_called = 0;
10863       }
10864       else return do_aexec(really,mark,sp);
10865     }
10866                                            /* no vfork - act VMSish */
10867     cmd = setup_argstr(aTHX_ really,mark,sp);
10868     exec_sts = vms_do_exec(cmd);
10869     Safefree(cmd);  /* Clean up from setup_argstr() */
10870     return exec_sts;
10871   }
10872
10873   return FALSE;
10874 }  /* end of vms_do_aexec() */
10875 /*}}}*/
10876
10877 /* {{{bool vms_do_exec(char *cmd) */
10878 bool
10879 Perl_vms_do_exec(pTHX_ const char *cmd)
10880 {
10881   struct dsc$descriptor_s *vmscmd;
10882
10883   if (vfork_called) {             /* this follows a vfork - act Unixish */
10884     vfork_called--;
10885     if (vfork_called < 0) {
10886       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10887       vfork_called = 0;
10888     }
10889     else return do_exec(cmd);
10890   }
10891
10892   {                               /* no vfork - act VMSish */
10893     unsigned long int retsts;
10894
10895     TAINT_ENV();
10896     TAINT_PROPER("exec");
10897     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10898       retsts = lib$do_command(vmscmd);
10899
10900     switch (retsts) {
10901       case RMS$_FNF: case RMS$_DNF:
10902         set_errno(ENOENT); break;
10903       case RMS$_DIR:
10904         set_errno(ENOTDIR); break;
10905       case RMS$_DEV:
10906         set_errno(ENODEV); break;
10907       case RMS$_PRV:
10908         set_errno(EACCES); break;
10909       case RMS$_SYN:
10910         set_errno(EINVAL); break;
10911       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10912         set_errno(E2BIG); break;
10913       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10914         _ckvmssts_noperl(retsts); /* fall through */
10915       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10916         set_errno(EVMSERR);
10917     }
10918     set_vaxc_errno(retsts);
10919     if (ckWARN(WARN_EXEC)) {
10920       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10921              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10922     }
10923     vms_execfree(vmscmd);
10924   }
10925
10926   return FALSE;
10927
10928 }  /* end of vms_do_exec() */
10929 /*}}}*/
10930
10931 int do_spawn2(pTHX_ const char *, int);
10932
10933 int
10934 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10935 {
10936   unsigned long int sts;
10937   char * cmd;
10938   int flags = 0;
10939
10940   if (sp > mark) {
10941
10942     /* We'll copy the (undocumented?) Win32 behavior and allow a
10943      * numeric first argument.  But the only value we'll support
10944      * through do_aspawn is a value of 1, which means spawn without
10945      * waiting for completion -- other values are ignored.
10946      */
10947     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10948         ++mark;
10949         flags = SvIVx(*mark);
10950     }
10951
10952     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10953         flags = CLI$M_NOWAIT;
10954     else
10955         flags = 0;
10956
10957     cmd = setup_argstr(aTHX_ really, mark, sp);
10958     sts = do_spawn2(aTHX_ cmd, flags);
10959     /* pp_sys will clean up cmd */
10960     return sts;
10961   }
10962   return SS$_ABORT;
10963 }  /* end of do_aspawn() */
10964 /*}}}*/
10965
10966
10967 /* {{{int do_spawn(char* cmd) */
10968 int
10969 Perl_do_spawn(pTHX_ char* cmd)
10970 {
10971     PERL_ARGS_ASSERT_DO_SPAWN;
10972
10973     return do_spawn2(aTHX_ cmd, 0);
10974 }
10975 /*}}}*/
10976
10977 /* {{{int do_spawn_nowait(char* cmd) */
10978 int
10979 Perl_do_spawn_nowait(pTHX_ char* cmd)
10980 {
10981     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10982
10983     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10984 }
10985 /*}}}*/
10986
10987 /* {{{int do_spawn2(char *cmd) */
10988 int
10989 do_spawn2(pTHX_ const char *cmd, int flags)
10990 {
10991   unsigned long int sts, substs;
10992
10993   /* The caller of this routine expects to Safefree(PL_Cmd) */
10994   Newx(PL_Cmd,10,char);
10995
10996   TAINT_ENV();
10997   TAINT_PROPER("spawn");
10998   if (!cmd || !*cmd) {
10999     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11000     if (!(sts & 1)) {
11001       switch (sts) {
11002         case RMS$_FNF:  case RMS$_DNF:
11003           set_errno(ENOENT); break;
11004         case RMS$_DIR:
11005           set_errno(ENOTDIR); break;
11006         case RMS$_DEV:
11007           set_errno(ENODEV); break;
11008         case RMS$_PRV:
11009           set_errno(EACCES); break;
11010         case RMS$_SYN:
11011           set_errno(EINVAL); break;
11012         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11013           set_errno(E2BIG); break;
11014         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11015           _ckvmssts_noperl(sts); /* fall through */
11016         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11017           set_errno(EVMSERR);
11018       }
11019       set_vaxc_errno(sts);
11020       if (ckWARN(WARN_EXEC)) {
11021         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11022                     Strerror(errno));
11023       }
11024     }
11025     sts = substs;
11026   }
11027   else {
11028     char mode[3];
11029     PerlIO * fp;
11030     if (flags & CLI$M_NOWAIT)
11031         strcpy(mode, "n");
11032     else
11033         strcpy(mode, "nW");
11034
11035     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11036     if (fp != NULL)
11037       my_pclose(fp);
11038     /* sts will be the pid in the nowait case, so leave a
11039      * hint saying not to do any bit shifting to it.
11040      */
11041     if (flags & CLI$M_NOWAIT)
11042         PL_statusvalue = -1;
11043   }
11044   return sts;
11045 }  /* end of do_spawn2() */
11046 /*}}}*/
11047
11048
11049 static unsigned int *sockflags, sockflagsize;
11050
11051 /*
11052  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11053  * routines found in some versions of the CRTL can't deal with sockets.
11054  * We don't shim the other file open routines since a socket isn't
11055  * likely to be opened by a name.
11056  */
11057 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11058 FILE *
11059 my_fdopen(int fd, const char *mode)
11060 {
11061   FILE *fp = fdopen(fd, mode);
11062
11063   if (fp) {
11064     unsigned int fdoff = fd / sizeof(unsigned int);
11065     Stat_t sbuf; /* native stat; we don't need flex_stat */
11066     if (!sockflagsize || fdoff > sockflagsize) {
11067       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11068       else           Newx  (sockflags,fdoff+2,unsigned int);
11069       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11070       sockflagsize = fdoff + 2;
11071     }
11072     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11073       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11074   }
11075   return fp;
11076
11077 }
11078 /*}}}*/
11079
11080
11081 /*
11082  * Clear the corresponding bit when the (possibly) socket stream is closed.
11083  * There still a small hole: we miss an implicit close which might occur
11084  * via freopen().  >> Todo
11085  */
11086 /*{{{ int my_fclose(FILE *fp)*/
11087 int
11088 my_fclose(FILE *fp) {
11089   if (fp) {
11090     unsigned int fd = fileno(fp);
11091     unsigned int fdoff = fd / sizeof(unsigned int);
11092
11093     if (sockflagsize && fdoff < sockflagsize)
11094       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11095   }
11096   return fclose(fp);
11097 }
11098 /*}}}*/
11099
11100
11101 /*
11102  * A simple fwrite replacement which outputs itmsz*nitm chars without
11103  * introducing record boundaries every itmsz chars.
11104  * We are using fputs, which depends on a terminating null.  We may
11105  * well be writing binary data, so we need to accommodate not only
11106  * data with nulls sprinkled in the middle but also data with no null
11107  * byte at the end.
11108  */
11109 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11110 int
11111 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11112 {
11113   char *cp, *end, *cpd;
11114   char *data;
11115   unsigned int fd = fileno(dest);
11116   unsigned int fdoff = fd / sizeof(unsigned int);
11117   int retval;
11118   int bufsize = itmsz * nitm + 1;
11119
11120   if (fdoff < sockflagsize &&
11121       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11122     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11123     return nitm;
11124   }
11125
11126   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11127   memcpy( data, src, itmsz*nitm );
11128   data[itmsz*nitm] = '\0';
11129
11130   end = data + itmsz * nitm;
11131   retval = (int) nitm; /* on success return # items written */
11132
11133   cpd = data;
11134   while (cpd <= end) {
11135     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11136     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11137     if (cp < end)
11138       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11139     cpd = cp + 1;
11140   }
11141
11142   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11143   return retval;
11144
11145 }  /* end of my_fwrite() */
11146 /*}}}*/
11147
11148 /*{{{ int my_flush(FILE *fp)*/
11149 int
11150 Perl_my_flush(pTHX_ FILE *fp)
11151 {
11152     int res;
11153     if ((res = fflush(fp)) == 0 && fp) {
11154 #ifdef VMS_DO_SOCKETS
11155         Stat_t s;
11156         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11157 #endif
11158             res = fsync(fileno(fp));
11159     }
11160 /*
11161  * If the flush succeeded but set end-of-file, we need to clear
11162  * the error because our caller may check ferror().  BTW, this
11163  * probably means we just flushed an empty file.
11164  */
11165     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11166
11167     return res;
11168 }
11169 /*}}}*/
11170
11171 /* fgetname() is not returning the correct file specifications when
11172  * decc_filename_unix_report mode is active.  So we have to have it
11173  * aways return filenames in VMS mode and convert it ourselves.
11174  */
11175
11176 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11177 char *
11178 Perl_my_fgetname(FILE *fp, char * buf) {
11179     char * retname;
11180     char * vms_name;
11181
11182     retname = fgetname(fp, buf, 1);
11183
11184     /* If we are in VMS mode, then we are done */
11185     if (!decc_filename_unix_report || (retname == NULL)) {
11186        return retname;
11187     }
11188
11189     /* Convert this to Unix format */
11190     vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11191     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11192     retname = int_tounixspec(vms_name, buf, NULL);
11193     PerlMem_free(vms_name);
11194
11195     return retname;
11196 }
11197 /*}}}*/
11198
11199 /*
11200  * Here are replacements for the following Unix routines in the VMS environment:
11201  *      getpwuid    Get information for a particular UIC or UID
11202  *      getpwnam    Get information for a named user
11203  *      getpwent    Get information for each user in the rights database
11204  *      setpwent    Reset search to the start of the rights database
11205  *      endpwent    Finish searching for users in the rights database
11206  *
11207  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11208  * (defined in pwd.h), which contains the following fields:-
11209  *      struct passwd {
11210  *              char        *pw_name;    Username (in lower case)
11211  *              char        *pw_passwd;  Hashed password
11212  *              unsigned int pw_uid;     UIC
11213  *              unsigned int pw_gid;     UIC group  number
11214  *              char        *pw_unixdir; Default device/directory (VMS-style)
11215  *              char        *pw_gecos;   Owner name
11216  *              char        *pw_dir;     Default device/directory (Unix-style)
11217  *              char        *pw_shell;   Default CLI name (eg. DCL)
11218  *      };
11219  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11220  *
11221  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11222  * not the UIC member number (eg. what's returned by getuid()),
11223  * getpwuid() can accept either as input (if uid is specified, the caller's
11224  * UIC group is used), though it won't recognise gid=0.
11225  *
11226  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11227  * information about other users in your group or in other groups, respectively.
11228  * If the required privilege is not available, then these routines fill only
11229  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11230  * string).
11231  *
11232  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11233  */
11234
11235 /* sizes of various UAF record fields */
11236 #define UAI$S_USERNAME 12
11237 #define UAI$S_IDENT    31
11238 #define UAI$S_OWNER    31
11239 #define UAI$S_DEFDEV   31
11240 #define UAI$S_DEFDIR   63
11241 #define UAI$S_DEFCLI   31
11242 #define UAI$S_PWD       8
11243
11244 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11245                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11246                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11247
11248 static char __empty[]= "";
11249 static struct passwd __passwd_empty=
11250     {(char *) __empty, (char *) __empty, 0, 0,
11251      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11252 static int contxt= 0;
11253 static struct passwd __pwdcache;
11254 static char __pw_namecache[UAI$S_IDENT+1];
11255
11256 /*
11257  * This routine does most of the work extracting the user information.
11258  */
11259 static int
11260 fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11261 {
11262     static struct {
11263         unsigned char length;
11264         char pw_gecos[UAI$S_OWNER+1];
11265     } owner;
11266     static union uicdef uic;
11267     static struct {
11268         unsigned char length;
11269         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11270     } defdev;
11271     static struct {
11272         unsigned char length;
11273         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11274     } defdir;
11275     static struct {
11276         unsigned char length;
11277         char pw_shell[UAI$S_DEFCLI+1];
11278     } defcli;
11279     static char pw_passwd[UAI$S_PWD+1];
11280
11281     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11282     struct dsc$descriptor_s name_desc;
11283     unsigned long int sts;
11284
11285     static struct itmlst_3 itmlst[]= {
11286         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11287         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11288         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11289         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11290         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11291         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11292         {0,                0,           NULL,    NULL}};
11293
11294     name_desc.dsc$w_length=  strlen(name);
11295     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11296     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11297     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11298
11299 /*  Note that sys$getuai returns many fields as counted strings. */
11300     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11301     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11302       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11303     }
11304     else { _ckvmssts(sts); }
11305     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11306
11307     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11308     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11309     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11310     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11311     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11312     owner.pw_gecos[lowner]=            '\0';
11313     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11314     defcli.pw_shell[ldefcli]=          '\0';
11315     if (valid_uic(uic)) {
11316         pwd->pw_uid= uic.uic$l_uic;
11317         pwd->pw_gid= uic.uic$v_group;
11318     }
11319     else
11320       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11321     pwd->pw_passwd=  pw_passwd;
11322     pwd->pw_gecos=   owner.pw_gecos;
11323     pwd->pw_dir=     defdev.pw_dir;
11324     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11325     pwd->pw_shell=   defcli.pw_shell;
11326     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11327         int ldir;
11328         ldir= strlen(pwd->pw_unixdir) - 1;
11329         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11330     }
11331     else
11332         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11333     if (!decc_efs_case_preserve)
11334         __mystrtolower(pwd->pw_unixdir);
11335     return 1;
11336 }
11337
11338 /*
11339  * Get information for a named user.
11340 */
11341 /*{{{struct passwd *getpwnam(char *name)*/
11342 struct passwd *
11343 Perl_my_getpwnam(pTHX_ const char *name)
11344 {
11345     struct dsc$descriptor_s name_desc;
11346     union uicdef uic;
11347     unsigned long int sts;
11348
11349     __pwdcache = __passwd_empty;
11350     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11351       /* We still may be able to determine pw_uid and pw_gid */
11352       name_desc.dsc$w_length=  strlen(name);
11353       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11354       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11355       name_desc.dsc$a_pointer= (char *) name;
11356       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11357         __pwdcache.pw_uid= uic.uic$l_uic;
11358         __pwdcache.pw_gid= uic.uic$v_group;
11359       }
11360       else {
11361         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11362           set_vaxc_errno(sts);
11363           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11364           return NULL;
11365         }
11366         else { _ckvmssts(sts); }
11367       }
11368     }
11369     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11370     __pwdcache.pw_name= __pw_namecache;
11371     return &__pwdcache;
11372 }  /* end of my_getpwnam() */
11373 /*}}}*/
11374
11375 /*
11376  * Get information for a particular UIC or UID.
11377  * Called by my_getpwent with uid=-1 to list all users.
11378 */
11379 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11380 struct passwd *
11381 Perl_my_getpwuid(pTHX_ Uid_t uid)
11382 {
11383     const $DESCRIPTOR(name_desc,__pw_namecache);
11384     unsigned short lname;
11385     union uicdef uic;
11386     unsigned long int status;
11387
11388     if (uid == (unsigned int) -1) {
11389       do {
11390         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11391         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11392           set_vaxc_errno(status);
11393           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11394           my_endpwent();
11395           return NULL;
11396         }
11397         else { _ckvmssts(status); }
11398       } while (!valid_uic (uic));
11399     }
11400     else {
11401       uic.uic$l_uic= uid;
11402       if (!uic.uic$v_group)
11403         uic.uic$v_group= PerlProc_getgid();
11404       if (valid_uic(uic))
11405         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11406       else status = SS$_IVIDENT;
11407       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11408           status == RMS$_PRV) {
11409         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11410         return NULL;
11411       }
11412       else { _ckvmssts(status); }
11413     }
11414     __pw_namecache[lname]= '\0';
11415     __mystrtolower(__pw_namecache);
11416
11417     __pwdcache = __passwd_empty;
11418     __pwdcache.pw_name = __pw_namecache;
11419
11420 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11421     The identifier's value is usually the UIC, but it doesn't have to be,
11422     so if we can, we let fillpasswd update this. */
11423     __pwdcache.pw_uid =  uic.uic$l_uic;
11424     __pwdcache.pw_gid =  uic.uic$v_group;
11425
11426     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11427     return &__pwdcache;
11428
11429 }  /* end of my_getpwuid() */
11430 /*}}}*/
11431
11432 /*
11433  * Get information for next user.
11434 */
11435 /*{{{struct passwd *my_getpwent()*/
11436 struct passwd *
11437 Perl_my_getpwent(pTHX)
11438 {
11439     return (my_getpwuid((unsigned int) -1));
11440 }
11441 /*}}}*/
11442
11443 /*
11444  * Finish searching rights database for users.
11445 */
11446 /*{{{void my_endpwent()*/
11447 void
11448 Perl_my_endpwent(pTHX)
11449 {
11450     if (contxt) {
11451       _ckvmssts(sys$finish_rdb(&contxt));
11452       contxt= 0;
11453     }
11454 }
11455 /*}}}*/
11456
11457 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11458  * my_utime(), and flex_stat(), all of which operate on UTC unless
11459  * VMSISH_TIMES is true.
11460  */
11461 /* method used to handle UTC conversions:
11462  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11463  */
11464 static int gmtime_emulation_type;
11465 /* number of secs to add to UTC POSIX-style time to get local time */
11466 static long int utc_offset_secs;
11467
11468 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11469  * in vmsish.h.  #undef them here so we can call the CRTL routines
11470  * directly.
11471  */
11472 #undef gmtime
11473 #undef localtime
11474 #undef time
11475
11476
11477 static time_t toutc_dst(time_t loc) {
11478   struct tm *rsltmp;
11479
11480   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11481   loc -= utc_offset_secs;
11482   if (rsltmp->tm_isdst) loc -= 3600;
11483   return loc;
11484 }
11485 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11486        ((gmtime_emulation_type || my_time(NULL)), \
11487        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11488        ((secs) - utc_offset_secs))))
11489
11490 static time_t toloc_dst(time_t utc) {
11491   struct tm *rsltmp;
11492
11493   utc += utc_offset_secs;
11494   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11495   if (rsltmp->tm_isdst) utc += 3600;
11496   return utc;
11497 }
11498 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11499        ((gmtime_emulation_type || my_time(NULL)), \
11500        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11501        ((secs) + utc_offset_secs))))
11502
11503 /* my_time(), my_localtime(), my_gmtime()
11504  * By default traffic in UTC time values, using CRTL gmtime() or
11505  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11506  * Note: We need to use these functions even when the CRTL has working
11507  * UTC support, since they also handle C<use vmsish qw(times);>
11508  *
11509  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11510  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11511  */
11512
11513 /*{{{time_t my_time(time_t *timep)*/
11514 time_t
11515 Perl_my_time(pTHX_ time_t *timep)
11516 {
11517   time_t when;
11518   struct tm *tm_p;
11519
11520   if (gmtime_emulation_type == 0) {
11521     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11522                               /* results of calls to gmtime() and localtime() */
11523                               /* for same &base */
11524
11525     gmtime_emulation_type++;
11526     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11527       char off[LNM$C_NAMLENGTH+1];;
11528
11529       gmtime_emulation_type++;
11530       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11531         gmtime_emulation_type++;
11532         utc_offset_secs = 0;
11533         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11534       }
11535       else { utc_offset_secs = atol(off); }
11536     }
11537     else { /* We've got a working gmtime() */
11538       struct tm gmt, local;
11539
11540       gmt = *tm_p;
11541       tm_p = localtime(&base);
11542       local = *tm_p;
11543       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11544       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11545       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11546       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11547     }
11548   }
11549
11550   when = time(NULL);
11551 # ifdef VMSISH_TIME
11552   if (VMSISH_TIME) when = _toloc(when);
11553 # endif
11554   if (timep != NULL) *timep = when;
11555   return when;
11556
11557 }  /* end of my_time() */
11558 /*}}}*/
11559
11560
11561 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11562 struct tm *
11563 Perl_my_gmtime(pTHX_ const time_t *timep)
11564 {
11565   time_t when;
11566   struct tm *rsltmp;
11567
11568   if (timep == NULL) {
11569     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11570     return NULL;
11571   }
11572   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11573
11574   when = *timep;
11575 # ifdef VMSISH_TIME
11576   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11577 #  endif
11578   return gmtime(&when);
11579 }  /* end of my_gmtime() */
11580 /*}}}*/
11581
11582
11583 /*{{{struct tm *my_localtime(const time_t *timep)*/
11584 struct tm *
11585 Perl_my_localtime(pTHX_ const time_t *timep)
11586 {
11587   time_t when;
11588
11589   if (timep == NULL) {
11590     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11591     return NULL;
11592   }
11593   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11594   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11595
11596   when = *timep;
11597 # ifdef VMSISH_TIME
11598   if (VMSISH_TIME) when = _toutc(when);
11599 # endif
11600   /* CRTL localtime() wants UTC as input, does tz correction itself */
11601   return localtime(&when);
11602 } /*  end of my_localtime() */
11603 /*}}}*/
11604
11605 /* Reset definitions for later calls */
11606 #define gmtime(t)    my_gmtime(t)
11607 #define localtime(t) my_localtime(t)
11608 #define time(t)      my_time(t)
11609
11610
11611 /* my_utime - update modification/access time of a file
11612  *
11613  * VMS 7.3 and later implementation
11614  * Only the UTC translation is home-grown. The rest is handled by the
11615  * CRTL utime(), which will take into account the relevant feature
11616  * logicals and ODS-5 volume characteristics for true access times.
11617  *
11618  * pre VMS 7.3 implementation:
11619  * The calling sequence is identical to POSIX utime(), but under
11620  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11621  * not maintain access times.  Restrictions differ from the POSIX
11622  * definition in that the time can be changed as long as the
11623  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11624  * no separate checks are made to insure that the caller is the
11625  * owner of the file or has special privs enabled.
11626  * Code here is based on Joe Meadows' FILE utility.
11627  *
11628  */
11629
11630 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11631  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11632  * in 100 ns intervals.
11633  */
11634 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11635
11636 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11637 int
11638 Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11639 {
11640 #if __CRTL_VER >= 70300000
11641   struct utimbuf utc_utimes, *utc_utimesp;
11642
11643   if (utimes != NULL) {
11644     utc_utimes.actime = utimes->actime;
11645     utc_utimes.modtime = utimes->modtime;
11646 # ifdef VMSISH_TIME
11647     /* If input was local; convert to UTC for sys svc */
11648     if (VMSISH_TIME) {
11649       utc_utimes.actime = _toutc(utimes->actime);
11650       utc_utimes.modtime = _toutc(utimes->modtime);
11651     }
11652 # endif
11653     utc_utimesp = &utc_utimes;
11654   }
11655   else {
11656     utc_utimesp = NULL;
11657   }
11658
11659   return utime(file, utc_utimesp);
11660
11661 #else /* __CRTL_VER < 70300000 */
11662
11663   int i;
11664   int sts;
11665   long int bintime[2], len = 2, lowbit, unixtime,
11666            secscale = 10000000; /* seconds --> 100 ns intervals */
11667   unsigned long int chan, iosb[2], retsts;
11668   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11669   struct FAB myfab = cc$rms_fab;
11670   struct NAM mynam = cc$rms_nam;
11671 #if defined (__DECC) && defined (__VAX)
11672   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11673    * at least through VMS V6.1, which causes a type-conversion warning.
11674    */
11675 #  pragma message save
11676 #  pragma message disable cvtdiftypes
11677 #endif
11678   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11679   struct fibdef myfib;
11680 #if defined (__DECC) && defined (__VAX)
11681   /* This should be right after the declaration of myatr, but due
11682    * to a bug in VAX DEC C, this takes effect a statement early.
11683    */
11684 #  pragma message restore
11685 #endif
11686   /* cast ok for read only parameter */
11687   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11688                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11689                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11690
11691   if (file == NULL || *file == '\0') {
11692     SETERRNO(ENOENT, LIB$_INVARG);
11693     return -1;
11694   }
11695
11696   /* Convert to VMS format ensuring that it will fit in 255 characters */
11697   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11698       SETERRNO(ENOENT, LIB$_INVARG);
11699       return -1;
11700   }
11701   if (utimes != NULL) {
11702     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11703      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11704      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11705      * as input, we force the sign bit to be clear by shifting unixtime right
11706      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11707      */
11708     lowbit = (utimes->modtime & 1) ? secscale : 0;
11709     unixtime = (long int) utimes->modtime;
11710 #   ifdef VMSISH_TIME
11711     /* If input was UTC; convert to local for sys svc */
11712     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11713 #   endif
11714     unixtime >>= 1;  secscale <<= 1;
11715     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11716     if (!(retsts & 1)) {
11717       SETERRNO(EVMSERR, retsts);
11718       return -1;
11719     }
11720     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11721     if (!(retsts & 1)) {
11722       SETERRNO(EVMSERR, retsts);
11723       return -1;
11724     }
11725   }
11726   else {
11727     /* Just get the current time in VMS format directly */
11728     retsts = sys$gettim(bintime);
11729     if (!(retsts & 1)) {
11730       SETERRNO(EVMSERR, retsts);
11731       return -1;
11732     }
11733   }
11734
11735   myfab.fab$l_fna = vmsspec;
11736   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11737   myfab.fab$l_nam = &mynam;
11738   mynam.nam$l_esa = esa;
11739   mynam.nam$b_ess = (unsigned char) sizeof esa;
11740   mynam.nam$l_rsa = rsa;
11741   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11742   if (decc_efs_case_preserve)
11743       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11744
11745   /* Look for the file to be affected, letting RMS parse the file
11746    * specification for us as well.  I have set errno using only
11747    * values documented in the utime() man page for VMS POSIX.
11748    */
11749   retsts = sys$parse(&myfab,0,0);
11750   if (!(retsts & 1)) {
11751     set_vaxc_errno(retsts);
11752     if      (retsts == RMS$_PRV) set_errno(EACCES);
11753     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11754     else                         set_errno(EVMSERR);
11755     return -1;
11756   }
11757   retsts = sys$search(&myfab,0,0);
11758   if (!(retsts & 1)) {
11759     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11760     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11761     set_vaxc_errno(retsts);
11762     if      (retsts == RMS$_PRV) set_errno(EACCES);
11763     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11764     else                         set_errno(EVMSERR);
11765     return -1;
11766   }
11767
11768   devdsc.dsc$w_length = mynam.nam$b_dev;
11769   /* cast ok for read only parameter */
11770   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11771
11772   retsts = sys$assign(&devdsc,&chan,0,0);
11773   if (!(retsts & 1)) {
11774     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11775     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11776     set_vaxc_errno(retsts);
11777     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11778     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11779     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11780     else                               set_errno(EVMSERR);
11781     return -1;
11782   }
11783
11784   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11785   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11786
11787   memset((void *) &myfib, 0, sizeof myfib);
11788 #if defined(__DECC) || defined(__DECCXX)
11789   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11790   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11791   /* This prevents the revision time of the file being reset to the current
11792    * time as a result of our IO$_MODIFY $QIO. */
11793   myfib.fib$l_acctl = FIB$M_NORECORD;
11794 #else
11795   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11796   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11797   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11798 #endif
11799   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11800   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11801   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11802   _ckvmssts(sys$dassgn(chan));
11803   if (retsts & 1) retsts = iosb[0];
11804   if (!(retsts & 1)) {
11805     set_vaxc_errno(retsts);
11806     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11807     else                      set_errno(EVMSERR);
11808     return -1;
11809   }
11810
11811   return 0;
11812
11813 #endif /* #if __CRTL_VER >= 70300000 */
11814
11815 }  /* end of my_utime() */
11816 /*}}}*/
11817
11818 /*
11819  * flex_stat, flex_lstat, flex_fstat
11820  * basic stat, but gets it right when asked to stat
11821  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11822  */
11823
11824 #ifndef _USE_STD_STAT
11825 /* encode_dev packs a VMS device name string into an integer to allow
11826  * simple comparisons. This can be used, for example, to check whether two
11827  * files are located on the same device, by comparing their encoded device
11828  * names. Even a string comparison would not do, because stat() reuses the
11829  * device name buffer for each call; so without encode_dev, it would be
11830  * necessary to save the buffer and use strcmp (this would mean a number of
11831  * changes to the standard Perl code, to say nothing of what a Perl script
11832  * would have to do.
11833  *
11834  * The device lock id, if it exists, should be unique (unless perhaps compared
11835  * with lock ids transferred from other nodes). We have a lock id if the disk is
11836  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11837  * device names. Thus we use the lock id in preference, and only if that isn't
11838  * available, do we try to pack the device name into an integer (flagged by
11839  * the sign bit (LOCKID_MASK) being set).
11840  *
11841  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11842  * name and its encoded form, but it seems very unlikely that we will find
11843  * two files on different disks that share the same encoded device names,
11844  * and even more remote that they will share the same file id (if the test
11845  * is to check for the same file).
11846  *
11847  * A better method might be to use sys$device_scan on the first call, and to
11848  * search for the device, returning an index into the cached array.
11849  * The number returned would be more intelligible.
11850  * This is probably not worth it, and anyway would take quite a bit longer
11851  * on the first call.
11852  */
11853 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11854 static mydev_t
11855 encode_dev (pTHX_ const char *dev)
11856 {
11857   int i;
11858   unsigned long int f;
11859   mydev_t enc;
11860   char c;
11861   const char *q;
11862
11863   if (!dev || !dev[0]) return 0;
11864
11865 #if LOCKID_MASK
11866   {
11867     struct dsc$descriptor_s dev_desc;
11868     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11869
11870     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11871        can try that first. */
11872     dev_desc.dsc$w_length =  strlen (dev);
11873     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11874     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11875     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11876     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11877     if (!$VMS_STATUS_SUCCESS(status)) {
11878       switch (status) {
11879         case SS$_NOSUCHDEV:
11880           SETERRNO(ENODEV, status);
11881           return 0;
11882         default:
11883           _ckvmssts(status);
11884       }
11885     }
11886     if (lockid) return (lockid & ~LOCKID_MASK);
11887   }
11888 #endif
11889
11890   /* Otherwise we try to encode the device name */
11891   enc = 0;
11892   f = 1;
11893   i = 0;
11894   for (q = dev + strlen(dev); q--; q >= dev) {
11895     if (*q == ':')
11896         break;
11897     if (isdigit (*q))
11898       c= (*q) - '0';
11899     else if (isalpha (toupper (*q)))
11900       c= toupper (*q) - 'A' + (char)10;
11901     else
11902       continue; /* Skip '$'s */
11903     i++;
11904     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11905     if (i>1) f *= 36;
11906     enc += f * (unsigned long int) c;
11907   }
11908   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11909
11910 }  /* end of encode_dev() */
11911 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11912         device_no = encode_dev(aTHX_ devname)
11913 #else
11914 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11915         device_no = new_dev_no
11916 #endif
11917
11918 static int
11919 is_null_device(const char *name)
11920 {
11921   if (decc_bug_devnull != 0) {
11922     if (strncmp("/dev/null", name, 9) == 0)
11923       return 1;
11924   }
11925     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11926        The underscore prefix, controller letter, and unit number are
11927        independently optional; for our purposes, the colon punctuation
11928        is not.  The colon can be trailed by optional directory and/or
11929        filename, but two consecutive colons indicates a nodename rather
11930        than a device.  [pr]  */
11931   if (*name == '_') ++name;
11932   if (tolower(*name++) != 'n') return 0;
11933   if (tolower(*name++) != 'l') return 0;
11934   if (tolower(*name) == 'a') ++name;
11935   if (*name == '0') ++name;
11936   return (*name++ == ':') && (*name != ':');
11937 }
11938
11939 static int
11940 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11941
11942 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11943
11944 static I32
11945 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective, const char *fname, int opts)
11946 {
11947   char usrname[L_cuserid];
11948   struct dsc$descriptor_s usrdsc =
11949          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11950   char *vmsname = NULL, *fileified = NULL;
11951   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11952   unsigned short int retlen, trnlnm_iter_count;
11953   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11954   union prvdef curprv;
11955   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11956          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11957          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11958   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11959          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11960          {0,0,0,0}};
11961   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11962          {0,0,0,0}};
11963   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11964   Stat_t st;
11965   static int profile_context = -1;
11966
11967   if (!fname || !*fname) return FALSE;
11968
11969   /* Make sure we expand logical names, since sys$check_access doesn't */
11970   fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11971   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11972   if (!strpbrk(fname,"/]>:")) {
11973       my_strlcpy(fileified, fname, VMS_MAXRSS);
11974       trnlnm_iter_count = 0;
11975       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11976         trnlnm_iter_count++;
11977         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11978       }
11979       fname = fileified;
11980   }
11981
11982   vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11983   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11984   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11985     /* Don't know if already in VMS format, so make sure */
11986     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11987       PerlMem_free(fileified);
11988       PerlMem_free(vmsname);
11989       return FALSE;
11990     }
11991   }
11992   else {
11993     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11994   }
11995
11996   /* sys$check_access needs a file spec, not a directory spec.
11997    * flex_stat now will handle a null thread context during startup.
11998    */
11999
12000   retlen = namdsc.dsc$w_length = strlen(vmsname);
12001   if (vmsname[retlen-1] == ']'
12002       || vmsname[retlen-1] == '>'
12003       || vmsname[retlen-1] == ':'
12004       || (!flex_stat_int(vmsname, &st, 1) &&
12005           S_ISDIR(st.st_mode))) {
12006
12007       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12008         PerlMem_free(fileified);
12009         PerlMem_free(vmsname);
12010         return FALSE;
12011       }
12012       fname = fileified;
12013   }
12014   else {
12015       fname = vmsname;
12016   }
12017
12018   retlen = namdsc.dsc$w_length = strlen(fname);
12019   namdsc.dsc$a_pointer = (char *)fname;
12020
12021   switch (bit) {
12022     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12023       access = ARM$M_EXECUTE;
12024       flags = CHP$M_READ;
12025       break;
12026     case S_IRUSR: case S_IRGRP: case S_IROTH:
12027       access = ARM$M_READ;
12028       flags = CHP$M_READ | CHP$M_USEREADALL;
12029       break;
12030     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12031       access = ARM$M_WRITE;
12032       flags = CHP$M_READ | CHP$M_WRITE;
12033       break;
12034     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12035       access = ARM$M_DELETE;
12036       flags = CHP$M_READ | CHP$M_WRITE;
12037       break;
12038     default:
12039       if (fileified != NULL)
12040         PerlMem_free(fileified);
12041       if (vmsname != NULL)
12042         PerlMem_free(vmsname);
12043       return FALSE;
12044   }
12045
12046   /* Before we call $check_access, create a user profile with the current
12047    * process privs since otherwise it just uses the default privs from the
12048    * UAF and might give false positives or negatives.  This only works on
12049    * VMS versions v6.0 and later since that's when sys$create_user_profile
12050    * became available.
12051    */
12052
12053   /* get current process privs and username */
12054   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12055   _ckvmssts_noperl(iosb[0]);
12056
12057   /* find out the space required for the profile */
12058   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12059                                     &usrprodsc.dsc$w_length,&profile_context));
12060
12061   /* allocate space for the profile and get it filled in */
12062   usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
12063   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12064   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12065                                     &usrprodsc.dsc$w_length,&profile_context));
12066
12067   /* use the profile to check access to the file; free profile & analyze results */
12068   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12069   PerlMem_free(usrprodsc.dsc$a_pointer);
12070   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12071
12072   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12073       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12074       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12075     set_vaxc_errno(retsts);
12076     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12077     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12078     else set_errno(ENOENT);
12079     if (fileified != NULL)
12080       PerlMem_free(fileified);
12081     if (vmsname != NULL)
12082       PerlMem_free(vmsname);
12083     return FALSE;
12084   }
12085   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12086     if (fileified != NULL)
12087       PerlMem_free(fileified);
12088     if (vmsname != NULL)
12089       PerlMem_free(vmsname);
12090     return TRUE;
12091   }
12092   _ckvmssts_noperl(retsts);
12093
12094   if (fileified != NULL)
12095     PerlMem_free(fileified);
12096   if (vmsname != NULL)
12097     PerlMem_free(vmsname);
12098   return FALSE;  /* Should never get here */
12099
12100 }
12101
12102 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12103 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12104  * subset of the applicable information.
12105  */
12106 bool
12107 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12108 {
12109   return cando_by_name_int
12110         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12111 }  /* end of cando() */
12112 /*}}}*/
12113
12114
12115 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12116 I32
12117 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12118 {
12119    return cando_by_name_int(bit, effective, fname, 0);
12120
12121 }  /* end of cando_by_name() */
12122 /*}}}*/
12123
12124
12125 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12126 int
12127 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12128 {
12129   dSAVE_ERRNO; /* fstat may set this even on success */
12130   if (!fstat(fd, &statbufp->crtl_stat)) {
12131     char *cptr;
12132     char *vms_filename;
12133     vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12134     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12135
12136     /* Save name for cando by name in VMS format */
12137     cptr = getname(fd, vms_filename, 1);
12138
12139     /* This should not happen, but just in case */
12140     if (cptr == NULL) {
12141         statbufp->st_devnam[0] = 0;
12142     }
12143     else {
12144         /* Make sure that the saved name fits in 255 characters */
12145         cptr = int_rmsexpand_vms
12146                        (vms_filename,
12147                         statbufp->st_devnam,
12148                         0);
12149         if (cptr == NULL)
12150             statbufp->st_devnam[0] = 0;
12151     }
12152     PerlMem_free(vms_filename);
12153
12154     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12155     VMS_DEVICE_ENCODE
12156         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12157
12158 #   ifdef VMSISH_TIME
12159     if (VMSISH_TIME) {
12160       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12161       statbufp->st_atime = _toloc(statbufp->st_atime);
12162       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12163     }
12164 #   endif
12165     RESTORE_ERRNO;
12166     return 0;
12167   }
12168   return -1;
12169
12170 }  /* end of flex_fstat() */
12171 /*}}}*/
12172
12173 static int
12174 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12175 {
12176     char *temp_fspec = NULL;
12177     char *fileified = NULL;
12178     const char *save_spec;
12179     char *ret_spec;
12180     int retval = -1;
12181     char efs_hack = 0;
12182     char already_fileified = 0;
12183     dSAVEDERRNO;
12184
12185     if (!fspec) {
12186         errno = EINVAL;
12187         return retval;
12188     }
12189
12190     if (decc_bug_devnull != 0) {
12191       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12192         memset(statbufp,0,sizeof *statbufp);
12193         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12194         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12195         statbufp->st_uid = 0x00010001;
12196         statbufp->st_gid = 0x0001;
12197         time((time_t *)&statbufp->st_mtime);
12198         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12199         return 0;
12200       }
12201     }
12202
12203     SAVE_ERRNO;
12204
12205 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12206   /*
12207    * If we are in POSIX filespec mode, accept the filename as is.
12208    */
12209   if (decc_posix_compliant_pathnames == 0) {
12210 #endif
12211
12212     /* Try for a simple stat first.  If fspec contains a filename without
12213      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12214      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12215      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12216      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12217      * the file with null type, specify this by calling flex_stat() with
12218      * a '.' at the end of fspec.
12219      */
12220
12221     if (lstat_flag == 0)
12222         retval = stat(fspec, &statbufp->crtl_stat);
12223     else
12224         retval = lstat(fspec, &statbufp->crtl_stat);
12225
12226     if (!retval) {
12227         save_spec = fspec;
12228     }
12229     else {
12230         /* In the odd case where we have write but not read access
12231          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12232          */
12233         fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12234         if (fileified == NULL)
12235               _ckvmssts_noperl(SS$_INSFMEM);
12236
12237         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12238         if (ret_spec != NULL) {
12239             if (lstat_flag == 0)
12240                 retval = stat(fileified, &statbufp->crtl_stat);
12241             else
12242                 retval = lstat(fileified, &statbufp->crtl_stat);
12243             save_spec = fileified;
12244             already_fileified = 1;
12245         }
12246     }
12247
12248     if (retval && vms_bug_stat_filename) {
12249
12250         temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12251         if (temp_fspec == NULL)
12252             _ckvmssts_noperl(SS$_INSFMEM);
12253
12254         /* We should try again as a vmsified file specification. */
12255
12256         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12257         if (ret_spec != NULL) {
12258             if (lstat_flag == 0)
12259                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12260             else
12261                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12262             save_spec = temp_fspec;
12263         }
12264     }
12265
12266     if (retval) {
12267         /* Last chance - allow multiple dots without EFS CHARSET */
12268         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12269          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12270          * enable it if it isn't already.
12271          */
12272 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12273         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12274             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12275 #endif
12276         if (lstat_flag == 0)
12277             retval = stat(fspec, &statbufp->crtl_stat);
12278         else
12279             retval = lstat(fspec, &statbufp->crtl_stat);
12280         save_spec = fspec;
12281 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12282         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12283             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12284             efs_hack = 1;
12285         }
12286 #endif
12287     }
12288
12289 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12290   } else {
12291     if (lstat_flag == 0)
12292       retval = stat(temp_fspec, &statbufp->crtl_stat);
12293     else
12294       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12295       save_spec = temp_fspec;
12296   }
12297 #endif
12298
12299 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12300   /* As you were... */
12301   if (!decc_efs_charset)
12302     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12303 #endif
12304
12305     if (!retval) {
12306       char *cptr;
12307       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12308
12309       /* If this is an lstat, do not follow the link */
12310       if (lstat_flag)
12311         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12312
12313 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12314       /* If we used the efs_hack above, we must also use it here for */
12315       /* perl_cando to work */
12316       if (efs_hack && (decc_efs_charset_index > 0)) {
12317           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12318       }
12319 #endif
12320
12321       /* If we've got a directory, save a fileified, expanded version of it
12322        * in st_devnam.  If not a directory, just an expanded version.
12323        */
12324       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12325           fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12326           if (fileified == NULL)
12327               _ckvmssts_noperl(SS$_INSFMEM);
12328
12329           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12330           if (cptr != NULL)
12331               save_spec = fileified;
12332       }
12333
12334       cptr = int_rmsexpand(save_spec,
12335                            statbufp->st_devnam,
12336                            NULL,
12337                            rmsex_flags,
12338                            0,
12339                            0);
12340
12341 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12342       if (efs_hack && (decc_efs_charset_index > 0)) {
12343           decc$feature_set_value(decc_efs_charset, 1, 0);
12344       }
12345 #endif
12346
12347       /* Fix me: If this is NULL then stat found a file, and we could */
12348       /* not convert the specification to VMS - Should never happen */
12349       if (cptr == NULL)
12350         statbufp->st_devnam[0] = 0;
12351
12352       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12353       VMS_DEVICE_ENCODE
12354         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12355 #     ifdef VMSISH_TIME
12356       if (VMSISH_TIME) {
12357         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12358         statbufp->st_atime = _toloc(statbufp->st_atime);
12359         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12360       }
12361 #     endif
12362     }
12363     /* If we were successful, leave errno where we found it */
12364     if (retval == 0) RESTORE_ERRNO;
12365     if (temp_fspec)
12366         PerlMem_free(temp_fspec);
12367     if (fileified)
12368         PerlMem_free(fileified);
12369     return retval;
12370
12371 }  /* end of flex_stat_int() */
12372
12373
12374 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12375 int
12376 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12377 {
12378    return flex_stat_int(fspec, statbufp, 0);
12379 }
12380 /*}}}*/
12381
12382 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12383 int
12384 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12385 {
12386    return flex_stat_int(fspec, statbufp, 1);
12387 }
12388 /*}}}*/
12389
12390
12391 /*{{{char *my_getlogin()*/
12392 /* VMS cuserid == Unix getlogin, except calling sequence */
12393 char *
12394 my_getlogin(void)
12395 {
12396     static char user[L_cuserid];
12397     return cuserid(user);
12398 }
12399 /*}}}*/
12400
12401
12402 /*  rmscopy - copy a file using VMS RMS routines
12403  *
12404  *  Copies contents and attributes of spec_in to spec_out, except owner
12405  *  and protection information.  Name and type of spec_in are used as
12406  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12407  *  should try to propagate timestamps from the input file to the output file.
12408  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12409  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12410  *  propagated to the output file at creation iff the output file specification
12411  *  did not contain an explicit name or type, and the revision date is always
12412  *  updated at the end of the copy operation.  If it is greater than 0, then
12413  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12414  *  other than the revision date should be propagated, and bit 1 indicates
12415  *  that the revision date should be propagated.
12416  *
12417  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12418  *
12419  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12420  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12421  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12422  * as part of the Perl standard distribution under the terms of the
12423  * GNU General Public License or the Perl Artistic License.  Copies
12424  * of each may be found in the Perl standard distribution.
12425  */ /* FIXME */
12426 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12427 int
12428 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12429 {
12430     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12431          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12432     unsigned long int sts;
12433     int dna_len;
12434     struct FAB fab_in, fab_out;
12435     struct RAB rab_in, rab_out;
12436     rms_setup_nam(nam);
12437     rms_setup_nam(nam_out);
12438     struct XABDAT xabdat;
12439     struct XABFHC xabfhc;
12440     struct XABRDT xabrdt;
12441     struct XABSUM xabsum;
12442
12443     vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12444     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12445     vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12446     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12447     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12448         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12449       PerlMem_free(vmsin);
12450       PerlMem_free(vmsout);
12451       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12452       return 0;
12453     }
12454
12455     esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12456     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12457     esal = NULL;
12458 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12459     esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12460     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12461 #endif
12462     fab_in = cc$rms_fab;
12463     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12464     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12465     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12466     fab_in.fab$l_fop = FAB$M_SQO;
12467     rms_bind_fab_nam(fab_in, nam);
12468     fab_in.fab$l_xab = (void *) &xabdat;
12469
12470     rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12471     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12472     rsal = NULL;
12473 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12474     rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12475     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12476 #endif
12477     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12478     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12479     rms_nam_esl(nam) = 0;
12480     rms_nam_rsl(nam) = 0;
12481     rms_nam_esll(nam) = 0;
12482     rms_nam_rsll(nam) = 0;
12483 #ifdef NAM$M_NO_SHORT_UPCASE
12484     if (decc_efs_case_preserve)
12485         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12486 #endif
12487
12488     xabdat = cc$rms_xabdat;        /* To get creation date */
12489     xabdat.xab$l_nxt = (void *) &xabfhc;
12490
12491     xabfhc = cc$rms_xabfhc;        /* To get record length */
12492     xabfhc.xab$l_nxt = (void *) &xabsum;
12493
12494     xabsum = cc$rms_xabsum;        /* To get key and area information */
12495
12496     if (!((sts = sys$open(&fab_in)) & 1)) {
12497       PerlMem_free(vmsin);
12498       PerlMem_free(vmsout);
12499       PerlMem_free(esa);
12500       if (esal != NULL)
12501         PerlMem_free(esal);
12502       PerlMem_free(rsa);
12503       if (rsal != NULL)
12504         PerlMem_free(rsal);
12505       set_vaxc_errno(sts);
12506       switch (sts) {
12507         case RMS$_FNF: case RMS$_DNF:
12508           set_errno(ENOENT); break;
12509         case RMS$_DIR:
12510           set_errno(ENOTDIR); break;
12511         case RMS$_DEV:
12512           set_errno(ENODEV); break;
12513         case RMS$_SYN:
12514           set_errno(EINVAL); break;
12515         case RMS$_PRV:
12516           set_errno(EACCES); break;
12517         default:
12518           set_errno(EVMSERR);
12519       }
12520       return 0;
12521     }
12522
12523     nam_out = nam;
12524     fab_out = fab_in;
12525     fab_out.fab$w_ifi = 0;
12526     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12527     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12528     fab_out.fab$l_fop = FAB$M_SQO;
12529     rms_bind_fab_nam(fab_out, nam_out);
12530     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12531     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12532     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12533     esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12534     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12535     rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12536     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12537     esal_out = NULL;
12538     rsal_out = NULL;
12539 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12540     esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12541     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12542     rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12543     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12544 #endif
12545     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12546     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12547
12548     if (preserve_dates == 0) {  /* Act like DCL COPY */
12549       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12550       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12551       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12552         PerlMem_free(vmsin);
12553         PerlMem_free(vmsout);
12554         PerlMem_free(esa);
12555         if (esal != NULL)
12556             PerlMem_free(esal);
12557         PerlMem_free(rsa);
12558         if (rsal != NULL)
12559             PerlMem_free(rsal);
12560         PerlMem_free(esa_out);
12561         if (esal_out != NULL)
12562             PerlMem_free(esal_out);
12563         PerlMem_free(rsa_out);
12564         if (rsal_out != NULL)
12565             PerlMem_free(rsal_out);
12566         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12567         set_vaxc_errno(sts);
12568         return 0;
12569       }
12570       fab_out.fab$l_xab = (void *) &xabdat;
12571       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12572         preserve_dates = 1;
12573     }
12574     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12575       preserve_dates =0;      /* bitmask from this point forward   */
12576
12577     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12578     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12579       PerlMem_free(vmsin);
12580       PerlMem_free(vmsout);
12581       PerlMem_free(esa);
12582       if (esal != NULL)
12583           PerlMem_free(esal);
12584       PerlMem_free(rsa);
12585       if (rsal != NULL)
12586           PerlMem_free(rsal);
12587       PerlMem_free(esa_out);
12588       if (esal_out != NULL)
12589           PerlMem_free(esal_out);
12590       PerlMem_free(rsa_out);
12591       if (rsal_out != NULL)
12592           PerlMem_free(rsal_out);
12593       set_vaxc_errno(sts);
12594       switch (sts) {
12595         case RMS$_DNF:
12596           set_errno(ENOENT); break;
12597         case RMS$_DIR:
12598           set_errno(ENOTDIR); break;
12599         case RMS$_DEV:
12600           set_errno(ENODEV); break;
12601         case RMS$_SYN:
12602           set_errno(EINVAL); break;
12603         case RMS$_PRV:
12604           set_errno(EACCES); break;
12605         default:
12606           set_errno(EVMSERR);
12607       }
12608       return 0;
12609     }
12610     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12611     if (preserve_dates & 2) {
12612       /* sys$close() will process xabrdt, not xabdat */
12613       xabrdt = cc$rms_xabrdt;
12614 #ifndef __GNUC__
12615       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12616 #else
12617       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12618        * is unsigned long[2], while DECC & VAXC use a struct */
12619       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12620 #endif
12621       fab_out.fab$l_xab = (void *) &xabrdt;
12622     }
12623
12624     ubf = (char *)PerlMem_malloc(32256);
12625     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12626     rab_in = cc$rms_rab;
12627     rab_in.rab$l_fab = &fab_in;
12628     rab_in.rab$l_rop = RAB$M_BIO;
12629     rab_in.rab$l_ubf = ubf;
12630     rab_in.rab$w_usz = 32256;
12631     if (!((sts = sys$connect(&rab_in)) & 1)) {
12632       sys$close(&fab_in); sys$close(&fab_out);
12633       PerlMem_free(vmsin);
12634       PerlMem_free(vmsout);
12635       PerlMem_free(ubf);
12636       PerlMem_free(esa);
12637       if (esal != NULL)
12638           PerlMem_free(esal);
12639       PerlMem_free(rsa);
12640       if (rsal != NULL)
12641           PerlMem_free(rsal);
12642       PerlMem_free(esa_out);
12643       if (esal_out != NULL)
12644           PerlMem_free(esal_out);
12645       PerlMem_free(rsa_out);
12646       if (rsal_out != NULL)
12647           PerlMem_free(rsal_out);
12648       set_errno(EVMSERR); set_vaxc_errno(sts);
12649       return 0;
12650     }
12651
12652     rab_out = cc$rms_rab;
12653     rab_out.rab$l_fab = &fab_out;
12654     rab_out.rab$l_rbf = ubf;
12655     if (!((sts = sys$connect(&rab_out)) & 1)) {
12656       sys$close(&fab_in); sys$close(&fab_out);
12657       PerlMem_free(vmsin);
12658       PerlMem_free(vmsout);
12659       PerlMem_free(ubf);
12660       PerlMem_free(esa);
12661       if (esal != NULL)
12662           PerlMem_free(esal);
12663       PerlMem_free(rsa);
12664       if (rsal != NULL)
12665           PerlMem_free(rsal);
12666       PerlMem_free(esa_out);
12667       if (esal_out != NULL)
12668           PerlMem_free(esal_out);
12669       PerlMem_free(rsa_out);
12670       if (rsal_out != NULL)
12671           PerlMem_free(rsal_out);
12672       set_errno(EVMSERR); set_vaxc_errno(sts);
12673       return 0;
12674     }
12675
12676     while ((sts = sys$read(&rab_in))) {  /* always true  */
12677       if (sts == RMS$_EOF) break;
12678       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12679       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12680         sys$close(&fab_in); sys$close(&fab_out);
12681         PerlMem_free(vmsin);
12682         PerlMem_free(vmsout);
12683         PerlMem_free(ubf);
12684         PerlMem_free(esa);
12685         if (esal != NULL)
12686             PerlMem_free(esal);
12687         PerlMem_free(rsa);
12688         if (rsal != NULL)
12689             PerlMem_free(rsal);
12690         PerlMem_free(esa_out);
12691         if (esal_out != NULL)
12692             PerlMem_free(esal_out);
12693         PerlMem_free(rsa_out);
12694         if (rsal_out != NULL)
12695             PerlMem_free(rsal_out);
12696         set_errno(EVMSERR); set_vaxc_errno(sts);
12697         return 0;
12698       }
12699     }
12700
12701
12702     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12703     sys$close(&fab_in);  sys$close(&fab_out);
12704     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12705
12706     PerlMem_free(vmsin);
12707     PerlMem_free(vmsout);
12708     PerlMem_free(ubf);
12709     PerlMem_free(esa);
12710     if (esal != NULL)
12711         PerlMem_free(esal);
12712     PerlMem_free(rsa);
12713     if (rsal != NULL)
12714         PerlMem_free(rsal);
12715     PerlMem_free(esa_out);
12716     if (esal_out != NULL)
12717         PerlMem_free(esal_out);
12718     PerlMem_free(rsa_out);
12719     if (rsal_out != NULL)
12720         PerlMem_free(rsal_out);
12721
12722     if (!(sts & 1)) {
12723       set_errno(EVMSERR); set_vaxc_errno(sts);
12724       return 0;
12725     }
12726
12727     return 1;
12728
12729 }  /* end of rmscopy() */
12730 /*}}}*/
12731
12732
12733 /***  The following glue provides 'hooks' to make some of the routines
12734  * from this file available from Perl.  These routines are sufficiently
12735  * basic, and are required sufficiently early in the build process,
12736  * that's it's nice to have them available to miniperl as well as the
12737  * full Perl, so they're set up here instead of in an extension.  The
12738  * Perl code which handles importation of these names into a given
12739  * package lives in [.VMS]Filespec.pm in @INC.
12740  */
12741
12742 void
12743 rmsexpand_fromperl(pTHX_ CV *cv)
12744 {
12745   dXSARGS;
12746   char *fspec, *defspec = NULL, *rslt;
12747   STRLEN n_a;
12748   int fs_utf8, dfs_utf8;
12749
12750   fs_utf8 = 0;
12751   dfs_utf8 = 0;
12752   if (!items || items > 2)
12753     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12754   fspec = SvPV(ST(0),n_a);
12755   fs_utf8 = SvUTF8(ST(0));
12756   if (!fspec || !*fspec) XSRETURN_UNDEF;
12757   if (items == 2) {
12758     defspec = SvPV(ST(1),n_a);
12759     dfs_utf8 = SvUTF8(ST(1));
12760   }
12761   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12762   ST(0) = sv_newmortal();
12763   if (rslt != NULL) {
12764     sv_usepvn(ST(0),rslt,strlen(rslt));
12765     if (fs_utf8) {
12766         SvUTF8_on(ST(0));
12767     }
12768   }
12769   XSRETURN(1);
12770 }
12771
12772 void
12773 vmsify_fromperl(pTHX_ CV *cv)
12774 {
12775   dXSARGS;
12776   char *vmsified;
12777   STRLEN n_a;
12778   int utf8_fl;
12779
12780   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12781   utf8_fl = SvUTF8(ST(0));
12782   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12783   ST(0) = sv_newmortal();
12784   if (vmsified != NULL) {
12785     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12786     if (utf8_fl) {
12787         SvUTF8_on(ST(0));
12788     }
12789   }
12790   XSRETURN(1);
12791 }
12792
12793 void
12794 unixify_fromperl(pTHX_ CV *cv)
12795 {
12796   dXSARGS;
12797   char *unixified;
12798   STRLEN n_a;
12799   int utf8_fl;
12800
12801   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12802   utf8_fl = SvUTF8(ST(0));
12803   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12804   ST(0) = sv_newmortal();
12805   if (unixified != NULL) {
12806     sv_usepvn(ST(0),unixified,strlen(unixified));
12807     if (utf8_fl) {
12808         SvUTF8_on(ST(0));
12809     }
12810   }
12811   XSRETURN(1);
12812 }
12813
12814 void
12815 fileify_fromperl(pTHX_ CV *cv)
12816 {
12817   dXSARGS;
12818   char *fileified;
12819   STRLEN n_a;
12820   int utf8_fl;
12821
12822   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12823   utf8_fl = SvUTF8(ST(0));
12824   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12825   ST(0) = sv_newmortal();
12826   if (fileified != NULL) {
12827     sv_usepvn(ST(0),fileified,strlen(fileified));
12828     if (utf8_fl) {
12829         SvUTF8_on(ST(0));
12830     }
12831   }
12832   XSRETURN(1);
12833 }
12834
12835 void
12836 pathify_fromperl(pTHX_ CV *cv)
12837 {
12838   dXSARGS;
12839   char *pathified;
12840   STRLEN n_a;
12841   int utf8_fl;
12842
12843   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12844   utf8_fl = SvUTF8(ST(0));
12845   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12846   ST(0) = sv_newmortal();
12847   if (pathified != NULL) {
12848     sv_usepvn(ST(0),pathified,strlen(pathified));
12849     if (utf8_fl) {
12850         SvUTF8_on(ST(0));
12851     }
12852   }
12853   XSRETURN(1);
12854 }
12855
12856 void
12857 vmspath_fromperl(pTHX_ CV *cv)
12858 {
12859   dXSARGS;
12860   char *vmspath;
12861   STRLEN n_a;
12862   int utf8_fl;
12863
12864   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12865   utf8_fl = SvUTF8(ST(0));
12866   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12867   ST(0) = sv_newmortal();
12868   if (vmspath != NULL) {
12869     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12870     if (utf8_fl) {
12871         SvUTF8_on(ST(0));
12872     }
12873   }
12874   XSRETURN(1);
12875 }
12876
12877 void
12878 unixpath_fromperl(pTHX_ CV *cv)
12879 {
12880   dXSARGS;
12881   char *unixpath;
12882   STRLEN n_a;
12883   int utf8_fl;
12884
12885   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12886   utf8_fl = SvUTF8(ST(0));
12887   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12888   ST(0) = sv_newmortal();
12889   if (unixpath != NULL) {
12890     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12891     if (utf8_fl) {
12892         SvUTF8_on(ST(0));
12893     }
12894   }
12895   XSRETURN(1);
12896 }
12897
12898 void
12899 candelete_fromperl(pTHX_ CV *cv)
12900 {
12901   dXSARGS;
12902   char *fspec, *fsp;
12903   SV *mysv;
12904   IO *io;
12905   STRLEN n_a;
12906
12907   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12908
12909   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12910   Newx(fspec, VMS_MAXRSS, char);
12911   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12912   if (isGV_with_GP(mysv)) {
12913     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12914       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12915       ST(0) = &PL_sv_no;
12916       Safefree(fspec);
12917       XSRETURN(1);
12918     }
12919     fsp = fspec;
12920   }
12921   else {
12922     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12923       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12924       ST(0) = &PL_sv_no;
12925       Safefree(fspec);
12926       XSRETURN(1);
12927     }
12928   }
12929
12930   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12931   Safefree(fspec);
12932   XSRETURN(1);
12933 }
12934
12935 void
12936 rmscopy_fromperl(pTHX_ CV *cv)
12937 {
12938   dXSARGS;
12939   char *inspec, *outspec, *inp, *outp;
12940   int date_flag;
12941   SV *mysv;
12942   IO *io;
12943   STRLEN n_a;
12944
12945   if (items < 2 || items > 3)
12946     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12947
12948   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12949   Newx(inspec, VMS_MAXRSS, char);
12950   if (isGV_with_GP(mysv)) {
12951     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12952       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12953       ST(0) = sv_2mortal(newSViv(0));
12954       Safefree(inspec);
12955       XSRETURN(1);
12956     }
12957     inp = inspec;
12958   }
12959   else {
12960     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12961       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12962       ST(0) = sv_2mortal(newSViv(0));
12963       Safefree(inspec);
12964       XSRETURN(1);
12965     }
12966   }
12967   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12968   Newx(outspec, VMS_MAXRSS, char);
12969   if (isGV_with_GP(mysv)) {
12970     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12971       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12972       ST(0) = sv_2mortal(newSViv(0));
12973       Safefree(inspec);
12974       Safefree(outspec);
12975       XSRETURN(1);
12976     }
12977     outp = outspec;
12978   }
12979   else {
12980     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12981       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12982       ST(0) = sv_2mortal(newSViv(0));
12983       Safefree(inspec);
12984       Safefree(outspec);
12985       XSRETURN(1);
12986     }
12987   }
12988   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12989
12990   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12991   Safefree(inspec);
12992   Safefree(outspec);
12993   XSRETURN(1);
12994 }
12995
12996 /* The mod2fname is limited to shorter filenames by design, so it should
12997  * not be modified to support longer EFS pathnames
12998  */
12999 void
13000 mod2fname(pTHX_ CV *cv)
13001 {
13002   dXSARGS;
13003   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13004        workbuff[NAM$C_MAXRSS*1 + 1];
13005   SSize_t counter, num_entries;
13006   /* ODS-5 ups this, but we want to be consistent, so... */
13007   int max_name_len = 39;
13008   AV *in_array = (AV *)SvRV(ST(0));
13009
13010   num_entries = av_tindex(in_array);
13011
13012   /* All the names start with PL_. */
13013   strcpy(ultimate_name, "PL_");
13014
13015   /* Clean up our working buffer */
13016   Zero(work_name, sizeof(work_name), char);
13017
13018   /* Run through the entries and build up a working name */
13019   for(counter = 0; counter <= num_entries; counter++) {
13020     /* If it's not the first name then tack on a __ */
13021     if (counter) {
13022       my_strlcat(work_name, "__", sizeof(work_name));
13023     }
13024     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
13025   }
13026
13027   /* Check to see if we actually have to bother...*/
13028   if (strlen(work_name) + 3 <= max_name_len) {
13029     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
13030   } else {
13031     /* It's too darned big, so we need to go strip. We use the same */
13032     /* algorithm as xsubpp does. First, strip out doubled __ */
13033     char *source, *dest, last;
13034     dest = workbuff;
13035     last = 0;
13036     for (source = work_name; *source; source++) {
13037       if (last == *source && last == '_') {
13038         continue;
13039       }
13040       *dest++ = *source;
13041       last = *source;
13042     }
13043     /* Go put it back */
13044     my_strlcpy(work_name, workbuff, sizeof(work_name));
13045     /* Is it still too big? */
13046     if (strlen(work_name) + 3 > max_name_len) {
13047       /* Strip duplicate letters */
13048       last = 0;
13049       dest = workbuff;
13050       for (source = work_name; *source; source++) {
13051         if (last == toupper(*source)) {
13052         continue;
13053         }
13054         *dest++ = *source;
13055         last = toupper(*source);
13056       }
13057       my_strlcpy(work_name, workbuff, sizeof(work_name));
13058     }
13059
13060     /* Is it *still* too big? */
13061     if (strlen(work_name) + 3 > max_name_len) {
13062       /* Too bad, we truncate */
13063       work_name[max_name_len - 2] = 0;
13064     }
13065     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
13066   }
13067
13068   /* Okay, return it */
13069   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13070   XSRETURN(1);
13071 }
13072
13073 void
13074 hushexit_fromperl(pTHX_ CV *cv)
13075 {
13076     dXSARGS;
13077
13078     if (items > 0) {
13079         VMSISH_HUSHED = SvTRUE(ST(0));
13080     }
13081     ST(0) = boolSV(VMSISH_HUSHED);
13082     XSRETURN(1);
13083 }
13084
13085
13086 PerlIO *
13087 Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io)
13088 {
13089     PerlIO *fp;
13090     struct vs_str_st *rslt;
13091     char *vmsspec;
13092     char *rstr;
13093     char *begin, *cp;
13094     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13095     PerlIO *tmpfp;
13096     STRLEN i;
13097     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13098     struct dsc$descriptor_vs rsdsc;
13099     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13100     unsigned long hasver = 0, isunix = 0;
13101     unsigned long int lff_flags = 0;
13102     int rms_sts;
13103     int vms_old_glob = 1;
13104
13105     if (!SvOK(tmpglob)) {
13106         SETERRNO(ENOENT,RMS$_FNF);
13107         return NULL;
13108     }
13109
13110     vms_old_glob = !decc_filename_unix_report;
13111
13112 #ifdef VMS_LONGNAME_SUPPORT
13113     lff_flags = LIB$M_FIL_LONG_NAMES;
13114 #endif
13115     /* The Newx macro will not allow me to assign a smaller array
13116      * to the rslt pointer, so we will assign it to the begin char pointer
13117      * and then copy the value into the rslt pointer.
13118      */
13119     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13120     rslt = (struct vs_str_st *)begin;
13121     rslt->length = 0;
13122     rstr = &rslt->str[0];
13123     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13124     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13125     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13126     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13127
13128     Newx(vmsspec, VMS_MAXRSS, char);
13129
13130         /* We could find out if there's an explicit dev/dir or version
13131            by peeking into lib$find_file's internal context at
13132            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13133            but that's unsupported, so I don't want to do it now and
13134            have it bite someone in the future. */
13135         /* Fix-me: vms_split_path() is the only way to do this, the
13136            existing method will fail with many legal EFS or UNIX specifications
13137          */
13138
13139     cp = SvPV(tmpglob,i);
13140
13141     for (; i; i--) {
13142         if (cp[i] == ';') hasver = 1;
13143         if (cp[i] == '.') {
13144             if (sts) hasver = 1;
13145             else sts = 1;
13146         }
13147         if (cp[i] == '/') {
13148             hasdir = isunix = 1;
13149             break;
13150         }
13151         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13152             hasdir = 1;
13153             break;
13154         }
13155     }
13156
13157     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13158     if ((hasdir == 0) && decc_filename_unix_report) {
13159         isunix = 1;
13160     }
13161
13162     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13163         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13164         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13165         int wildstar = 0;
13166         int wildquery = 0;
13167         int found = 0;
13168         Stat_t st;
13169         int stat_sts;
13170         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13171         if (!stat_sts && S_ISDIR(st.st_mode)) {
13172             char * vms_dir;
13173             const char * fname;
13174             STRLEN fname_len;
13175
13176             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13177             /* path delimiter of ':>]', if so, then the old behavior has */
13178             /* obviously been specifically requested */
13179
13180             fname = SvPVX_const(tmpglob);
13181             fname_len = strlen(fname);
13182             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13183             if (vms_old_glob || (vms_dir != NULL)) {
13184                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13185                                             SvPVX(tmpglob),vmsspec,NULL);
13186                 ok = (wilddsc.dsc$a_pointer != NULL);
13187                 /* maybe passed 'foo' rather than '[.foo]', thus not
13188                    detected above */
13189                 hasdir = 1;
13190             } else {
13191                 /* Operate just on the directory, the special stat/fstat for */
13192                 /* leaves the fileified  specification in the st_devnam */
13193                 /* member. */
13194                 wilddsc.dsc$a_pointer = st.st_devnam;
13195                 ok = 1;
13196             }
13197         }
13198         else {
13199             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13200             ok = (wilddsc.dsc$a_pointer != NULL);
13201         }
13202         if (ok)
13203             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13204
13205         /* If not extended character set, replace ? with % */
13206         /* With extended character set, ? is a wildcard single character */
13207         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13208             if (*cp == '?') {
13209                 wildquery = 1;
13210                 if (!decc_efs_charset)
13211                     *cp = '%';
13212             } else if (*cp == '%') {
13213                 wildquery = 1;
13214             } else if (*cp == '*') {
13215                 wildstar = 1;
13216             }
13217         }
13218
13219         if (ok) {
13220             wv_sts = vms_split_path(
13221                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13222                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13223                 &wvs_spec, &wvs_len);
13224         } else {
13225             wn_spec = NULL;
13226             wn_len = 0;
13227             we_spec = NULL;
13228             we_len = 0;
13229         }
13230
13231         sts = SS$_NORMAL;
13232         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13233          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13234          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13235          int valid_find;
13236
13237             valid_find = 0;
13238             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13239                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13240             if (!$VMS_STATUS_SUCCESS(sts))
13241                 break;
13242
13243             /* with varying string, 1st word of buffer contains result length */
13244             rstr[rslt->length] = '\0';
13245
13246              /* Find where all the components are */
13247              v_sts = vms_split_path
13248                        (rstr,
13249                         &v_spec,
13250                         &v_len,
13251                         &r_spec,
13252                         &r_len,
13253                         &d_spec,
13254                         &d_len,
13255                         &n_spec,
13256                         &n_len,
13257                         &e_spec,
13258                         &e_len,
13259                         &vs_spec,
13260                         &vs_len);
13261
13262             /* If no version on input, truncate the version on output */
13263             if (!hasver && (vs_len > 0)) {
13264                 *vs_spec = '\0';
13265                 vs_len = 0;
13266             }
13267
13268             if (isunix) {
13269
13270                 /* In Unix report mode, remove the ".dir;1" from the name */
13271                 /* if it is a real directory */
13272                 if (decc_filename_unix_report && decc_efs_charset) {
13273                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13274                         Stat_t statbuf;
13275                         int ret_sts;
13276
13277                         ret_sts = flex_lstat(rstr, &statbuf);
13278                         if ((ret_sts == 0) &&
13279                             S_ISDIR(statbuf.st_mode)) {
13280                             e_len = 0;
13281                             e_spec[0] = 0;
13282                         }
13283                     }
13284                 }
13285
13286                 /* No version & a null extension on UNIX handling */
13287                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13288                     e_len = 0;
13289                     *e_spec = '\0';
13290                 }
13291             }
13292
13293             if (!decc_efs_case_preserve) {
13294                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13295             }
13296
13297             /* Find File treats a Null extension as return all extensions */
13298             /* This is contrary to Perl expectations */
13299
13300             if (wildstar || wildquery || vms_old_glob) {
13301                 /* really need to see if the returned file name matched */
13302                 /* but for now will assume that it matches */
13303                 valid_find = 1;
13304             } else {
13305                 /* Exact Match requested */
13306                 /* How are directories handled? - like a file */
13307                 if ((e_len == we_len) && (n_len == wn_len)) {
13308                     int t1;
13309                     t1 = e_len;
13310                     if (t1 > 0)
13311                         t1 = strncmp(e_spec, we_spec, e_len);
13312                     if (t1 == 0) {
13313                        t1 = n_len;
13314                        if (t1 > 0)
13315                            t1 = strncmp(n_spec, we_spec, n_len);
13316                        if (t1 == 0)
13317                            valid_find = 1;
13318                     }
13319                 }
13320             }
13321
13322             if (valid_find) {
13323                 found++;
13324
13325                 if (hasdir) {
13326                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13327                     begin = rstr;
13328                 }
13329                 else {
13330                     /* Start with the name */
13331                     begin = n_spec;
13332                 }
13333                 strcat(begin,"\n");
13334                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13335             }
13336         }
13337         if (cxt) (void)lib$find_file_end(&cxt);
13338
13339         if (!found) {
13340             /* Be POSIXish: return the input pattern when no matches */
13341             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13342             strcat(rstr,"\n");
13343             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13344         }
13345
13346         if (ok && sts != RMS$_NMF &&
13347             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13348         if (!ok) {
13349             if (!(sts & 1)) {
13350                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13351             }
13352             PerlIO_close(tmpfp);
13353             fp = NULL;
13354         }
13355         else {
13356             PerlIO_rewind(tmpfp);
13357             IoTYPE(io) = IoTYPE_RDONLY;
13358             IoIFP(io) = fp = tmpfp;
13359             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13360         }
13361     }
13362     Safefree(vmsspec);
13363     Safefree(rslt);
13364     return fp;
13365 }
13366
13367
13368 static char *
13369 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13370                    int *utf8_fl);
13371
13372 void
13373 unixrealpath_fromperl(pTHX_ CV *cv)
13374 {
13375     dXSARGS;
13376     char *fspec, *rslt_spec, *rslt;
13377     STRLEN n_a;
13378
13379     if (!items || items != 1)
13380         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13381
13382     fspec = SvPV(ST(0),n_a);
13383     if (!fspec || !*fspec) XSRETURN_UNDEF;
13384
13385     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13386     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13387
13388     ST(0) = sv_newmortal();
13389     if (rslt != NULL)
13390         sv_usepvn(ST(0),rslt,strlen(rslt));
13391     else
13392         Safefree(rslt_spec);
13393         XSRETURN(1);
13394 }
13395
13396 static char *
13397 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13398                    int *utf8_fl);
13399
13400 void
13401 vmsrealpath_fromperl(pTHX_ CV *cv)
13402 {
13403     dXSARGS;
13404     char *fspec, *rslt_spec, *rslt;
13405     STRLEN n_a;
13406
13407     if (!items || items != 1)
13408         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13409
13410     fspec = SvPV(ST(0),n_a);
13411     if (!fspec || !*fspec) XSRETURN_UNDEF;
13412
13413     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13414     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13415
13416     ST(0) = sv_newmortal();
13417     if (rslt != NULL)
13418         sv_usepvn(ST(0),rslt,strlen(rslt));
13419     else
13420         Safefree(rslt_spec);
13421         XSRETURN(1);
13422 }
13423
13424 #ifdef HAS_SYMLINK
13425 /*
13426  * A thin wrapper around decc$symlink to make sure we follow the
13427  * standard and do not create a symlink with a zero-length name,
13428  * and convert the target to Unix format, as the CRTL can't handle
13429  * targets in VMS format.
13430  */
13431 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13432 int
13433 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13434 {
13435     int sts;
13436     char * utarget;
13437
13438     if (!link_name || !*link_name) {
13439       SETERRNO(ENOENT, SS$_NOSUCHFILE);
13440       return -1;
13441     }
13442
13443     utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13444     /* An untranslatable filename should be passed through. */
13445     (void) int_tounixspec(contents, utarget, NULL);
13446     sts = symlink(utarget, link_name);
13447     PerlMem_free(utarget);
13448     return sts;
13449 }
13450 /*}}}*/
13451
13452 #endif /* HAS_SYMLINK */
13453
13454 int do_vms_case_tolerant(void);
13455
13456 void
13457 case_tolerant_process_fromperl(pTHX_ CV *cv)
13458 {
13459   dXSARGS;
13460   ST(0) = boolSV(do_vms_case_tolerant());
13461   XSRETURN(1);
13462 }
13463
13464 #ifdef USE_ITHREADS
13465
13466 void
13467 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13468                           struct interp_intern *dst)
13469 {
13470     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13471
13472     memcpy(dst,src,sizeof(struct interp_intern));
13473 }
13474
13475 #endif
13476
13477 void
13478 Perl_sys_intern_clear(pTHX)
13479 {
13480 }
13481
13482 void
13483 Perl_sys_intern_init(pTHX)
13484 {
13485     unsigned int ix = RAND_MAX;
13486     double x;
13487
13488     VMSISH_HUSHED = 0;
13489
13490     MY_POSIX_EXIT = vms_posix_exit;
13491
13492     x = (float)ix;
13493     MY_INV_RAND_MAX = 1./x;
13494 }
13495
13496 void
13497 init_os_extras(void)
13498 {
13499   dTHX;
13500   char* file = __FILE__;
13501   if (decc_disable_to_vms_logname_translation) {
13502     no_translate_barewords = TRUE;
13503   } else {
13504     no_translate_barewords = FALSE;
13505   }
13506
13507   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13508   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13509   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13510   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13511   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13512   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13513   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13514   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13515   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13516   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13517   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13518   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13519   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13520   newXSproto("VMS::Filespec::case_tolerant_process",
13521       case_tolerant_process_fromperl,file,"");
13522
13523   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13524
13525   return;
13526 }
13527
13528 #if __CRTL_VER == 80200000
13529 /* This missed getting in to the DECC SDK for 8.2 */
13530 char *realpath(const char *file_name, char * resolved_name, ...);
13531 #endif
13532
13533 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13534 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13535  * The perl fallback routine to provide realpath() is not as efficient
13536  * on OpenVMS.
13537  */
13538
13539 #ifdef __cplusplus
13540 extern "C" {
13541 #endif
13542
13543 /* Hack, use old stat() as fastest way of getting ino_t and device */
13544 int decc$stat(const char *name, void * statbuf);
13545 #if !defined(__VAX) && __CRTL_VER >= 80200000
13546 int decc$lstat(const char *name, void * statbuf);
13547 #else
13548 #define decc$lstat decc$stat
13549 #endif
13550
13551 #ifdef __cplusplus
13552 }
13553 #endif
13554
13555
13556 /* Realpath is fragile.  In 8.3 it does not work if the feature
13557  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13558  * links are implemented in RMS, not the CRTL. It also can fail if the
13559  * user does not have read/execute access to some of the directories.
13560  * So in order for Do What I Mean mode to work, if realpath() fails,
13561  * fall back to looking up the filename by the device name and FID.
13562  */
13563
13564 int vms_fid_to_name(char * outname, int outlen,
13565                     const char * name, int lstat_flag, mode_t * mode)
13566 {
13567 #pragma message save
13568 #pragma message disable MISALGNDSTRCT
13569 #pragma message disable MISALGNDMEM
13570 #pragma member_alignment save
13571 #pragma nomember_alignment
13572     struct statbuf_t {
13573         char       * st_dev;
13574         unsigned short st_ino[3];
13575         unsigned short old_st_mode;
13576         unsigned long  padl[30];  /* plenty of room */
13577     } statbuf;
13578 #pragma message restore
13579 #pragma member_alignment restore
13580
13581     int sts;
13582     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13583     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13584     char *fileified;
13585     char *temp_fspec;
13586     char *ret_spec;
13587
13588     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13589      * unexpected answers
13590      */
13591
13592     fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13593     if (fileified == NULL)
13594         _ckvmssts_noperl(SS$_INSFMEM);
13595
13596     temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13597     if (temp_fspec == NULL)
13598         _ckvmssts_noperl(SS$_INSFMEM);
13599
13600     sts = -1;
13601     /* First need to try as a directory */
13602     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13603     if (ret_spec != NULL) {
13604         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13605         if (ret_spec != NULL) {
13606             if (lstat_flag == 0)
13607                 sts = decc$stat(fileified, &statbuf);
13608             else
13609                 sts = decc$lstat(fileified, &statbuf);
13610         }
13611     }
13612
13613     /* Then as a VMS file spec */
13614     if (sts != 0) {
13615         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13616         if (ret_spec != NULL) {
13617             if (lstat_flag == 0) {
13618                 sts = decc$stat(temp_fspec, &statbuf);
13619             } else {
13620                 sts = decc$lstat(temp_fspec, &statbuf);
13621             }
13622         }
13623     }
13624
13625     if (sts) {
13626         /* Next try - allow multiple dots with out EFS CHARSET */
13627         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13628          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13629          * enable it if it isn't already.
13630          */
13631 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13632         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13633             decc$feature_set_value(decc_efs_charset_index, 1, 1);
13634 #endif
13635         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13636         if (lstat_flag == 0) {
13637             sts = decc$stat(name, &statbuf);
13638         } else {
13639             sts = decc$lstat(name, &statbuf);
13640         }
13641 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13642         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13643             decc$feature_set_value(decc_efs_charset_index, 1, 0);
13644 #endif
13645     }
13646
13647
13648     /* and then because the Perl Unix to VMS conversion is not perfect */
13649     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13650     /* characters from filenames so we need to try it as-is */
13651     if (sts) {
13652         if (lstat_flag == 0) {
13653             sts = decc$stat(name, &statbuf);
13654         } else {
13655             sts = decc$lstat(name, &statbuf);
13656         }
13657     }
13658
13659     if (sts == 0) {
13660         int vms_sts;
13661
13662         dvidsc.dsc$a_pointer=statbuf.st_dev;
13663         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13664
13665         specdsc.dsc$a_pointer = outname;
13666         specdsc.dsc$w_length = outlen-1;
13667
13668         vms_sts = lib$fid_to_name
13669             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13670         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13671             outname[specdsc.dsc$w_length] = 0;
13672
13673             /* Return the mode */
13674             if (mode) {
13675                 *mode = statbuf.old_st_mode;
13676             }
13677         }
13678     }
13679     PerlMem_free(temp_fspec);
13680     PerlMem_free(fileified);
13681     return sts;
13682 }
13683
13684
13685
13686 static char *
13687 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13688                    int *utf8_fl)
13689 {
13690     char * rslt = NULL;
13691
13692 #ifdef HAS_SYMLINK
13693     if (decc_posix_compliant_pathnames > 0 ) {
13694         /* realpath currently only works if posix compliant pathnames are
13695          * enabled.  It may start working when they are not, but in that
13696          * case we still want the fallback behavior for backwards compatibility
13697          */
13698         rslt = realpath(filespec, outbuf);
13699     }
13700 #endif
13701
13702     if (rslt == NULL) {
13703         char * vms_spec;
13704         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13705         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13706         mode_t my_mode;
13707
13708         /* Fall back to fid_to_name */
13709
13710         Newx(vms_spec, VMS_MAXRSS + 1, char);
13711
13712         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13713         if (sts == 0) {
13714
13715
13716             /* Now need to trim the version off */
13717             sts = vms_split_path
13718                   (vms_spec,
13719                    &v_spec,
13720                    &v_len,
13721                    &r_spec,
13722                    &r_len,
13723                    &d_spec,
13724                    &d_len,
13725                    &n_spec,
13726                    &n_len,
13727                    &e_spec,
13728                    &e_len,
13729                    &vs_spec,
13730                    &vs_len);
13731
13732
13733                 if (sts == 0) {
13734                     int haslower = 0;
13735                     const char *cp;
13736
13737                     /* Trim off the version */
13738                     int file_len = v_len + r_len + d_len + n_len + e_len;
13739                     vms_spec[file_len] = 0;
13740
13741                     /* Trim off the .DIR if this is a directory */
13742                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13743                         if (S_ISDIR(my_mode)) {
13744                             e_len = 0;
13745                             e_spec[0] = 0;
13746                         }
13747                     }
13748
13749                     /* Drop NULL extensions on UNIX file specification */
13750                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
13751                         e_len = 0;
13752                         e_spec[0] = '\0';
13753                     }
13754
13755                     /* The result is expected to be in UNIX format */
13756                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13757
13758                     /* Downcase if input had any lower case letters and
13759                      * case preservation is not in effect.
13760                      */
13761                     if (!decc_efs_case_preserve) {
13762                         for (cp = filespec; *cp; cp++)
13763                             if (islower(*cp)) { haslower = 1; break; }
13764
13765                         if (haslower) __mystrtolower(rslt);
13766                     }
13767                 }
13768         } else {
13769
13770             /* Now for some hacks to deal with backwards and forward */
13771             /* compatibility */
13772             if (!decc_efs_charset) {
13773
13774                 /* 1. ODS-2 mode wants to do a syntax only translation */
13775                 rslt = int_rmsexpand(filespec, outbuf,
13776                                     NULL, 0, NULL, utf8_fl);
13777
13778             } else {
13779                 if (decc_filename_unix_report) {
13780                     char * dir_name;
13781                     char * vms_dir_name;
13782                     char * file_name;
13783
13784                     /* 2. ODS-5 / UNIX report mode should return a failure */
13785                     /*    if the parent directory also does not exist */
13786                     /*    Otherwise, get the real path for the parent */
13787                     /*    and add the child to it. */
13788
13789                     /* basename / dirname only available for VMS 7.0+ */
13790                     /* So we may need to implement them as common routines */
13791
13792                     Newx(dir_name, VMS_MAXRSS + 1, char);
13793                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13794                     dir_name[0] = '\0';
13795                     file_name = NULL;
13796
13797                     /* First try a VMS parse */
13798                     sts = vms_split_path
13799                           (filespec,
13800                            &v_spec,
13801                            &v_len,
13802                            &r_spec,
13803                            &r_len,
13804                            &d_spec,
13805                            &d_len,
13806                            &n_spec,
13807                            &n_len,
13808                            &e_spec,
13809                            &e_len,
13810                            &vs_spec,
13811                            &vs_len);
13812
13813                     if (sts == 0) {
13814                         /* This is VMS */
13815
13816                         int dir_len = v_len + r_len + d_len + n_len;
13817                         if (dir_len > 0) {
13818                            memcpy(dir_name, filespec, dir_len);
13819                            dir_name[dir_len] = '\0';
13820                            file_name = (char *)&filespec[dir_len + 1];
13821                         }
13822                     } else {
13823                         /* This must be UNIX */
13824                         char * tchar;
13825
13826                         tchar = strrchr(filespec, '/');
13827
13828                         if (tchar != NULL) {
13829                             int dir_len = tchar - filespec;
13830                             memcpy(dir_name, filespec, dir_len);
13831                             dir_name[dir_len] = '\0';
13832                             file_name = (char *) &filespec[dir_len + 1];
13833                         }
13834                     }
13835
13836                     /* Dir name is defaulted */
13837                     if (dir_name[0] == 0) {
13838                         dir_name[0] = '.';
13839                         dir_name[1] = '\0';
13840                     }
13841
13842                     /* Need realpath for the directory */
13843                     sts = vms_fid_to_name(vms_dir_name,
13844                                           VMS_MAXRSS + 1,
13845                                           dir_name, 0, NULL);
13846
13847                     if (sts == 0) {
13848                         /* Now need to pathify it. */
13849                         char *tdir = int_pathify_dirspec(vms_dir_name,
13850                                                          outbuf);
13851
13852                         /* And now add the original filespec to it */
13853                         if (file_name != NULL) {
13854                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13855                         }
13856                         return outbuf;
13857                     }
13858                     Safefree(vms_dir_name);
13859                     Safefree(dir_name);
13860                 }
13861             }
13862         }
13863         Safefree(vms_spec);
13864     }
13865     return rslt;
13866 }
13867
13868 static char *
13869 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13870                    int *utf8_fl)
13871 {
13872     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13873     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13874
13875     /* Fall back to fid_to_name */
13876
13877     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13878     if (sts != 0) {
13879         return NULL;
13880     }
13881     else {
13882
13883
13884         /* Now need to trim the version off */
13885         sts = vms_split_path
13886                   (outbuf,
13887                    &v_spec,
13888                    &v_len,
13889                    &r_spec,
13890                    &r_len,
13891                    &d_spec,
13892                    &d_len,
13893                    &n_spec,
13894                    &n_len,
13895                    &e_spec,
13896                    &e_len,
13897                    &vs_spec,
13898                    &vs_len);
13899
13900
13901         if (sts == 0) {
13902             int haslower = 0;
13903             const char *cp;
13904
13905             /* Trim off the version */
13906             int file_len = v_len + r_len + d_len + n_len + e_len;
13907             outbuf[file_len] = 0;
13908
13909             /* Downcase if input had any lower case letters and
13910              * case preservation is not in effect.
13911              */
13912             if (!decc_efs_case_preserve) {
13913                 for (cp = filespec; *cp; cp++)
13914                     if (islower(*cp)) { haslower = 1; break; }
13915
13916                 if (haslower) __mystrtolower(outbuf);
13917             }
13918         }
13919     }
13920     return outbuf;
13921 }
13922
13923
13924 /*}}}*/
13925 /* External entry points */
13926 char *
13927 Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13928 {
13929     return do_vms_realpath(filespec, outbuf, utf8_fl);
13930 }
13931
13932 char *
13933 Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13934 {
13935     return do_vms_realname(filespec, outbuf, utf8_fl);
13936 }
13937
13938 /* case_tolerant */
13939
13940 /*{{{int do_vms_case_tolerant(void)*/
13941 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13942  * controlled by a process setting.
13943  */
13944 int
13945 do_vms_case_tolerant(void)
13946 {
13947     return vms_process_case_tolerant;
13948 }
13949 /*}}}*/
13950 /* External entry points */
13951 int
13952 Perl_vms_case_tolerant(void)
13953 {
13954 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13955     return do_vms_case_tolerant();
13956 #else
13957     return vms_process_case_tolerant;
13958 #endif
13959 }
13960
13961  /* Start of DECC RTL Feature handling */
13962
13963 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13964
13965 static int
13966 set_feature_default(const char *name, int value)
13967 {
13968     int status;
13969     int index;
13970     char val_str[10];
13971
13972     /* If the feature has been explicitly disabled in the environment,
13973      * then don't enable it here.
13974      */
13975     if (value > 0) {
13976         status = simple_trnlnm(name, val_str, sizeof(val_str));
13977         if (status) {
13978             val_str[0] = _toupper(val_str[0]);
13979             if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
13980                 return 0;
13981         }
13982     }
13983
13984     index = decc$feature_get_index(name);
13985
13986     status = decc$feature_set_value(index, 1, value);
13987     if (index == -1 || (status == -1)) {
13988       return -1;
13989     }
13990
13991     status = decc$feature_get_value(index, 1);
13992     if (status != value) {
13993       return -1;
13994     }
13995
13996     /* Various things may check for an environment setting
13997      * rather than the feature directly, so set that too.
13998      */
13999     vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
14000
14001     return 0;
14002 }
14003 #endif
14004
14005
14006 /* C RTL Feature settings */
14007
14008 #if defined(__DECC) || defined(__DECCXX)
14009
14010 #ifdef __cplusplus
14011 extern "C" {
14012 #endif
14013
14014 extern void
14015 vmsperl_set_features(void)
14016 {
14017     int status;
14018     int s;
14019     char val_str[10];
14020 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14021     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14022     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14023     unsigned long case_perm;
14024     unsigned long case_image;
14025 #endif
14026
14027     /* Allow an exception to bring Perl into the VMS debugger */
14028     vms_debug_on_exception = 0;
14029     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14030     if (status) {
14031        val_str[0] = _toupper(val_str[0]);
14032        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14033          vms_debug_on_exception = 1;
14034        else
14035          vms_debug_on_exception = 0;
14036     }
14037
14038     /* Debug unix/vms file translation routines */
14039     vms_debug_fileify = 0;
14040     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14041     if (status) {
14042         val_str[0] = _toupper(val_str[0]);
14043         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14044             vms_debug_fileify = 1;
14045         else
14046             vms_debug_fileify = 0;
14047     }
14048
14049
14050     /* Historically PERL has been doing vmsify / stat differently than */
14051     /* the CRTL.  In particular, under some conditions the CRTL will   */
14052     /* remove some illegal characters like spaces from filenames       */
14053     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14054     /* been reporting such file names as invalid and fails to stat them */
14055     /* fixing this bug so that stat()/lstat() accept these like the     */
14056     /* CRTL does will result in several tests failing.                  */
14057     /* This should really be fixed, but for now, set up a feature to    */
14058     /* enable it so that the impact can be studied.                     */
14059     vms_bug_stat_filename = 0;
14060     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14061     if (status) {
14062         val_str[0] = _toupper(val_str[0]);
14063         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14064             vms_bug_stat_filename = 1;
14065         else
14066             vms_bug_stat_filename = 0;
14067     }
14068
14069
14070     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14071     vms_vtf7_filenames = 0;
14072     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14073     if (status) {
14074        val_str[0] = _toupper(val_str[0]);
14075        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14076          vms_vtf7_filenames = 1;
14077        else
14078          vms_vtf7_filenames = 0;
14079     }
14080
14081     /* unlink all versions on unlink() or rename() */
14082     vms_unlink_all_versions = 0;
14083     status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14084     if (status) {
14085        val_str[0] = _toupper(val_str[0]);
14086        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14087          vms_unlink_all_versions = 1;
14088        else
14089          vms_unlink_all_versions = 0;
14090     }
14091
14092 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14093     /* Detect running under GNV Bash or other UNIX like shell */
14094     gnv_unix_shell = 0;
14095     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14096     if (status) {
14097          gnv_unix_shell = 1;
14098          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14099          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14100          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14101          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14102          vms_unlink_all_versions = 1;
14103          vms_posix_exit = 1;
14104          /* Reverse default ordering of PERL_ENV_TABLES. */
14105          defenv[0] = &crtlenvdsc;
14106          defenv[1] = &fildevdsc;
14107     }
14108     /* Some reasonable defaults that are not CRTL defaults */
14109     set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14110     set_feature_default("DECC$ARGV_PARSE_STYLE", 1);     /* Requires extended parse. */
14111     set_feature_default("DECC$EFS_CHARSET", 1);
14112 #endif
14113
14114     /* hacks to see if known bugs are still present for testing */
14115
14116     /* PCP mode requires creating /dev/null special device file */
14117     decc_bug_devnull = 0;
14118     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14119     if (status) {
14120        val_str[0] = _toupper(val_str[0]);
14121        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14122           decc_bug_devnull = 1;
14123        else
14124           decc_bug_devnull = 0;
14125     }
14126
14127 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14128     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14129     if (s >= 0) {
14130         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14131         if (decc_disable_to_vms_logname_translation < 0)
14132             decc_disable_to_vms_logname_translation = 0;
14133     }
14134
14135     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14136     if (s >= 0) {
14137         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14138         if (decc_efs_case_preserve < 0)
14139             decc_efs_case_preserve = 0;
14140     }
14141
14142     s = decc$feature_get_index("DECC$EFS_CHARSET");
14143     decc_efs_charset_index = s;
14144     if (s >= 0) {
14145         decc_efs_charset = decc$feature_get_value(s, 1);
14146         if (decc_efs_charset < 0)
14147             decc_efs_charset = 0;
14148     }
14149
14150     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14151     if (s >= 0) {
14152         decc_filename_unix_report = decc$feature_get_value(s, 1);
14153         if (decc_filename_unix_report > 0) {
14154             decc_filename_unix_report = 1;
14155             vms_posix_exit = 1;
14156         }
14157         else
14158             decc_filename_unix_report = 0;
14159     }
14160
14161     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14162     if (s >= 0) {
14163         decc_filename_unix_only = decc$feature_get_value(s, 1);
14164         if (decc_filename_unix_only > 0) {
14165             decc_filename_unix_only = 1;
14166         }
14167         else {
14168             decc_filename_unix_only = 0;
14169         }
14170     }
14171
14172     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14173     if (s >= 0) {
14174         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14175         if (decc_filename_unix_no_version < 0)
14176             decc_filename_unix_no_version = 0;
14177     }
14178
14179     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14180     if (s >= 0) {
14181         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14182         if (decc_readdir_dropdotnotype < 0)
14183             decc_readdir_dropdotnotype = 0;
14184     }
14185
14186 #if __CRTL_VER >= 80200000
14187     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14188     if (s >= 0) {
14189         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14190         if (decc_posix_compliant_pathnames < 0)
14191             decc_posix_compliant_pathnames = 0;
14192         if (decc_posix_compliant_pathnames > 4)
14193             decc_posix_compliant_pathnames = 0;
14194     }
14195
14196 #endif
14197 #else
14198     status = simple_trnlnm
14199         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14200     if (status) {
14201         val_str[0] = _toupper(val_str[0]);
14202         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14203            decc_disable_to_vms_logname_translation = 1;
14204         }
14205     }
14206
14207 #ifndef __VAX
14208     status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14209     if (status) {
14210         val_str[0] = _toupper(val_str[0]);
14211         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14212            decc_efs_case_preserve = 1;
14213         }
14214     }
14215 #endif
14216
14217     status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14218     if (status) {
14219         val_str[0] = _toupper(val_str[0]);
14220         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14221            decc_filename_unix_report = 1;
14222         }
14223     }
14224     status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14225     if (status) {
14226         val_str[0] = _toupper(val_str[0]);
14227         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14228            decc_filename_unix_only = 1;
14229            decc_filename_unix_report = 1;
14230         }
14231     }
14232     status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14233     if (status) {
14234         val_str[0] = _toupper(val_str[0]);
14235         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14236            decc_filename_unix_no_version = 1;
14237         }
14238     }
14239     status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14240     if (status) {
14241         val_str[0] = _toupper(val_str[0]);
14242         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14243            decc_readdir_dropdotnotype = 1;
14244         }
14245     }
14246 #endif
14247
14248 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14249
14250      /* Report true case tolerance */
14251     /*----------------------------*/
14252     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14253     if (!$VMS_STATUS_SUCCESS(status))
14254         case_perm = PPROP$K_CASE_BLIND;
14255     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14256     if (!$VMS_STATUS_SUCCESS(status))
14257         case_image = PPROP$K_CASE_BLIND;
14258     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14259         (case_image == PPROP$K_CASE_SENSITIVE))
14260         vms_process_case_tolerant = 0;
14261
14262 #endif
14263
14264     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14265     /* for strict backward compatibility */
14266     status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14267     if (status) {
14268        val_str[0] = _toupper(val_str[0]);
14269        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14270          vms_posix_exit = 1;
14271        else
14272          vms_posix_exit = 0;
14273     }
14274 }
14275
14276 /* Use 32-bit pointers because that's what the image activator
14277  * assumes for the LIB$INITIALZE psect.
14278  */
14279 #if __INITIAL_POINTER_SIZE
14280 #pragma pointer_size save
14281 #pragma pointer_size 32
14282 #endif
14283
14284 /* Create a reference to the LIB$INITIALIZE function. */
14285 extern void LIB$INITIALIZE(void);
14286 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14287
14288 /* Create an array of pointers to the init functions in the special
14289  * LIB$INITIALIZE section. In our case, the array only has one entry.
14290  */
14291 #pragma extern_model save
14292 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
14293 extern void (* const vmsperl_unused_global_2[])() =
14294 {
14295    vmsperl_set_features,
14296 };
14297 #pragma extern_model restore
14298
14299 #if __INITIAL_POINTER_SIZE
14300 #pragma pointer_size restore
14301 #endif
14302
14303 #ifdef __cplusplus
14304 }
14305 #endif
14306
14307 #endif /* defined(__DECC) || defined(__DECCXX) */
14308 /*  End of vms.c */