vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993-2013 by Charles Bailey and others.
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  */
  10
  11 /*
  12  *   Yet small as was their hunted band
  13  *   still fell and fearless was each hand,
  14  *   and strong deeds they wrought yet oft,
  15  *   and loved the woods, whose ways more soft
  16  *   them seemed than thralls of that black throne
  17  *   to live and languish in halls of stone.
  18  *        "The Lay of Leithian", Canto II, lines 135-40
  19  *
  20  *     [p.162 of _The Lays of Beleriand_]
  21  */
  22
  23 #include <acedef.h>
  24 #include <acldef.h>
  25 #include <armdef.h>
  26 #if __CRTL_VER < 70300000
  27 /* needed for home-rolled utime() */
  28 #include <atrdef.h>
  29 #include <fibdef.h>
  30 #endif
  31 #include <chpdef.h>
  32 #include <clidef.h>
  33 #include <climsgdef.h>
  34 #include <dcdef.h>
  35 #include <descrip.h>
  36 #include <devdef.h>
  37 #include <dvidef.h>
  38 #include <float.h>
  39 #include <fscndef.h>
  40 #include <iodef.h>
  41 #include <jpidef.h>
  42 #include <kgbdef.h>
  43 #include <libclidef.h>
  44 #include <libdef.h>
  45 #include <lib$routines.h>
  46 #include <lnmdef.h>
  47 #include <ossdef.h>
  48 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  49 #include <ppropdef.h>
  50 #endif
  51 #include <prvdef.h>
  52 #include <psldef.h>
  53 #include <rms.h>
  54 #include <shrdef.h>
  55 #include <ssdef.h>
  56 #include <starlet.h>
  57 #include <strdef.h>
  58 #include <str$routines.h>
  59 #include <syidef.h>
  60 #include <uaidef.h>
  61 #include <uicdef.h>
  62 #include <stsdef.h>
  63 #include <efndef.h>
  64 #define NO_EFN EFN$C_ENF
  65
  66 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  67 int   decc$feature_get_index(const char *name);
  68 char* decc$feature_get_name(int index);
  69 int   decc$feature_get_value(int index, int mode);
  70 int   decc$feature_set_value(int index, int mode, int value);
  71 #else
  72 #include <unixlib.h>
  73 #endif
  74
  75 #pragma member_alignment save
  76 #pragma nomember_alignment longword
  77 struct item_list_3 {
  78         unsigned short len;
  79         unsigned short code;
  80         void * bufadr;
  81         unsigned short * retadr;
  82 };
  83 #pragma member_alignment restore
  84
  85 /* Older versions of ssdef.h don't have these */
  86 #ifndef SS$_INVFILFOROP
  87 #  define SS$_INVFILFOROP 3930
  88 #endif
  89 #ifndef SS$_NOSUCHOBJECT
  90 #  define SS$_NOSUCHOBJECT 2696
  91 #endif
  92
  93 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
  94 #define PERLIO_NOT_STDIO 0
  95
  96 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
  97  * code below needs to get to the underlying CRTL routines. */
  98 #define DONT_MASK_RTL_CALLS
  99 #include "EXTERN.h"
 100 #include "perl.h"
 101 #include "XSUB.h"
 102 /* Anticipating future expansion in lexical warnings . . . */
 103 #ifndef WARN_INTERNAL
 104 #  define WARN_INTERNAL WARN_MISC
 105 #endif
 106
 107 #ifdef VMS_LONGNAME_SUPPORT
 108 #include <libfildef.h>
 109 #endif
 110
 111 #if !defined(__VAX) && __CRTL_VER >= 80200000
 112 #ifdef lstat
 113 #undef lstat
 114 #endif
 115 #else
 116 #ifdef lstat
 117 #undef lstat
 118 #endif
 119 #define lstat(_x, _y) stat(_x, _y)
 120 #endif
 121
 122 /* Routine to create a decterm for use with the Perl debugger */
 123 /* No headers, this information was found in the Programming Concepts Manual */
 124
 125 static int (*decw_term_port)
 126    (const struct dsc$descriptor_s * display,
 127     const struct dsc$descriptor_s * setup_file,
 128     const struct dsc$descriptor_s * customization,
 129     struct dsc$descriptor_s * result_device_name,
 130     unsigned short * result_device_name_length,
 131     void * controller,
 132     void * char_buffer,
 133     void * char_change_buffer) = 0;
 134
 135 /* gcc's header files don't #define direct access macros
 136  * corresponding to VAXC's variant structs */
 137 #ifdef __GNUC__
 138 #  define uic$v_format uic$r_uic_form.uic$v_format
 139 #  define uic$v_group uic$r_uic_form.uic$v_group
 140 #  define uic$v_member uic$r_uic_form.uic$v_member
 141 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 142 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 143 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 144 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 145 #endif
 146
 147 #if defined(NEED_AN_H_ERRNO)
 148 dEXT int h_errno;
 149 #endif
 150
 151 #if defined(__DECC) || defined(__DECCXX)
 152 #pragma member_alignment save
 153 #pragma nomember_alignment longword
 154 #pragma message save
 155 #pragma message disable misalgndmem
 156 #endif
 157 struct itmlst_3 {
 158   unsigned short int buflen;
 159   unsigned short int itmcode;
 160   void *bufadr;
 161   unsigned short int *retlen;
 162 };
 163
 164 struct filescan_itmlst_2 {
 165     unsigned short length;
 166     unsigned short itmcode;
 167     char * component;
 168 };
 169
 170 struct vs_str_st {
 171     unsigned short length;
 172     char str[VMS_MAXRSS];
 173     unsigned short pad; /* for longword struct alignment */
 174 };
 175
 176 #if defined(__DECC) || defined(__DECCXX)
 177 #pragma message restore
 178 #pragma member_alignment restore
 179 #endif
 180
 181 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 182 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 183 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 184 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 185 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 186 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 187 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 188 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 189 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 190 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 191 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 192 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 193
 194 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 195 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 196 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 197 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 198
 199 static char *  int_rmsexpand_vms(
 200     const char * filespec, char * outbuf, unsigned opts);
 201 static char * int_rmsexpand_tovms(
 202     const char * filespec, char * outbuf, unsigned opts);
 203 static char *int_tovmsspec
 204    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 205 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 206 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 207 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 208
 209 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 210 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 211
 212 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 213  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 214  * the Perl facility.
 215  */
 216 #define PERL_LNM_MAX_ITER 10
 217
 218   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 219 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 220 #define MAX_DCL_SYMBOL          (8192)
 221 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 222 #else
 223 #define MAX_DCL_SYMBOL          (1024)
 224 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 225 #endif
 226
 227 static char *__mystrtolower(char *str)
 228 {
 229   if (str) for (; *str; ++str) *str= tolower(*str);
 230   return str;
 231 }
 232
 233 static struct dsc$descriptor_s fildevdsc =
 234   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 235 static struct dsc$descriptor_s crtlenvdsc =
 236   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 237 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 238 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 239 static struct dsc$descriptor_s **env_tables = defenv;
 240 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 241
 242 /* True if we shouldn't treat barewords as logicals during directory */
 243 /* munching */
 244 static int no_translate_barewords;
 245
 246 /* DECC Features that may need to affect how Perl interprets
 247  * displays filename information
 248  */
 249 static int decc_disable_to_vms_logname_translation = 1;
 250 static int decc_disable_posix_root = 1;
 251 int decc_efs_case_preserve = 0;
 252 static int decc_efs_charset = 0;
 253 static int decc_efs_charset_index = -1;
 254 static int decc_filename_unix_no_version = 0;
 255 static int decc_filename_unix_only = 0;
 256 int decc_filename_unix_report = 0;
 257 int decc_posix_compliant_pathnames = 0;
 258 int decc_readdir_dropdotnotype = 0;
 259 static int vms_process_case_tolerant = 1;
 260 int vms_vtf7_filenames = 0;
 261 int gnv_unix_shell = 0;
 262 static int vms_unlink_all_versions = 0;
 263 static int vms_posix_exit = 0;
 264
 265 /* bug workarounds if needed */
 266 int decc_bug_devnull = 1;
 267 int vms_bug_stat_filename = 0;
 268
 269 static int vms_debug_on_exception = 0;
 270 static int vms_debug_fileify = 0;
 271
 272 /* Simple logical name translation */
 273 static int simple_trnlnm
 274    (const char * logname,
 275     char * value,
 276     int value_len)
 277 {
 278     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 279     const unsigned long attr = LNM$M_CASE_BLIND;
 280     struct dsc$descriptor_s name_dsc;
 281     int status;
 282     unsigned short result;
 283     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 284                                 {0, 0, 0, 0}};
 285
 286     name_dsc.dsc$w_length = strlen(logname);
 287     name_dsc.dsc$a_pointer = (char *)logname;
 288     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 289     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 290
 291     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 292
 293     if ($VMS_STATUS_SUCCESS(status)) {
 294
 295          /* Null terminate and return the string */
 296         /*--------------------------------------*/
 297         value[result] = 0;
 298         return result;
 299     }
 300
 301     return 0;
 302 }
 303
 304
 305 /* Is this a UNIX file specification?
 306  *   No longer a simple check with EFS file specs
 307  *   For now, not a full check, but need to
 308  *   handle POSIX ^UP^ specifications
 309  *   Fixing to handle ^/ cases would require
 310  *   changes to many other conversion routines.
 311  */
 312
 313 static int is_unix_filespec(const char *path)
 314 {
 315 int ret_val;
 316 const char * pch1;
 317
 318     ret_val = 0;
 319     if (strncmp(path,"\"^UP^",5) != 0) {
 320         pch1 = strchr(path, '/');
 321         if (pch1 != NULL)
 322             ret_val = 1;
 323         else {
 324
 325             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 326             if (decc_filename_unix_report || decc_filename_unix_only) {
 327             if (strcmp(path,".") == 0)
 328                 ret_val = 1;
 329             }
 330         }
 331     }
 332     return ret_val;
 333 }
 334
 335 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 336  */
 337
 338 static void ucs2_to_vtf7
 339    (char *outspec,
 340     unsigned long ucs2_char,
 341     int * output_cnt)
 342 {
 343 unsigned char * ucs_ptr;
 344 int hex;
 345
 346     ucs_ptr = (unsigned char *)&ucs2_char;
 347
 348     outspec[0] = '^';
 349     outspec[1] = 'U';
 350     hex = (ucs_ptr[1] >> 4) & 0xf;
 351     if (hex < 0xA)
 352         outspec[2] = hex + '0';
 353     else
 354         outspec[2] = (hex - 9) + 'A';
 355     hex = ucs_ptr[1] & 0xF;
 356     if (hex < 0xA)
 357         outspec[3] = hex + '0';
 358     else {
 359         outspec[3] = (hex - 9) + 'A';
 360     }
 361     hex = (ucs_ptr[0] >> 4) & 0xf;
 362     if (hex < 0xA)
 363         outspec[4] = hex + '0';
 364     else
 365         outspec[4] = (hex - 9) + 'A';
 366     hex = ucs_ptr[1] & 0xF;
 367     if (hex < 0xA)
 368         outspec[5] = hex + '0';
 369     else {
 370         outspec[5] = (hex - 9) + 'A';
 371     }
 372     *output_cnt = 6;
 373 }
 374
 375
 376 /* This handles the conversion of a UNIX extended character set to a ^
 377  * escaped VMS character.
 378  * in a UNIX file specification.
 379  *
 380  * The output count variable contains the number of characters added
 381  * to the output string.
 382  *
 383  * The return value is the number of characters read from the input string
 384  */
 385 static int copy_expand_unix_filename_escape
 386   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 387 {
 388 int count;
 389 int utf8_flag;
 390
 391     utf8_flag = 0;
 392     if (utf8_fl)
 393       utf8_flag = *utf8_fl;
 394
 395     count = 0;
 396     *output_cnt = 0;
 397     if (*inspec >= 0x80) {
 398         if (utf8_fl && vms_vtf7_filenames) {
 399         unsigned long ucs_char;
 400
 401             ucs_char = 0;
 402
 403             if ((*inspec & 0xE0) == 0xC0) {
 404                 /* 2 byte Unicode */
 405                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 406                 if (ucs_char >= 0x80) {
 407                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 408                     return 2;
 409                 }
 410             } else if ((*inspec & 0xF0) == 0xE0) {
 411                 /* 3 byte Unicode */
 412                 ucs_char = ((inspec[0] & 0xF) << 12) +
 413                    ((inspec[1] & 0x3f) << 6) +
 414                    (inspec[2] & 0x3f);
 415                 if (ucs_char >= 0x800) {
 416                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 417                     return 3;
 418                 }
 419
 420 #if 0 /* I do not see longer sequences supported by OpenVMS */
 421       /* Maybe some one can fix this later */
 422             } else if ((*inspec & 0xF8) == 0xF0) {
 423                 /* 4 byte Unicode */
 424                 /* UCS-4 to UCS-2 */
 425             } else if ((*inspec & 0xFC) == 0xF8) {
 426                 /* 5 byte Unicode */
 427                 /* UCS-4 to UCS-2 */
 428             } else if ((*inspec & 0xFE) == 0xFC) {
 429                 /* 6 byte Unicode */
 430                 /* UCS-4 to UCS-2 */
 431 #endif
 432             }
 433         }
 434
 435         /* High bit set, but not a Unicode character! */
 436
 437         /* Non printing DECMCS or ISO Latin-1 character? */
 438         if ((unsigned char)*inspec <= 0x9F) {
 439             int hex;
 440             outspec[0] = '^';
 441             outspec++;
 442             hex = (*inspec >> 4) & 0xF;
 443             if (hex < 0xA)
 444                 outspec[1] = hex + '0';
 445             else {
 446                 outspec[1] = (hex - 9) + 'A';
 447             }
 448             hex = *inspec & 0xF;
 449             if (hex < 0xA)
 450                 outspec[2] = hex + '0';
 451             else {
 452                 outspec[2] = (hex - 9) + 'A';
 453             }
 454             *output_cnt = 3;
 455             return 1;
 456         } else if ((unsigned char)*inspec == 0xA0) {
 457             outspec[0] = '^';
 458             outspec[1] = 'A';
 459             outspec[2] = '0';
 460             *output_cnt = 3;
 461             return 1;
 462         } else if ((unsigned char)*inspec == 0xFF) {
 463             outspec[0] = '^';
 464             outspec[1] = 'F';
 465             outspec[2] = 'F';
 466             *output_cnt = 3;
 467             return 1;
 468         }
 469         *outspec = *inspec;
 470         *output_cnt = 1;
 471         return 1;
 472     }
 473
 474     /* Is this a macro that needs to be passed through?
 475      * Macros start with $( and an alpha character, followed
 476      * by a string of alpha numeric characters ending with a )
 477      * If this does not match, then encode it as ODS-5.
 478      */
 479     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 480     int tcnt;
 481
 482         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 483             tcnt = 3;
 484             outspec[0] = inspec[0];
 485             outspec[1] = inspec[1];
 486             outspec[2] = inspec[2];
 487
 488             while(isalnum(inspec[tcnt]) ||
 489                   (inspec[2] == '.') || (inspec[2] == '_')) {
 490                 outspec[tcnt] = inspec[tcnt];
 491                 tcnt++;
 492             }
 493             if (inspec[tcnt] == ')') {
 494                 outspec[tcnt] = inspec[tcnt];
 495                 tcnt++;
 496                 *output_cnt = tcnt;
 497                 return tcnt;
 498             }
 499         }
 500     }
 501
 502     switch (*inspec) {
 503     case 0x7f:
 504         outspec[0] = '^';
 505         outspec[1] = '7';
 506         outspec[2] = 'F';
 507         *output_cnt = 3;
 508         return 1;
 509         break;
 510     case '?':
 511         if (decc_efs_charset == 0)
 512           outspec[0] = '%';
 513         else
 514           outspec[0] = '?';
 515         *output_cnt = 1;
 516         return 1;
 517         break;
 518     case '.':
 519     case '~':
 520     case '!':
 521     case '#':
 522     case '&':
 523     case '\'':
 524     case '`':
 525     case '(':
 526     case ')':
 527     case '+':
 528     case '@':
 529     case '{':
 530     case '}':
 531     case ',':
 532     case ';':
 533     case '[':
 534     case ']':
 535     case '%':
 536     case '^':
 537     case '\\':
 538         /* Don't escape again if following character is
 539          * already something we escape.
 540          */
 541         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 542             *outspec = *inspec;
 543             *output_cnt = 1;
 544             return 1;
 545             break;
 546         }
 547         /* But otherwise fall through and escape it. */
 548     case '=':
 549         /* Assume that this is to be escaped */
 550         outspec[0] = '^';
 551         outspec[1] = *inspec;
 552         *output_cnt = 2;
 553         return 1;
 554         break;
 555     case ' ': /* space */
 556         /* Assume that this is to be escaped */
 557         outspec[0] = '^';
 558         outspec[1] = '_';
 559         *output_cnt = 2;
 560         return 1;
 561         break;
 562     default:
 563         *outspec = *inspec;
 564         *output_cnt = 1;
 565         return 1;
 566         break;
 567     }
 568     return 0;
 569 }
 570
 571
 572 /* This handles the expansion of a '^' prefix to the proper character
 573  * in a UNIX file specification.
 574  *
 575  * The output count variable contains the number of characters added
 576  * to the output string.
 577  *
 578  * The return value is the number of characters read from the input
 579  * string
 580  */
 581 static int copy_expand_vms_filename_escape
 582   (char *outspec, const char *inspec, int *output_cnt)
 583 {
 584 int count;
 585 int scnt;
 586
 587     count = 0;
 588     *output_cnt = 0;
 589     if (*inspec == '^') {
 590         inspec++;
 591         switch (*inspec) {
 592         /* Spaces and non-trailing dots should just be passed through,
 593          * but eat the escape character.
 594          */
 595         case '.':
 596             *outspec = *inspec;
 597             count += 2;
 598             (*output_cnt)++;
 599             break;
 600         case '_': /* space */
 601             *outspec = ' ';
 602             count += 2;
 603             (*output_cnt)++;
 604             break;
 605         case '^':
 606             /* Hmm.  Better leave the escape escaped. */
 607             outspec[0] = '^';
 608             outspec[1] = '^';
 609             count += 2;
 610             (*output_cnt) += 2;
 611             break;
 612         case 'U': /* Unicode - FIX-ME this is wrong. */
 613             inspec++;
 614             count++;
 615             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 616             if (scnt == 4) {
 617                 unsigned int c1, c2;
 618                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 619                 outspec[0] = c1 & 0xff;
 620                 outspec[1] = c2 & 0xff;
 621                 if (scnt > 1) {
 622                     (*output_cnt) += 2;
 623                     count += 4;
 624                 }
 625             }
 626             else {
 627                 /* Error - do best we can to continue */
 628                 *outspec = 'U';
 629                 outspec++;
 630                 (*output_cnt++);
 631                 *outspec = *inspec;
 632                 count++;
 633                 (*output_cnt++);
 634             }
 635             break;
 636         default:
 637             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 638             if (scnt == 2) {
 639                 /* Hex encoded */
 640                 unsigned int c1;
 641                 scnt = sscanf(inspec, "%2x", &c1);
 642                 outspec[0] = c1 & 0xff;
 643                 if (scnt > 0) {
 644                     (*output_cnt++);
 645                     count += 2;
 646                 }
 647             }
 648             else {
 649                 *outspec = *inspec;
 650                 count++;
 651                 (*output_cnt++);
 652             }
 653         }
 654     }
 655     else {
 656         *outspec = *inspec;
 657         count++;
 658         (*output_cnt)++;
 659     }
 660     return count;
 661 }
 662
 663 /* vms_split_path - Verify that the input file specification is a
 664  * VMS format file specification, and provide pointers to the components of
 665  * it.  With EFS format filenames, this is virtually the only way to
 666  * parse a VMS path specification into components.
 667  *
 668  * If the sum of the components do not add up to the length of the
 669  * string, then the passed file specification is probably a UNIX style
 670  * path.
 671  */
 672 static int vms_split_path
 673    (const char * path,
 674     char * * volume,
 675     int * vol_len,
 676     char * * root,
 677     int * root_len,
 678     char * * dir,
 679     int * dir_len,
 680     char * * name,
 681     int * name_len,
 682     char * * ext,
 683     int * ext_len,
 684     char * * version,
 685     int * ver_len)
 686 {
 687 struct dsc$descriptor path_desc;
 688 int status;
 689 unsigned long flags;
 690 int ret_stat;
 691 struct filescan_itmlst_2 item_list[9];
 692 const int filespec = 0;
 693 const int nodespec = 1;
 694 const int devspec = 2;
 695 const int rootspec = 3;
 696 const int dirspec = 4;
 697 const int namespec = 5;
 698 const int typespec = 6;
 699 const int verspec = 7;
 700
 701     /* Assume the worst for an easy exit */
 702     ret_stat = -1;
 703     *volume = NULL;
 704     *vol_len = 0;
 705     *root = NULL;
 706     *root_len = 0;
 707     *dir = NULL;
 708     *name = NULL;
 709     *name_len = 0;
 710     *ext = NULL;
 711     *ext_len = 0;
 712     *version = NULL;
 713     *ver_len = 0;
 714
 715     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 716     path_desc.dsc$w_length = strlen(path);
 717     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 718     path_desc.dsc$b_class = DSC$K_CLASS_S;
 719
 720     /* Get the total length, if it is shorter than the string passed
 721      * then this was probably not a VMS formatted file specification
 722      */
 723     item_list[filespec].itmcode = FSCN$_FILESPEC;
 724     item_list[filespec].length = 0;
 725     item_list[filespec].component = NULL;
 726
 727     /* If the node is present, then it gets considered as part of the
 728      * volume name to hopefully make things simple.
 729      */
 730     item_list[nodespec].itmcode = FSCN$_NODE;
 731     item_list[nodespec].length = 0;
 732     item_list[nodespec].component = NULL;
 733
 734     item_list[devspec].itmcode = FSCN$_DEVICE;
 735     item_list[devspec].length = 0;
 736     item_list[devspec].component = NULL;
 737
 738     /* root is a special case,  adding it to either the directory or
 739      * the device components will probably complicate things for the
 740      * callers of this routine, so leave it separate.
 741      */
 742     item_list[rootspec].itmcode = FSCN$_ROOT;
 743     item_list[rootspec].length = 0;
 744     item_list[rootspec].component = NULL;
 745
 746     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 747     item_list[dirspec].length = 0;
 748     item_list[dirspec].component = NULL;
 749
 750     item_list[namespec].itmcode = FSCN$_NAME;
 751     item_list[namespec].length = 0;
 752     item_list[namespec].component = NULL;
 753
 754     item_list[typespec].itmcode = FSCN$_TYPE;
 755     item_list[typespec].length = 0;
 756     item_list[typespec].component = NULL;
 757
 758     item_list[verspec].itmcode = FSCN$_VERSION;
 759     item_list[verspec].length = 0;
 760     item_list[verspec].component = NULL;
 761
 762     item_list[8].itmcode = 0;
 763     item_list[8].length = 0;
 764     item_list[8].component = NULL;
 765
 766     status = sys$filescan
 767        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 768         &flags, NULL, NULL);
 769     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 770
 771     /* If we parsed it successfully these two lengths should be the same */
 772     if (path_desc.dsc$w_length != item_list[filespec].length)
 773         return ret_stat;
 774
 775     /* If we got here, then it is a VMS file specification */
 776     ret_stat = 0;
 777
 778     /* set the volume name */
 779     if (item_list[nodespec].length > 0) {
 780         *volume = item_list[nodespec].component;
 781         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 782     }
 783     else {
 784         *volume = item_list[devspec].component;
 785         *vol_len = item_list[devspec].length;
 786     }
 787
 788     *root = item_list[rootspec].component;
 789     *root_len = item_list[rootspec].length;
 790
 791     *dir = item_list[dirspec].component;
 792     *dir_len = item_list[dirspec].length;
 793
 794     /* Now fun with versions and EFS file specifications
 795      * The parser can not tell the difference when a "." is a version
 796      * delimiter or a part of the file specification.
 797      */
 798     if ((decc_efs_charset) &&
 799         (item_list[verspec].length > 0) &&
 800         (item_list[verspec].component[0] == '.')) {
 801         *name = item_list[namespec].component;
 802         *name_len = item_list[namespec].length + item_list[typespec].length;
 803         *ext = item_list[verspec].component;
 804         *ext_len = item_list[verspec].length;
 805         *version = NULL;
 806         *ver_len = 0;
 807     }
 808     else {
 809         *name = item_list[namespec].component;
 810         *name_len = item_list[namespec].length;
 811         *ext = item_list[typespec].component;
 812         *ext_len = item_list[typespec].length;
 813         *version = item_list[verspec].component;
 814         *ver_len = item_list[verspec].length;
 815     }
 816     return ret_stat;
 817 }
 818
 819 /* Routine to determine if the file specification ends with .dir */
 820 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 821
 822     /* e_len must be 4, and version must be <= 2 characters */
 823     if (e_len != 4 || vs_len > 2)
 824         return 0;
 825
 826     /* If a version number is present, it needs to be one */
 827     if ((vs_len == 2) && (vs_spec[1] != '1'))
 828         return 0;
 829
 830     /* Look for the DIR on the extension */
 831     if (vms_process_case_tolerant) {
 832         if ((toupper(e_spec[1]) == 'D') &&
 833             (toupper(e_spec[2]) == 'I') &&
 834             (toupper(e_spec[3]) == 'R')) {
 835             return 1;
 836         }
 837     } else {
 838         /* Directory extensions are supposed to be in upper case only */
 839         /* I would not be surprised if this rule can not be enforced */
 840         /* if and when someone fully debugs the case sensitive mode */
 841         if ((e_spec[1] == 'D') &&
 842             (e_spec[2] == 'I') &&
 843             (e_spec[3] == 'R')) {
 844             return 1;
 845         }
 846     }
 847     return 0;
 848 }
 849
 850
 851 /* my_maxidx
 852  * Routine to retrieve the maximum equivalence index for an input
 853  * logical name.  Some calls to this routine have no knowledge if
 854  * the variable is a logical or not.  So on error we return a max
 855  * index of zero.
 856  */
 857 /*{{{int my_maxidx(const char *lnm) */
 858 static int
 859 my_maxidx(const char *lnm)
 860 {
 861     int status;
 862     int midx;
 863     int attr = LNM$M_CASE_BLIND;
 864     struct dsc$descriptor lnmdsc;
 865     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 866                                 {0, 0, 0, 0}};
 867
 868     lnmdsc.dsc$w_length = strlen(lnm);
 869     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 870     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 871     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 872
 873     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 874     if ((status & 1) == 0)
 875        midx = 0;
 876
 877     return (midx);
 878 }
 879 /*}}}*/
 880
 881 /* Routine to remove the 2-byte prefix from the translation of a
 882  * process-permanent file (PPF).
 883  */
 884 static inline unsigned short int
 885 S_remove_ppf_prefix(const char *lnm, char *eqv, unsigned short int eqvlen)
 886 {
 887     if (*((int *)lnm) == *((int *)"SYS$")                    &&
 888         eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00      &&
 889         ( (lnm[4] == 'O' && !strcmp(lnm,"SYS$OUTPUT"))  ||
 890           (lnm[4] == 'I' && !strcmp(lnm,"SYS$INPUT"))   ||
 891           (lnm[4] == 'E' && !strcmp(lnm,"SYS$ERROR"))   ||
 892           (lnm[4] == 'C' && !strcmp(lnm,"SYS$COMMAND")) )  ) {
 893
 894         memmove(eqv, eqv+4, eqvlen-4);
 895         eqvlen -= 4;
 896     }
 897     return eqvlen;
 898 }
 899
 900 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 901 int
 902 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 903   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 904 {
 905     const char *cp1;
 906     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 907     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 908     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 909     int midx;
 910     unsigned char acmode;
 911     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 912                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 913     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 914                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 915                                  {0, 0, 0, 0}};
 916     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 917 #if defined(PERL_IMPLICIT_CONTEXT)
 918     pTHX = NULL;
 919     if (PL_curinterp) {
 920       aTHX = PERL_GET_INTERP;
 921     } else {
 922       aTHX = NULL;
 923     }
 924 #endif
 925
 926     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 927       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 928     }
 929     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 930       *cp2 = _toupper(*cp1);
 931       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 932         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 933         return 0;
 934       }
 935     }
 936     lnmdsc.dsc$w_length = cp1 - lnm;
 937     lnmdsc.dsc$a_pointer = uplnm;
 938     uplnm[lnmdsc.dsc$w_length] = '\0';
 939     secure = flags & PERL__TRNENV_SECURE;
 940     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 941     if (!tabvec || !*tabvec) tabvec = env_tables;
 942
 943     for (curtab = 0; tabvec[curtab]; curtab++) {
 944       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 945         if (!ivenv && !secure) {
 946           char *eq;
 947           int i;
 948           if (!environ) {
 949             ivenv = 1;
 950 #if defined(PERL_IMPLICIT_CONTEXT)
 951             if (aTHX == NULL) {
 952                 fprintf(stderr,
 953                     "Can't read CRTL environ\n");
 954             } else
 955 #endif
 956                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 957             continue;
 958           }
 959           retsts = SS$_NOLOGNAM;
 960           for (i = 0; environ[i]; i++) {
 961             if ((eq = strchr(environ[i],'=')) &&
 962                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 963                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 964               eq++;
 965               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 966               if (!eqvlen) continue;
 967               retsts = SS$_NORMAL;
 968               break;
 969             }
 970           }
 971           if (retsts != SS$_NOLOGNAM) break;
 972         }
 973       }
 974       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 975                !str$case_blind_compare(&tmpdsc,&clisym)) {
 976         if (!ivsym && !secure) {
 977           unsigned short int deflen = LNM$C_NAMLENGTH;
 978           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 979           /* dynamic dsc to accommodate possible long value */
 980           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 981           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 982           if (retsts & 1) {
 983             if (eqvlen > MAX_DCL_SYMBOL) {
 984               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 985               eqvlen = MAX_DCL_SYMBOL;
 986               /* Special hack--we might be called before the interpreter's */
 987               /* fully initialized, in which case either thr or PL_curcop */
 988               /* might be bogus. We have to check, since ckWARN needs them */
 989               /* both to be valid if running threaded */
 990 #if defined(PERL_IMPLICIT_CONTEXT)
 991               if (aTHX == NULL) {
 992                   fprintf(stderr,
 993                      "Value of CLI symbol \"%s\" too long",lnm);
 994               } else
 995 #endif
 996                 if (ckWARN(WARN_MISC)) {
 997                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 998                 }
 999             }
1000             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1001           }
1002           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1003           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1004           if (retsts == LIB$_NOSUCHSYM) continue;
1005           break;
1006         }
1007       }
1008       else if (!ivlnm) {
1009         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1010           midx = my_maxidx(lnm);
1011           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1012             lnmlst[1].bufadr = cp2;
1013             eqvlen = 0;
1014             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1015             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1016             if (retsts == SS$_NOLOGNAM) break;
1017             eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
1018             cp2 += eqvlen;
1019             *cp2 = '\0';
1020           }
1021           if ((retsts == SS$_IVLOGNAM) ||
1022               (retsts == SS$_NOLOGNAM)) { continue; }
1023           eqvlen = strlen(eqv);
1024         }
1025         else {
1026           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1027           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1028           if (retsts == SS$_NOLOGNAM) continue;
1029           eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
1030           eqv[eqvlen] = '\0';
1031         }
1032         break;
1033       }
1034     }
1035     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1036     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1037              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1038              retsts == SS$_NOLOGNAM) {
1039       set_errno(EINVAL);  set_vaxc_errno(retsts);
1040     }
1041     else _ckvmssts_noperl(retsts);
1042     return 0;
1043 }  /* end of vmstrnenv */
1044 /*}}}*/
1045
1046 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1047 /* Define as a function so we can access statics. */
1048 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1049 {
1050     int flags = 0;
1051
1052 #if defined(PERL_IMPLICIT_CONTEXT)
1053     if (aTHX != NULL)
1054 #endif
1055 #ifdef SECURE_INTERNAL_GETENV
1056         flags = (PL_curinterp ? TAINTING_get : will_taint) ?
1057                  PERL__TRNENV_SECURE : 0;
1058 #endif
1059
1060     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1061 }
1062 /*}}}*/
1063
1064 /* my_getenv
1065  * Note: Uses Perl temp to store result so char * can be returned to
1066  * caller; this pointer will be invalidated at next Perl statement
1067  * transition.
1068  * We define this as a function rather than a macro in terms of my_getenv_len()
1069  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1070  * allocate SVs).
1071  */
1072 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1073 char *
1074 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1075 {
1076     const char *cp1;
1077     static char *__my_getenv_eqv = NULL;
1078     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1079     unsigned long int idx = 0;
1080     int success, secure, saverr, savvmserr;
1081     int midx, flags;
1082     SV *tmpsv;
1083
1084     midx = my_maxidx(lnm) + 1;
1085
1086     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1087       /* Set up a temporary buffer for the return value; Perl will
1088        * clean it up at the next statement transition */
1089       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1090       if (!tmpsv) return NULL;
1091       eqv = SvPVX(tmpsv);
1092     }
1093     else {
1094       /* Assume no interpreter ==> single thread */
1095       if (__my_getenv_eqv != NULL) {
1096         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1097       }
1098       else {
1099         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1100       }
1101       eqv = __my_getenv_eqv;
1102     }
1103
1104     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1105     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1106       int len;
1107       getcwd(eqv,LNM$C_NAMLENGTH);
1108
1109       len = strlen(eqv);
1110
1111       /* Get rid of "000000/ in rooted filespecs */
1112       if (len > 7) {
1113         char * zeros;
1114         zeros = strstr(eqv, "/000000/");
1115         if (zeros != NULL) {
1116           int mlen;
1117           mlen = len - (zeros - eqv) - 7;
1118           memmove(zeros, &zeros[7], mlen);
1119           len = len - 7;
1120           eqv[len] = '\0';
1121         }
1122       }
1123       return eqv;
1124     }
1125     else {
1126       /* Impose security constraints only if tainting */
1127       if (sys) {
1128         /* Impose security constraints only if tainting */
1129         secure = PL_curinterp ? TAINTING_get : will_taint;
1130         saverr = errno;  savvmserr = vaxc$errno;
1131       }
1132       else {
1133         secure = 0;
1134       }
1135
1136       flags =
1137 #ifdef SECURE_INTERNAL_GETENV
1138               secure ? PERL__TRNENV_SECURE : 0
1139 #else
1140               0
1141 #endif
1142       ;
1143
1144       /* For the getenv interface we combine all the equivalence names
1145        * of a search list logical into one value to acquire a maximum
1146        * value length of 255*128 (assuming %ENV is using logicals).
1147        */
1148       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1149
1150       /* If the name contains a semicolon-delimited index, parse it
1151        * off and make sure we only retrieve the equivalence name for
1152        * that index.  */
1153       if ((cp2 = strchr(lnm,';')) != NULL) {
1154         my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1155         idx = strtoul(cp2+1,NULL,0);
1156         lnm = uplnm;
1157         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1158       }
1159
1160       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1161
1162       /* Discard NOLOGNAM on internal calls since we're often looking
1163        * for an optional name, and this "error" often shows up as the
1164        * (bogus) exit status for a die() call later on.  */
1165       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1166       return success ? eqv : NULL;
1167     }
1168
1169 }  /* end of my_getenv() */
1170 /*}}}*/
1171
1172
1173 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1174 char *
1175 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1176 {
1177     const char *cp1;
1178     char *buf, *cp2;
1179     unsigned long idx = 0;
1180     int midx, flags;
1181     static char *__my_getenv_len_eqv = NULL;
1182     int secure, saverr, savvmserr;
1183     SV *tmpsv;
1184
1185     midx = my_maxidx(lnm) + 1;
1186
1187     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1188       /* Set up a temporary buffer for the return value; Perl will
1189        * clean it up at the next statement transition */
1190       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1191       if (!tmpsv) return NULL;
1192       buf = SvPVX(tmpsv);
1193     }
1194     else {
1195       /* Assume no interpreter ==> single thread */
1196       if (__my_getenv_len_eqv != NULL) {
1197         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1198       }
1199       else {
1200         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1201       }
1202       buf = __my_getenv_len_eqv;
1203     }
1204
1205     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1206     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1207     char * zeros;
1208
1209       getcwd(buf,LNM$C_NAMLENGTH);
1210       *len = strlen(buf);
1211
1212       /* Get rid of "000000/ in rooted filespecs */
1213       if (*len > 7) {
1214       zeros = strstr(buf, "/000000/");
1215       if (zeros != NULL) {
1216         int mlen;
1217         mlen = *len - (zeros - buf) - 7;
1218         memmove(zeros, &zeros[7], mlen);
1219         *len = *len - 7;
1220         buf[*len] = '\0';
1221         }
1222       }
1223       return buf;
1224     }
1225     else {
1226       if (sys) {
1227         /* Impose security constraints only if tainting */
1228         secure = PL_curinterp ? TAINTING_get : will_taint;
1229         saverr = errno;  savvmserr = vaxc$errno;
1230       }
1231       else {
1232         secure = 0;
1233       }
1234
1235       flags =
1236 #ifdef SECURE_INTERNAL_GETENV
1237               secure ? PERL__TRNENV_SECURE : 0
1238 #else
1239               0
1240 #endif
1241       ;
1242
1243       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1244
1245       if ((cp2 = strchr(lnm,';')) != NULL) {
1246         my_strlcpy(buf, lnm, cp2 - lnm + 1);
1247         idx = strtoul(cp2+1,NULL,0);
1248         lnm = buf;
1249         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1250       }
1251
1252       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1253
1254       /* Get rid of "000000/ in rooted filespecs */
1255       if (*len > 7) {
1256       char * zeros;
1257         zeros = strstr(buf, "/000000/");
1258         if (zeros != NULL) {
1259           int mlen;
1260           mlen = *len - (zeros - buf) - 7;
1261           memmove(zeros, &zeros[7], mlen);
1262           *len = *len - 7;
1263           buf[*len] = '\0';
1264         }
1265       }
1266
1267       /* Discard NOLOGNAM on internal calls since we're often looking
1268        * for an optional name, and this "error" often shows up as the
1269        * (bogus) exit status for a die() call later on.  */
1270       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1271       return *len ? buf : NULL;
1272     }
1273
1274 }  /* end of my_getenv_len() */
1275 /*}}}*/
1276
1277 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1278
1279 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1280
1281 /*{{{ void prime_env_iter() */
1282 void
1283 prime_env_iter(void)
1284 /* Fill the %ENV associative array with all logical names we can
1285  * find, in preparation for iterating over it.
1286  */
1287 {
1288   static int primed = 0;
1289   HV *seenhv = NULL, *envhv;
1290   SV *sv = NULL;
1291   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1292   unsigned short int chan;
1293 #ifndef CLI$M_TRUSTED
1294 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1295 #endif
1296   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1297   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1298   long int i;
1299   bool have_sym = FALSE, have_lnm = FALSE;
1300   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1301   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1302   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1303   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1304   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1305 #if defined(PERL_IMPLICIT_CONTEXT)
1306   pTHX;
1307 #endif
1308 #if defined(USE_ITHREADS)
1309   static perl_mutex primenv_mutex;
1310   MUTEX_INIT(&primenv_mutex);
1311 #endif
1312
1313 #if defined(PERL_IMPLICIT_CONTEXT)
1314     /* We jump through these hoops because we can be called at */
1315     /* platform-specific initialization time, which is before anything is */
1316     /* set up--we can't even do a plain dTHX since that relies on the */
1317     /* interpreter structure to be initialized */
1318     if (PL_curinterp) {
1319       aTHX = PERL_GET_INTERP;
1320     } else {
1321       /* we never get here because the NULL pointer will cause the */
1322       /* several of the routines called by this routine to access violate */
1323
1324       /* This routine is only called by hv.c/hv_iterinit which has a */
1325       /* context, so the real fix may be to pass it through instead of */
1326       /* the hoops above */
1327       aTHX = NULL;
1328     }
1329 #endif
1330
1331   if (primed || !PL_envgv) return;
1332   MUTEX_LOCK(&primenv_mutex);
1333   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1334   envhv = GvHVn(PL_envgv);
1335   /* Perform a dummy fetch as an lval to insure that the hash table is
1336    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1337   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1338
1339   for (i = 0; env_tables[i]; i++) {
1340      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1341          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1342      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1343   }
1344   if (have_sym || have_lnm) {
1345     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1346     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1347     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1348     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1349   }
1350
1351   for (i--; i >= 0; i--) {
1352     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1353       char *start;
1354       int j;
1355       for (j = 0; environ[j]; j++) {
1356         if (!(start = strchr(environ[j],'='))) {
1357           if (ckWARN(WARN_INTERNAL))
1358             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1359         }
1360         else {
1361           start++;
1362           sv = newSVpv(start,0);
1363           SvTAINTED_on(sv);
1364           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1365         }
1366       }
1367       continue;
1368     }
1369     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1370              !str$case_blind_compare(&tmpdsc,&clisym)) {
1371       my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1372       cmddsc.dsc$w_length = 20;
1373       if (env_tables[i]->dsc$w_length == 12 &&
1374           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1375           !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local  *", sizeof(cmd)-12);
1376       flags = defflags | CLI$M_NOLOGNAM;
1377     }
1378     else {
1379       my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1380       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1381         my_strlcat(cmd," /Table=", sizeof(cmd));
1382         cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, sizeof(cmd));
1383       }
1384       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1385       flags = defflags | CLI$M_NOCLISYM;
1386     }
1387
1388     /* Create a new subprocess to execute each command, to exclude the
1389      * remote possibility that someone could subvert a mbx or file used
1390      * to write multiple commands to a single subprocess.
1391      */
1392     do {
1393       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1394                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1395       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1396       defflags &= ~CLI$M_TRUSTED;
1397     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1398     _ckvmssts(retsts);
1399     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1400     if (seenhv) SvREFCNT_dec(seenhv);
1401     seenhv = newHV();
1402     while (1) {
1403       char *cp1, *cp2, *key;
1404       unsigned long int sts, iosb[2], retlen, keylen;
1405       U32 hash;
1406
1407       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1408       if (sts & 1) sts = iosb[0] & 0xffff;
1409       if (sts == SS$_ENDOFFILE) {
1410         int wakect = 0;
1411         while (substs == 0) { sys$hiber(); wakect++;}
1412         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1413         _ckvmssts(substs);
1414         break;
1415       }
1416       _ckvmssts(sts);
1417       retlen = iosb[0] >> 16;
1418       if (!retlen) continue;  /* blank line */
1419       buf[retlen] = '\0';
1420       if (iosb[1] != subpid) {
1421         if (iosb[1]) {
1422           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1423         }
1424         continue;
1425       }
1426       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1427         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1428
1429       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1430       if (*cp1 == '(' || /* Logical name table name */
1431           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1432       if (*cp1 == '"') cp1++;
1433       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1434       key = cp1;  keylen = cp2 - cp1;
1435       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1436       while (*cp2 && *cp2 != '=') cp2++;
1437       while (*cp2 && *cp2 == '=') cp2++;
1438       while (*cp2 && *cp2 == ' ') cp2++;
1439       if (*cp2 == '"') {  /* String translation; may embed "" */
1440         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1441         cp2++;  cp1--; /* Skip "" surrounding translation */
1442       }
1443       else {  /* Numeric translation */
1444         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1445         cp1--;  /* stop on last non-space char */
1446       }
1447       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1448         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1449         continue;
1450       }
1451       PERL_HASH(hash,key,keylen);
1452
1453       if (cp1 == cp2 && *cp2 == '.') {
1454         /* A single dot usually means an unprintable character, such as a null
1455          * to indicate a zero-length value.  Get the actual value to make sure.
1456          */
1457         char lnm[LNM$C_NAMLENGTH+1];
1458         char eqv[MAX_DCL_SYMBOL+1];
1459         int trnlen;
1460         strncpy(lnm, key, keylen);
1461         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1462         sv = newSVpvn(eqv, strlen(eqv));
1463       }
1464       else {
1465         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1466       }
1467
1468       SvTAINTED_on(sv);
1469       hv_store(envhv,key,keylen,sv,hash);
1470       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1471     }
1472     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1473       /* get the PPFs for this process, not the subprocess */
1474       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1475       char eqv[LNM$C_NAMLENGTH+1];
1476       int trnlen, i;
1477       for (i = 0; ppfs[i]; i++) {
1478         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1479         sv = newSVpv(eqv,trnlen);
1480         SvTAINTED_on(sv);
1481         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1482       }
1483     }
1484   }
1485   primed = 1;
1486   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1487   if (buf) Safefree(buf);
1488   if (seenhv) SvREFCNT_dec(seenhv);
1489   MUTEX_UNLOCK(&primenv_mutex);
1490   return;
1491
1492 }  /* end of prime_env_iter */
1493 /*}}}*/
1494
1495
1496 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1497 /* Define or delete an element in the same "environment" as
1498  * vmstrnenv().  If an element is to be deleted, it's removed from
1499  * the first place it's found.  If it's to be set, it's set in the
1500  * place designated by the first element of the table vector.
1501  * Like setenv() returns 0 for success, non-zero on error.
1502  */
1503 int
1504 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1505 {
1506     const char *cp1;
1507     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1508     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1509     int nseg = 0, j;
1510     unsigned long int retsts, usermode = PSL$C_USER;
1511     struct itmlst_3 *ile, *ilist;
1512     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1513                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1514                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1515     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1516     $DESCRIPTOR(local,"_LOCAL");
1517
1518     if (!lnm) {
1519         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1520         return SS$_IVLOGNAM;
1521     }
1522
1523     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1524       *cp2 = _toupper(*cp1);
1525       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1526         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1527         return SS$_IVLOGNAM;
1528       }
1529     }
1530     lnmdsc.dsc$w_length = cp1 - lnm;
1531     if (!tabvec || !*tabvec) tabvec = env_tables;
1532
1533     if (!eqv) {  /* we're deleting n element */
1534       for (curtab = 0; tabvec[curtab]; curtab++) {
1535         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1536         int i;
1537           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1538             if ((cp1 = strchr(environ[i],'=')) &&
1539                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1540                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1541 #ifdef HAS_SETENV
1542               return setenv(lnm,"",1) ? vaxc$errno : 0;
1543             }
1544           }
1545           ivenv = 1; retsts = SS$_NOLOGNAM;
1546 #else
1547               if (ckWARN(WARN_INTERNAL))
1548                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1549               ivenv = 1; retsts = SS$_NOSUCHPGM;
1550               break;
1551             }
1552           }
1553 #endif
1554         }
1555         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1556                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1557           unsigned int symtype;
1558           if (tabvec[curtab]->dsc$w_length == 12 &&
1559               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1560               !str$case_blind_compare(&tmpdsc,&local))
1561             symtype = LIB$K_CLI_LOCAL_SYM;
1562           else symtype = LIB$K_CLI_GLOBAL_SYM;
1563           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1564           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1565           if (retsts == LIB$_NOSUCHSYM) continue;
1566           break;
1567         }
1568         else if (!ivlnm) {
1569           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1570           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1571           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1572           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1573           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1574         }
1575       }
1576     }
1577     else {  /* we're defining a value */
1578       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1579 #ifdef HAS_SETENV
1580         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1581 #else
1582         if (ckWARN(WARN_INTERNAL))
1583           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1584         retsts = SS$_NOSUCHPGM;
1585 #endif
1586       }
1587       else {
1588         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1589         eqvdsc.dsc$w_length  = strlen(eqv);
1590         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1591             !str$case_blind_compare(&tmpdsc,&clisym)) {
1592           unsigned int symtype;
1593           if (tabvec[0]->dsc$w_length == 12 &&
1594               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1595                !str$case_blind_compare(&tmpdsc,&local))
1596             symtype = LIB$K_CLI_LOCAL_SYM;
1597           else symtype = LIB$K_CLI_GLOBAL_SYM;
1598           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1599         }
1600         else {
1601           if (!*eqv) eqvdsc.dsc$w_length = 1;
1602           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1603
1604             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1605             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1606               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1607                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1608               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1609               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1610             }
1611
1612             Newx(ilist,nseg+1,struct itmlst_3);
1613             ile = ilist;
1614             if (!ile) {
1615               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1616               return SS$_INSFMEM;
1617             }
1618             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1619
1620             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1621               ile->itmcode = LNM$_STRING;
1622               ile->bufadr = c;
1623               if ((j+1) == nseg) {
1624                 ile->buflen = strlen(c);
1625                 /* in case we are truncating one that's too long */
1626                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1627               }
1628               else {
1629                 ile->buflen = LNM$C_NAMLENGTH;
1630               }
1631             }
1632
1633             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1634             Safefree (ilist);
1635           }
1636           else {
1637             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1638           }
1639         }
1640       }
1641     }
1642     if (!(retsts & 1)) {
1643       switch (retsts) {
1644         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1645         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1646           set_errno(EVMSERR); break;
1647         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1648         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1649           set_errno(EINVAL); break;
1650         case SS$_NOPRIV:
1651           set_errno(EACCES); break;
1652         default:
1653           _ckvmssts(retsts);
1654           set_errno(EVMSERR);
1655        }
1656        set_vaxc_errno(retsts);
1657        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1658     }
1659     else {
1660       /* We reset error values on success because Perl does an hv_fetch()
1661        * before each hv_store(), and if the thing we're setting didn't
1662        * previously exist, we've got a leftover error message.  (Of course,
1663        * this fails in the face of
1664        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1665        * in that the error reported in $! isn't spurious,
1666        * but it's right more often than not.)
1667        */
1668       set_errno(0); set_vaxc_errno(retsts);
1669       return 0;
1670     }
1671
1672 }  /* end of vmssetenv() */
1673 /*}}}*/
1674
1675 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1676 /* This has to be a function since there's a prototype for it in proto.h */
1677 void
1678 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1679 {
1680     if (lnm && *lnm) {
1681       int len = strlen(lnm);
1682       if  (len == 7) {
1683         char uplnm[8];
1684         int i;
1685         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1686         if (!strcmp(uplnm,"DEFAULT")) {
1687           if (eqv && *eqv) my_chdir(eqv);
1688           return;
1689         }
1690     }
1691   }
1692   (void) vmssetenv(lnm,eqv,NULL);
1693 }
1694 /*}}}*/
1695
1696 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1697 /*  vmssetuserlnm
1698  *  sets a user-mode logical in the process logical name table
1699  *  used for redirection of sys$error
1700  */
1701 void
1702 Perl_vmssetuserlnm(const char *name, const char *eqv)
1703 {
1704     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1705     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1706     unsigned long int iss, attr = LNM$M_CONFINE;
1707     unsigned char acmode = PSL$C_USER;
1708     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1709                                  {0, 0, 0, 0}};
1710     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1711     d_name.dsc$w_length = strlen(name);
1712
1713     lnmlst[0].buflen = strlen(eqv);
1714     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1715
1716     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1717     if (!(iss&1)) lib$signal(iss);
1718 }
1719 /*}}}*/
1720
1721
1722 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1723 /* my_crypt - VMS password hashing
1724  * my_crypt() provides an interface compatible with the Unix crypt()
1725  * C library function, and uses sys$hash_password() to perform VMS
1726  * password hashing.  The quadword hashed password value is returned
1727  * as a NUL-terminated 8 character string.  my_crypt() does not change
1728  * the case of its string arguments; in order to match the behavior
1729  * of LOGINOUT et al., alphabetic characters in both arguments must
1730  *  be upcased by the caller.
1731  *
1732  * - fix me to call ACM services when available
1733  */
1734 char *
1735 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1736 {
1737 #   ifndef UAI$C_PREFERRED_ALGORITHM
1738 #     define UAI$C_PREFERRED_ALGORITHM 127
1739 #   endif
1740     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1741     unsigned short int salt = 0;
1742     unsigned long int sts;
1743     struct const_dsc {
1744         unsigned short int dsc$w_length;
1745         unsigned char      dsc$b_type;
1746         unsigned char      dsc$b_class;
1747         const char *       dsc$a_pointer;
1748     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1749        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1750     struct itmlst_3 uailst[3] = {
1751         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1752         { sizeof salt, UAI$_SALT,    &salt, 0},
1753         { 0,           0,            NULL,  NULL}};
1754     static char hash[9];
1755
1756     usrdsc.dsc$w_length = strlen(usrname);
1757     usrdsc.dsc$a_pointer = usrname;
1758     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1759       switch (sts) {
1760         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1761           set_errno(EACCES);
1762           break;
1763         case RMS$_RNF:
1764           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1765           break;
1766         default:
1767           set_errno(EVMSERR);
1768       }
1769       set_vaxc_errno(sts);
1770       if (sts != RMS$_RNF) return NULL;
1771     }
1772
1773     txtdsc.dsc$w_length = strlen(textpasswd);
1774     txtdsc.dsc$a_pointer = textpasswd;
1775     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1776       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1777     }
1778
1779     return (char *) hash;
1780
1781 }  /* end of my_crypt() */
1782 /*}}}*/
1783
1784
1785 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1786 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1787 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1788
1789 /* fixup barenames that are directories for internal use.
1790  * There have been problems with the consistent handling of UNIX
1791  * style directory names when routines are presented with a name that
1792  * has no directory delimiters at all.  So this routine will eventually
1793  * fix the issue.
1794  */
1795 static char * fixup_bare_dirnames(const char * name)
1796 {
1797   if (decc_disable_to_vms_logname_translation) {
1798 /* fix me */
1799   }
1800   return NULL;
1801 }
1802
1803 /* 8.3, remove() is now broken on symbolic links */
1804 static int rms_erase(const char * vmsname);
1805
1806
1807 /* mp_do_kill_file
1808  * A little hack to get around a bug in some implementation of remove()
1809  * that do not know how to delete a directory
1810  *
1811  * Delete any file to which user has control access, regardless of whether
1812  * delete access is explicitly allowed.
1813  * Limitations: User must have write access to parent directory.
1814  *              Does not block signals or ASTs; if interrupted in midstream
1815  *              may leave file with an altered ACL.
1816  * HANDLE WITH CARE!
1817  */
1818 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1819 static int
1820 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1821 {
1822     char *vmsname;
1823     char *rslt;
1824     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1825     unsigned long int cxt = 0, aclsts, fndsts;
1826     int rmsts = -1;
1827     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1828     struct myacedef {
1829       unsigned char myace$b_length;
1830       unsigned char myace$b_type;
1831       unsigned short int myace$w_flags;
1832       unsigned long int myace$l_access;
1833       unsigned long int myace$l_ident;
1834     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1835                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1836       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1837      struct itmlst_3
1838        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1839                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1840        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1841        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1842        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1843        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1844
1845     /* Expand the input spec using RMS, since the CRTL remove() and
1846      * system services won't do this by themselves, so we may miss
1847      * a file "hiding" behind a logical name or search list. */
1848     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1849     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1850
1851     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1852     if (rslt == NULL) {
1853         PerlMem_free(vmsname);
1854         return -1;
1855       }
1856
1857     /* Erase the file */
1858     rmsts = rms_erase(vmsname);
1859
1860     /* Did it succeed */
1861     if ($VMS_STATUS_SUCCESS(rmsts)) {
1862         PerlMem_free(vmsname);
1863         return 0;
1864       }
1865
1866     /* If not, can changing protections help? */
1867     if (rmsts != RMS$_PRV) {
1868       set_vaxc_errno(rmsts);
1869       PerlMem_free(vmsname);
1870       return -1;
1871     }
1872
1873     /* No, so we get our own UIC to use as a rights identifier,
1874      * and the insert an ACE at the head of the ACL which allows us
1875      * to delete the file.
1876      */
1877     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1878     fildsc.dsc$w_length = strlen(vmsname);
1879     fildsc.dsc$a_pointer = vmsname;
1880     cxt = 0;
1881     newace.myace$l_ident = oldace.myace$l_ident;
1882     rmsts = -1;
1883     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1884       switch (aclsts) {
1885         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1886           set_errno(ENOENT); break;
1887         case RMS$_DIR:
1888           set_errno(ENOTDIR); break;
1889         case RMS$_DEV:
1890           set_errno(ENODEV); break;
1891         case RMS$_SYN: case SS$_INVFILFOROP:
1892           set_errno(EINVAL); break;
1893         case RMS$_PRV:
1894           set_errno(EACCES); break;
1895         default:
1896           _ckvmssts_noperl(aclsts);
1897       }
1898       set_vaxc_errno(aclsts);
1899       PerlMem_free(vmsname);
1900       return -1;
1901     }
1902     /* Grab any existing ACEs with this identifier in case we fail */
1903     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1904     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1905                     || fndsts == SS$_NOMOREACE ) {
1906       /* Add the new ACE . . . */
1907       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1908         goto yourroom;
1909
1910       rmsts = rms_erase(vmsname);
1911       if ($VMS_STATUS_SUCCESS(rmsts)) {
1912         rmsts = 0;
1913         }
1914         else {
1915         rmsts = -1;
1916         /* We blew it - dir with files in it, no write priv for
1917          * parent directory, etc.  Put things back the way they were. */
1918         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1919           goto yourroom;
1920         if (fndsts & 1) {
1921           addlst[0].bufadr = &oldace;
1922           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1923             goto yourroom;
1924         }
1925       }
1926     }
1927
1928     yourroom:
1929     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1930     /* We just deleted it, so of course it's not there.  Some versions of
1931      * VMS seem to return success on the unlock operation anyhow (after all
1932      * the unlock is successful), but others don't.
1933      */
1934     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1935     if (aclsts & 1) aclsts = fndsts;
1936     if (!(aclsts & 1)) {
1937       set_errno(EVMSERR);
1938       set_vaxc_errno(aclsts);
1939     }
1940
1941     PerlMem_free(vmsname);
1942     return rmsts;
1943
1944 }  /* end of kill_file() */
1945 /*}}}*/
1946
1947
1948 /*{{{int do_rmdir(char *name)*/
1949 int
1950 Perl_do_rmdir(pTHX_ const char *name)
1951 {
1952     char * dirfile;
1953     int retval;
1954     Stat_t st;
1955
1956     /* lstat returns a VMS fileified specification of the name */
1957     /* that is looked up, and also lets verifies that this is a directory */
1958
1959     retval = flex_lstat(name, &st);
1960     if (retval != 0) {
1961         char * ret_spec;
1962
1963         /* Due to a historical feature, flex_stat/lstat can not see some */
1964         /* Unix format file names that the rest of the CRTL can see */
1965         /* Fixing that feature will cause some perl tests to fail */
1966         /* So try this one more time. */
1967
1968         retval = lstat(name, &st.crtl_stat);
1969         if (retval != 0)
1970             return -1;
1971
1972         /* force it to a file spec for the kill file to work. */
1973         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1974         if (ret_spec == NULL) {
1975             errno = EIO;
1976             return -1;
1977         }
1978     }
1979
1980     if (!S_ISDIR(st.st_mode)) {
1981         errno = ENOTDIR;
1982         retval = -1;
1983     }
1984     else {
1985         dirfile = st.st_devnam;
1986
1987         /* It may be possible for flex_stat to find a file and vmsify() to */
1988         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
1989         /* with that case, so fail it */
1990         if (dirfile[0] == 0) {
1991             errno = EIO;
1992             return -1;
1993         }
1994
1995         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1996     }
1997
1998     return retval;
1999
2000 }  /* end of do_rmdir */
2001 /*}}}*/
2002
2003 /* kill_file
2004  * Delete any file to which user has control access, regardless of whether
2005  * delete access is explicitly allowed.
2006  * Limitations: User must have write access to parent directory.
2007  *              Does not block signals or ASTs; if interrupted in midstream
2008  *              may leave file with an altered ACL.
2009  * HANDLE WITH CARE!
2010  */
2011 /*{{{int kill_file(char *name)*/
2012 int
2013 Perl_kill_file(pTHX_ const char *name)
2014 {
2015     char * vmsfile;
2016     Stat_t st;
2017     int rmsts;
2018
2019     /* Convert the filename to VMS format and see if it is a directory */
2020     /* flex_lstat returns a vmsified file specification */
2021     rmsts = flex_lstat(name, &st);
2022     if (rmsts != 0) {
2023
2024         /* Due to a historical feature, flex_stat/lstat can not see some */
2025         /* Unix format file names that the rest of the CRTL can see when */
2026         /* ODS-2 file specifications are in use. */
2027         /* Fixing that feature will cause some perl tests to fail */
2028         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2029         st.st_mode = 0;
2030         vmsfile = (char *) name; /* cast ok */
2031
2032     } else {
2033         vmsfile = st.st_devnam;
2034         if (vmsfile[0] == 0) {
2035             /* It may be possible for flex_stat to find a file and vmsify() */
2036             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2037             /* deal with that case, so fail it */
2038             errno = EIO;
2039             return -1;
2040         }
2041     }
2042
2043     /* Remove() is allowed to delete directories, according to the X/Open
2044      * specifications.
2045      * This may need special handling to work with the ACL hacks.
2046      */
2047     if (S_ISDIR(st.st_mode)) {
2048         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2049         return rmsts;
2050     }
2051
2052     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2053
2054     /* Need to delete all versions ? */
2055     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2056         int i = 0;
2057
2058         /* Just use lstat() here as do not need st_dev */
2059         /* and we know that the file is in VMS format or that */
2060         /* because of a historical bug, flex_stat can not see the file */
2061         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2062             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2063             if (rmsts != 0)
2064                 break;
2065             i++;
2066
2067             /* Make sure that we do not loop forever */
2068             if (i > 32767) {
2069                 errno = EIO;
2070                 rmsts = -1;
2071                 break;
2072             }
2073         }
2074     }
2075
2076     return rmsts;
2077
2078 }  /* end of kill_file() */
2079 /*}}}*/
2080
2081
2082 /*{{{int my_mkdir(char *,Mode_t)*/
2083 int
2084 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2085 {
2086   STRLEN dirlen = strlen(dir);
2087
2088   /* zero length string sometimes gives ACCVIO */
2089   if (dirlen == 0) return -1;
2090
2091   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2092    * null file name/type.  However, it's commonplace under Unix,
2093    * so we'll allow it for a gain in portability.
2094    */
2095   if (dir[dirlen-1] == '/') {
2096     char *newdir = savepvn(dir,dirlen-1);
2097     int ret = mkdir(newdir,mode);
2098     Safefree(newdir);
2099     return ret;
2100   }
2101   else return mkdir(dir,mode);
2102 }  /* end of my_mkdir */
2103 /*}}}*/
2104
2105 /*{{{int my_chdir(char *)*/
2106 int
2107 Perl_my_chdir(pTHX_ const char *dir)
2108 {
2109   STRLEN dirlen = strlen(dir);
2110   const char *dir1 = dir;
2111
2112   /* zero length string sometimes gives ACCVIO */
2113   if (dirlen == 0) {
2114     SETERRNO(EINVAL, SS$_BADPARAM);
2115     return -1;
2116   }
2117
2118   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2119    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2120    * so that existing scripts do not need to be changed.
2121    */
2122   while ((dirlen > 0) && (*dir1 == ' ')) {
2123     dir1++;
2124     dirlen--;
2125   }
2126
2127   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2128    * that implies
2129    * null file name/type.  However, it's commonplace under Unix,
2130    * so we'll allow it for a gain in portability.
2131    *
2132    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2133    */
2134   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2135       char *newdir;
2136       int ret;
2137       newdir = (char *)PerlMem_malloc(dirlen);
2138       if (newdir ==NULL)
2139           _ckvmssts_noperl(SS$_INSFMEM);
2140       memcpy(newdir, dir1, dirlen-1);
2141       newdir[dirlen-1] = '\0';
2142       ret = chdir(newdir);
2143       PerlMem_free(newdir);
2144       return ret;
2145   }
2146   else return chdir(dir1);
2147 }  /* end of my_chdir */
2148 /*}}}*/
2149
2150
2151 /*{{{int my_chmod(char *, mode_t)*/
2152 int
2153 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2154 {
2155   Stat_t st;
2156   int ret = -1;
2157   char * changefile;
2158   STRLEN speclen = strlen(file_spec);
2159
2160   /* zero length string sometimes gives ACCVIO */
2161   if (speclen == 0) return -1;
2162
2163   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2164    * that implies null file name/type.  However, it's commonplace under Unix,
2165    * so we'll allow it for a gain in portability.
2166    *
2167    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2168    * in VMS file.dir notation.
2169    */
2170   changefile = (char *) file_spec; /* cast ok */
2171   ret = flex_lstat(file_spec, &st);
2172   if (ret != 0) {
2173
2174         /* Due to a historical feature, flex_stat/lstat can not see some */
2175         /* Unix format file names that the rest of the CRTL can see when */
2176         /* ODS-2 file specifications are in use. */
2177         /* Fixing that feature will cause some perl tests to fail */
2178         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2179         st.st_mode = 0;
2180
2181   } else {
2182       /* It may be possible to get here with nothing in st_devname */
2183       /* chmod still may work though */
2184       if (st.st_devnam[0] != 0) {
2185           changefile = st.st_devnam;
2186       }
2187   }
2188   ret = chmod(changefile, mode);
2189   return ret;
2190 }  /* end of my_chmod */
2191 /*}}}*/
2192
2193
2194 /*{{{FILE *my_tmpfile()*/
2195 FILE *
2196 my_tmpfile(void)
2197 {
2198   FILE *fp;
2199   char *cp;
2200
2201   if ((fp = tmpfile())) return fp;
2202
2203   cp = (char *)PerlMem_malloc(L_tmpnam+24);
2204   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2205
2206   if (decc_filename_unix_only == 0)
2207     strcpy(cp,"Sys$Scratch:");
2208   else
2209     strcpy(cp,"/tmp/");
2210   tmpnam(cp+strlen(cp));
2211   strcat(cp,".Perltmp");
2212   fp = fopen(cp,"w+","fop=dlt");
2213   PerlMem_free(cp);
2214   return fp;
2215 }
2216 /*}}}*/
2217
2218
2219 /*
2220  * The C RTL's sigaction fails to check for invalid signal numbers so we
2221  * help it out a bit.  The docs are correct, but the actual routine doesn't
2222  * do what the docs say it will.
2223  */
2224 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2225 int
2226 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2227                    struct sigaction* oact)
2228 {
2229   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2230         SETERRNO(EINVAL, SS$_INVARG);
2231         return -1;
2232   }
2233   return sigaction(sig, act, oact);
2234 }
2235 /*}}}*/
2236
2237 #ifdef KILL_BY_SIGPRC
2238 #include <errnodef.h>
2239
2240 /* We implement our own kill() using the undocumented system service
2241    sys$sigprc for one of two reasons:
2242
2243    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2244    target process to do a sys$exit, which usually can't be handled
2245    gracefully...certainly not by Perl and the %SIG{} mechanism.
2246
2247    2.) If the kill() in the CRTL can't be called from a signal
2248    handler without disappearing into the ether, i.e., the signal
2249    it purportedly sends is never trapped. Still true as of VMS 7.3.
2250
2251    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2252    in the target process rather than calling sys$exit.
2253
2254    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2255    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2256    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2257    with condition codes C$_SIG0+nsig*8, catching the exception on the
2258    target process and resignaling with appropriate arguments.
2259
2260    But we don't have that VMS 7.0+ exception handler, so if you
2261    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2262
2263    Also note that SIGTERM is listed in the docs as being "unimplemented",
2264    yet always seems to be signaled with a VMS condition code of 4 (and
2265    correctly handled for that code).  So we hardwire it in.
2266
2267    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2268    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2269    than signalling with an unrecognized (and unhandled by CRTL) code.
2270 */
2271
2272 #define _MY_SIG_MAX 28
2273
2274 static unsigned int
2275 Perl_sig_to_vmscondition_int(int sig)
2276 {
2277     static unsigned int sig_code[_MY_SIG_MAX+1] =
2278     {
2279         0,                  /*  0 ZERO     */
2280         SS$_HANGUP,         /*  1 SIGHUP   */
2281         SS$_CONTROLC,       /*  2 SIGINT   */
2282         SS$_CONTROLY,       /*  3 SIGQUIT  */
2283         SS$_RADRMOD,        /*  4 SIGILL   */
2284         SS$_BREAK,          /*  5 SIGTRAP  */
2285         SS$_OPCCUS,         /*  6 SIGABRT  */
2286         SS$_COMPAT,         /*  7 SIGEMT   */
2287 #ifdef __VAX
2288         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2289 #else
2290         SS$_HPARITH,        /*  8 SIGFPE AXP */
2291 #endif
2292         SS$_ABORT,          /*  9 SIGKILL  */
2293         SS$_ACCVIO,         /* 10 SIGBUS   */
2294         SS$_ACCVIO,         /* 11 SIGSEGV  */
2295         SS$_BADPARAM,       /* 12 SIGSYS   */
2296         SS$_NOMBX,          /* 13 SIGPIPE  */
2297         SS$_ASTFLT,         /* 14 SIGALRM  */
2298         4,                  /* 15 SIGTERM  */
2299         0,                  /* 16 SIGUSR1  */
2300         0,                  /* 17 SIGUSR2  */
2301         0,                  /* 18 */
2302         0,                  /* 19 */
2303         0,                  /* 20 SIGCHLD  */
2304         0,                  /* 21 SIGCONT  */
2305         0,                  /* 22 SIGSTOP  */
2306         0,                  /* 23 SIGTSTP  */
2307         0,                  /* 24 SIGTTIN  */
2308         0,                  /* 25 SIGTTOU  */
2309         0,                  /* 26 */
2310         0,                  /* 27 */
2311         0                   /* 28 SIGWINCH  */
2312     };
2313
2314     static int initted = 0;
2315     if (!initted) {
2316         initted = 1;
2317         sig_code[16] = C$_SIGUSR1;
2318         sig_code[17] = C$_SIGUSR2;
2319         sig_code[20] = C$_SIGCHLD;
2320 #if __CRTL_VER >= 70300000
2321         sig_code[28] = C$_SIGWINCH;
2322 #endif
2323     }
2324
2325     if (sig < _SIG_MIN) return 0;
2326     if (sig > _MY_SIG_MAX) return 0;
2327     return sig_code[sig];
2328 }
2329
2330 unsigned int
2331 Perl_sig_to_vmscondition(int sig)
2332 {
2333 #ifdef SS$_DEBUG
2334     if (vms_debug_on_exception != 0)
2335         lib$signal(SS$_DEBUG);
2336 #endif
2337     return Perl_sig_to_vmscondition_int(sig);
2338 }
2339
2340
2341 #define sys$sigprc SYS$SIGPRC
2342 #ifdef __cplusplus
2343 extern "C" {
2344 #endif
2345 int sys$sigprc(unsigned int *pidadr,
2346                struct dsc$descriptor_s *prcname,
2347                unsigned int code);
2348 #ifdef __cplusplus
2349 }
2350 #endif
2351
2352 int
2353 Perl_my_kill(int pid, int sig)
2354 {
2355     int iss;
2356     unsigned int code;
2357
2358      /* sig 0 means validate the PID */
2359     /*------------------------------*/
2360     if (sig == 0) {
2361         const unsigned long int jpicode = JPI$_PID;
2362         pid_t ret_pid;
2363         int status;
2364         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2365         if ($VMS_STATUS_SUCCESS(status))
2366            return 0;
2367         switch (status) {
2368         case SS$_NOSUCHNODE:
2369         case SS$_UNREACHABLE:
2370         case SS$_NONEXPR:
2371            errno = ESRCH;
2372            break;
2373         case SS$_NOPRIV:
2374            errno = EPERM;
2375            break;
2376         default:
2377            errno = EVMSERR;
2378         }
2379         vaxc$errno=status;
2380         return -1;
2381     }
2382
2383     code = Perl_sig_to_vmscondition_int(sig);
2384
2385     if (!code) {
2386         SETERRNO(EINVAL, SS$_BADPARAM);
2387         return -1;
2388     }
2389
2390     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2391      * signals are to be sent to multiple processes.
2392      *  pid = 0 - all processes in group except ones that the system exempts
2393      *  pid = -1 - all processes except ones that the system exempts
2394      *  pid = -n - all processes in group (abs(n)) except ...
2395      * For now, just report as not supported.
2396      */
2397
2398     if (pid <= 0) {
2399         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2400         return -1;
2401     }
2402
2403     iss = sys$sigprc((unsigned int *)&pid,0,code);
2404     if (iss&1) return 0;
2405
2406     switch (iss) {
2407       case SS$_NOPRIV:
2408         set_errno(EPERM);  break;
2409       case SS$_NONEXPR:
2410       case SS$_NOSUCHNODE:
2411       case SS$_UNREACHABLE:
2412         set_errno(ESRCH);  break;
2413       case SS$_INSFMEM:
2414         set_errno(ENOMEM); break;
2415       default:
2416         _ckvmssts_noperl(iss);
2417         set_errno(EVMSERR);
2418     }
2419     set_vaxc_errno(iss);
2420
2421     return -1;
2422 }
2423 #endif
2424
2425 /* Routine to convert a VMS status code to a UNIX status code.
2426 ** More tricky than it appears because of conflicting conventions with
2427 ** existing code.
2428 **
2429 ** VMS status codes are a bit mask, with the least significant bit set for
2430 ** success.
2431 **
2432 ** Special UNIX status of EVMSERR indicates that no translation is currently
2433 ** available, and programs should check the VMS status code.
2434 **
2435 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2436 ** decoding.
2437 */
2438
2439 #ifndef C_FACILITY_NO
2440 #define C_FACILITY_NO 0x350000
2441 #endif
2442 #ifndef DCL_IVVERB
2443 #define DCL_IVVERB 0x38090
2444 #endif
2445
2446 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2447 {
2448 int facility;
2449 int fac_sp;
2450 int msg_no;
2451 int msg_status;
2452 int unix_status;
2453
2454   /* Assume the best or the worst */
2455   if (vms_status & STS$M_SUCCESS)
2456     unix_status = 0;
2457   else
2458     unix_status = EVMSERR;
2459
2460   msg_status = vms_status & ~STS$M_CONTROL;
2461
2462   facility = vms_status & STS$M_FAC_NO;
2463   fac_sp = vms_status & STS$M_FAC_SP;
2464   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2465
2466   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2467     switch(msg_no) {
2468     case SS$_NORMAL:
2469         unix_status = 0;
2470         break;
2471     case SS$_ACCVIO:
2472         unix_status = EFAULT;
2473         break;
2474     case SS$_DEVOFFLINE:
2475         unix_status = EBUSY;
2476         break;
2477     case SS$_CLEARED:
2478         unix_status = ENOTCONN;
2479         break;
2480     case SS$_IVCHAN:
2481     case SS$_IVLOGNAM:
2482     case SS$_BADPARAM:
2483     case SS$_IVLOGTAB:
2484     case SS$_NOLOGNAM:
2485     case SS$_NOLOGTAB:
2486     case SS$_INVFILFOROP:
2487     case SS$_INVARG:
2488     case SS$_NOSUCHID:
2489     case SS$_IVIDENT:
2490         unix_status = EINVAL;
2491         break;
2492     case SS$_UNSUPPORTED:
2493         unix_status = ENOTSUP;
2494         break;
2495     case SS$_FILACCERR:
2496     case SS$_NOGRPPRV:
2497     case SS$_NOSYSPRV:
2498         unix_status = EACCES;
2499         break;
2500     case SS$_DEVICEFULL:
2501         unix_status = ENOSPC;
2502         break;
2503     case SS$_NOSUCHDEV:
2504         unix_status = ENODEV;
2505         break;
2506     case SS$_NOSUCHFILE:
2507     case SS$_NOSUCHOBJECT:
2508         unix_status = ENOENT;
2509         break;
2510     case SS$_ABORT:                                 /* Fatal case */
2511     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2512     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2513         unix_status = EINTR;
2514         break;
2515     case SS$_BUFFEROVF:
2516         unix_status = E2BIG;
2517         break;
2518     case SS$_INSFMEM:
2519         unix_status = ENOMEM;
2520         break;
2521     case SS$_NOPRIV:
2522         unix_status = EPERM;
2523         break;
2524     case SS$_NOSUCHNODE:
2525     case SS$_UNREACHABLE:
2526         unix_status = ESRCH;
2527         break;
2528     case SS$_NONEXPR:
2529         unix_status = ECHILD;
2530         break;
2531     default:
2532         if ((facility == 0) && (msg_no < 8)) {
2533           /* These are not real VMS status codes so assume that they are
2534           ** already UNIX status codes
2535           */
2536           unix_status = msg_no;
2537           break;
2538         }
2539     }
2540   }
2541   else {
2542     /* Translate a POSIX exit code to a UNIX exit code */
2543     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2544         unix_status = (msg_no & 0x07F8) >> 3;
2545     }
2546     else {
2547
2548          /* Documented traditional behavior for handling VMS child exits */
2549         /*--------------------------------------------------------------*/
2550         if (child_flag != 0) {
2551
2552              /* Success / Informational return 0 */
2553             /*----------------------------------*/
2554             if (msg_no & STS$K_SUCCESS)
2555                 return 0;
2556
2557              /* Warning returns 1 */
2558             /*-------------------*/
2559             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2560                 return 1;
2561
2562              /* Everything else pass through the severity bits */
2563             /*------------------------------------------------*/
2564             return (msg_no & STS$M_SEVERITY);
2565         }
2566
2567          /* Normal VMS status to ERRNO mapping attempt */
2568         /*--------------------------------------------*/
2569         switch(msg_status) {
2570         /* case RMS$_EOF: */ /* End of File */
2571         case RMS$_FNF:  /* File Not Found */
2572         case RMS$_DNF:  /* Dir Not Found */
2573                 unix_status = ENOENT;
2574                 break;
2575         case RMS$_RNF:  /* Record Not Found */
2576                 unix_status = ESRCH;
2577                 break;
2578         case RMS$_DIR:
2579                 unix_status = ENOTDIR;
2580                 break;
2581         case RMS$_DEV:
2582                 unix_status = ENODEV;
2583                 break;
2584         case RMS$_IFI:
2585         case RMS$_FAC:
2586         case RMS$_ISI:
2587                 unix_status = EBADF;
2588                 break;
2589         case RMS$_FEX:
2590                 unix_status = EEXIST;
2591                 break;
2592         case RMS$_SYN:
2593         case RMS$_FNM:
2594         case LIB$_INVSTRDES:
2595         case LIB$_INVARG:
2596         case LIB$_NOSUCHSYM:
2597         case LIB$_INVSYMNAM:
2598         case DCL_IVVERB:
2599                 unix_status = EINVAL;
2600                 break;
2601         case CLI$_BUFOVF:
2602         case RMS$_RTB:
2603         case CLI$_TKNOVF:
2604         case CLI$_RSLOVF:
2605                 unix_status = E2BIG;
2606                 break;
2607         case RMS$_PRV:  /* No privilege */
2608         case RMS$_ACC:  /* ACP file access failed */
2609         case RMS$_WLK:  /* Device write locked */
2610                 unix_status = EACCES;
2611                 break;
2612         case RMS$_MKD:  /* Failed to mark for delete */
2613                 unix_status = EPERM;
2614                 break;
2615         /* case RMS$_NMF: */  /* No more files */
2616         }
2617     }
2618   }
2619
2620   return unix_status;
2621 }
2622
2623 /* Try to guess at what VMS error status should go with a UNIX errno
2624  * value.  This is hard to do as there could be many possible VMS
2625  * error statuses that caused the errno value to be set.
2626  */
2627
2628 int Perl_unix_status_to_vms(int unix_status)
2629 {
2630 int test_unix_status;
2631
2632      /* Trivial cases first */
2633     /*---------------------*/
2634     if (unix_status == EVMSERR)
2635         return vaxc$errno;
2636
2637      /* Is vaxc$errno sane? */
2638     /*---------------------*/
2639     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2640     if (test_unix_status == unix_status)
2641         return vaxc$errno;
2642
2643      /* If way out of range, must be VMS code already */
2644     /*-----------------------------------------------*/
2645     if (unix_status > EVMSERR)
2646         return unix_status;
2647
2648      /* If out of range, punt */
2649     /*-----------------------*/
2650     if (unix_status > __ERRNO_MAX)
2651         return SS$_ABORT;
2652
2653
2654      /* Ok, now we have to do it the hard way. */
2655     /*----------------------------------------*/
2656     switch(unix_status) {
2657     case 0:     return SS$_NORMAL;
2658     case EPERM: return SS$_NOPRIV;
2659     case ENOENT: return SS$_NOSUCHOBJECT;
2660     case ESRCH: return SS$_UNREACHABLE;
2661     case EINTR: return SS$_ABORT;
2662     /* case EIO: */
2663     /* case ENXIO:  */
2664     case E2BIG: return SS$_BUFFEROVF;
2665     /* case ENOEXEC */
2666     case EBADF: return RMS$_IFI;
2667     case ECHILD: return SS$_NONEXPR;
2668     /* case EAGAIN */
2669     case ENOMEM: return SS$_INSFMEM;
2670     case EACCES: return SS$_FILACCERR;
2671     case EFAULT: return SS$_ACCVIO;
2672     /* case ENOTBLK */
2673     case EBUSY: return SS$_DEVOFFLINE;
2674     case EEXIST: return RMS$_FEX;
2675     /* case EXDEV */
2676     case ENODEV: return SS$_NOSUCHDEV;
2677     case ENOTDIR: return RMS$_DIR;
2678     /* case EISDIR */
2679     case EINVAL: return SS$_INVARG;
2680     /* case ENFILE */
2681     /* case EMFILE */
2682     /* case ENOTTY */
2683     /* case ETXTBSY */
2684     /* case EFBIG */
2685     case ENOSPC: return SS$_DEVICEFULL;
2686     case ESPIPE: return LIB$_INVARG;
2687     /* case EROFS: */
2688     /* case EMLINK: */
2689     /* case EPIPE: */
2690     /* case EDOM */
2691     case ERANGE: return LIB$_INVARG;
2692     /* case EWOULDBLOCK */
2693     /* case EINPROGRESS */
2694     /* case EALREADY */
2695     /* case ENOTSOCK */
2696     /* case EDESTADDRREQ */
2697     /* case EMSGSIZE */
2698     /* case EPROTOTYPE */
2699     /* case ENOPROTOOPT */
2700     /* case EPROTONOSUPPORT */
2701     /* case ESOCKTNOSUPPORT */
2702     /* case EOPNOTSUPP */
2703     /* case EPFNOSUPPORT */
2704     /* case EAFNOSUPPORT */
2705     /* case EADDRINUSE */
2706     /* case EADDRNOTAVAIL */
2707     /* case ENETDOWN */
2708     /* case ENETUNREACH */
2709     /* case ENETRESET */
2710     /* case ECONNABORTED */
2711     /* case ECONNRESET */
2712     /* case ENOBUFS */
2713     /* case EISCONN */
2714     case ENOTCONN: return SS$_CLEARED;
2715     /* case ESHUTDOWN */
2716     /* case ETOOMANYREFS */
2717     /* case ETIMEDOUT */
2718     /* case ECONNREFUSED */
2719     /* case ELOOP */
2720     /* case ENAMETOOLONG */
2721     /* case EHOSTDOWN */
2722     /* case EHOSTUNREACH */
2723     /* case ENOTEMPTY */
2724     /* case EPROCLIM */
2725     /* case EUSERS  */
2726     /* case EDQUOT  */
2727     /* case ENOMSG  */
2728     /* case EIDRM */
2729     /* case EALIGN */
2730     /* case ESTALE */
2731     /* case EREMOTE */
2732     /* case ENOLCK */
2733     /* case ENOSYS */
2734     /* case EFTYPE */
2735     /* case ECANCELED */
2736     /* case EFAIL */
2737     /* case EINPROG */
2738     case ENOTSUP:
2739         return SS$_UNSUPPORTED;
2740     /* case EDEADLK */
2741     /* case ENWAIT */
2742     /* case EILSEQ */
2743     /* case EBADCAT */
2744     /* case EBADMSG */
2745     /* case EABANDONED */
2746     default:
2747         return SS$_ABORT; /* punt */
2748     }
2749 }
2750
2751
2752 /* default piping mailbox size */
2753 #ifdef __VAX
2754 #  define PERL_BUFSIZ        512
2755 #else
2756 #  define PERL_BUFSIZ        8192
2757 #endif
2758
2759
2760 static void
2761 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2762 {
2763   unsigned long int mbxbufsiz;
2764   static unsigned long int syssize = 0;
2765   unsigned long int dviitm = DVI$_DEVNAM;
2766   char csize[LNM$C_NAMLENGTH+1];
2767   int sts;
2768
2769   if (!syssize) {
2770     unsigned long syiitm = SYI$_MAXBUF;
2771     /*
2772      * Get the SYSGEN parameter MAXBUF
2773      *
2774      * If the logical 'PERL_MBX_SIZE' is defined
2775      * use the value of the logical instead of PERL_BUFSIZ, but
2776      * keep the size between 128 and MAXBUF.
2777      *
2778      */
2779     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2780   }
2781
2782   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2783       mbxbufsiz = atoi(csize);
2784   } else {
2785       mbxbufsiz = PERL_BUFSIZ;
2786   }
2787   if (mbxbufsiz < 128) mbxbufsiz = 128;
2788   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2789
2790   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2791
2792   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2793   _ckvmssts_noperl(sts);
2794   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2795
2796 }  /* end of create_mbx() */
2797
2798
2799 /*{{{  my_popen and my_pclose*/
2800
2801 typedef struct _iosb           IOSB;
2802 typedef struct _iosb*         pIOSB;
2803 typedef struct _pipe           Pipe;
2804 typedef struct _pipe*         pPipe;
2805 typedef struct pipe_details    Info;
2806 typedef struct pipe_details*  pInfo;
2807 typedef struct _srqp            RQE;
2808 typedef struct _srqp*          pRQE;
2809 typedef struct _tochildbuf      CBuf;
2810 typedef struct _tochildbuf*    pCBuf;
2811
2812 struct _iosb {
2813     unsigned short status;
2814     unsigned short count;
2815     unsigned long  dvispec;
2816 };
2817
2818 #pragma member_alignment save
2819 #pragma nomember_alignment quadword
2820 struct _srqp {          /* VMS self-relative queue entry */
2821     unsigned long qptr[2];
2822 };
2823 #pragma member_alignment restore
2824 static RQE  RQE_ZERO = {0,0};
2825
2826 struct _tochildbuf {
2827     RQE             q;
2828     int             eof;
2829     unsigned short  size;
2830     char            *buf;
2831 };
2832
2833 struct _pipe {
2834     RQE            free;
2835     RQE            wait;
2836     int            fd_out;
2837     unsigned short chan_in;
2838     unsigned short chan_out;
2839     char          *buf;
2840     unsigned int   bufsize;
2841     IOSB           iosb;
2842     IOSB           iosb2;
2843     int           *pipe_done;
2844     int            retry;
2845     int            type;
2846     int            shut_on_empty;
2847     int            need_wake;
2848     pPipe         *home;
2849     pInfo          info;
2850     pCBuf          curr;
2851     pCBuf          curr2;
2852 #if defined(PERL_IMPLICIT_CONTEXT)
2853     void            *thx;           /* Either a thread or an interpreter */
2854                                     /* pointer, depending on how we're built */
2855 #endif
2856 };
2857
2858
2859 struct pipe_details
2860 {
2861     pInfo           next;
2862     PerlIO *fp;  /* file pointer to pipe mailbox */
2863     int useFILE; /* using stdio, not perlio */
2864     int pid;   /* PID of subprocess */
2865     int mode;  /* == 'r' if pipe open for reading */
2866     int done;  /* subprocess has completed */
2867     int waiting; /* waiting for completion/closure */
2868     int             closing;        /* my_pclose is closing this pipe */
2869     unsigned long   completion;     /* termination status of subprocess */
2870     pPipe           in;             /* pipe in to sub */
2871     pPipe           out;            /* pipe out of sub */
2872     pPipe           err;            /* pipe of sub's sys$error */
2873     int             in_done;        /* true when in pipe finished */
2874     int             out_done;
2875     int             err_done;
2876     unsigned short  xchan;          /* channel to debug xterm */
2877     unsigned short  xchan_valid;    /* channel is assigned */
2878 };
2879
2880 struct exit_control_block
2881 {
2882     struct exit_control_block *flink;
2883     unsigned long int (*exit_routine)(void);
2884     unsigned long int arg_count;
2885     unsigned long int *status_address;
2886     unsigned long int exit_status;
2887 };
2888
2889 typedef struct _closed_pipes    Xpipe;
2890 typedef struct _closed_pipes*  pXpipe;
2891
2892 struct _closed_pipes {
2893     int             pid;            /* PID of subprocess */
2894     unsigned long   completion;     /* termination status of subprocess */
2895 };
2896 #define NKEEPCLOSED 50
2897 static Xpipe closed_list[NKEEPCLOSED];
2898 static int   closed_index = 0;
2899 static int   closed_num = 0;
2900
2901 #define RETRY_DELAY     "0 ::0.20"
2902 #define MAX_RETRY              50
2903
2904 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2905 static unsigned long mypid;
2906 static unsigned long delaytime[2];
2907
2908 static pInfo open_pipes = NULL;
2909 static $DESCRIPTOR(nl_desc, "NL:");
2910
2911 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2912
2913
2914
2915 static unsigned long int
2916 pipe_exit_routine(void)
2917 {
2918     pInfo info;
2919     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2920     int sts, did_stuff, j;
2921
2922    /*
2923     * Flush any pending i/o, but since we are in process run-down, be
2924     * careful about referencing PerlIO structures that may already have
2925     * been deallocated.  We may not even have an interpreter anymore.
2926     */
2927     info = open_pipes;
2928     while (info) {
2929         if (info->fp) {
2930 #if defined(PERL_IMPLICIT_CONTEXT)
2931            /* We need to use the Perl context of the thread that created */
2932            /* the pipe. */
2933            pTHX;
2934            if (info->err)
2935                aTHX = info->err->thx;
2936            else if (info->out)
2937                aTHX = info->out->thx;
2938            else if (info->in)
2939                aTHX = info->in->thx;
2940 #endif
2941            if (!info->useFILE
2942 #if defined(USE_ITHREADS)
2943              && my_perl
2944 #endif
2945 #ifdef USE_PERLIO
2946              && PL_perlio_fd_refcnt
2947 #endif
2948               )
2949                PerlIO_flush(info->fp);
2950            else
2951                fflush((FILE *)info->fp);
2952         }
2953         info = info->next;
2954     }
2955
2956     /*
2957      next we try sending an EOF...ignore if doesn't work, make sure we
2958      don't hang
2959     */
2960     did_stuff = 0;
2961     info = open_pipes;
2962
2963     while (info) {
2964       _ckvmssts_noperl(sys$setast(0));
2965       if (info->in && !info->in->shut_on_empty) {
2966         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2967                                  0, 0, 0, 0, 0, 0));
2968         info->waiting = 1;
2969         did_stuff = 1;
2970       }
2971       _ckvmssts_noperl(sys$setast(1));
2972       info = info->next;
2973     }
2974
2975     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2976
2977     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2978         int nwait = 0;
2979
2980         info = open_pipes;
2981         while (info) {
2982           _ckvmssts_noperl(sys$setast(0));
2983           if (info->waiting && info->done)
2984                 info->waiting = 0;
2985           nwait += info->waiting;
2986           _ckvmssts_noperl(sys$setast(1));
2987           info = info->next;
2988         }
2989         if (!nwait) break;
2990         sleep(1);
2991     }
2992
2993     did_stuff = 0;
2994     info = open_pipes;
2995     while (info) {
2996       _ckvmssts_noperl(sys$setast(0));
2997       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2998         sts = sys$forcex(&info->pid,0,&abort);
2999         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3000         did_stuff = 1;
3001       }
3002       _ckvmssts_noperl(sys$setast(1));
3003       info = info->next;
3004     }
3005
3006     /* again, wait for effect */
3007
3008     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3009         int nwait = 0;
3010
3011         info = open_pipes;
3012         while (info) {
3013           _ckvmssts_noperl(sys$setast(0));
3014           if (info->waiting && info->done)
3015                 info->waiting = 0;
3016           nwait += info->waiting;
3017           _ckvmssts_noperl(sys$setast(1));
3018           info = info->next;
3019         }
3020         if (!nwait) break;
3021         sleep(1);
3022     }
3023
3024     info = open_pipes;
3025     while (info) {
3026       _ckvmssts_noperl(sys$setast(0));
3027       if (!info->done) {  /* We tried to be nice . . . */
3028         sts = sys$delprc(&info->pid,0);
3029         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3030         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3031       }
3032       _ckvmssts_noperl(sys$setast(1));
3033       info = info->next;
3034     }
3035
3036     while(open_pipes) {
3037
3038 #if defined(PERL_IMPLICIT_CONTEXT)
3039       /* We need to use the Perl context of the thread that created */
3040       /* the pipe. */
3041       pTHX;
3042       if (open_pipes->err)
3043           aTHX = open_pipes->err->thx;
3044       else if (open_pipes->out)
3045           aTHX = open_pipes->out->thx;
3046       else if (open_pipes->in)
3047           aTHX = open_pipes->in->thx;
3048 #endif
3049       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3050       else if (!(sts & 1)) retsts = sts;
3051     }
3052     return retsts;
3053 }
3054
3055 static struct exit_control_block pipe_exitblock =
3056        {(struct exit_control_block *) 0,
3057         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3058
3059 static void pipe_mbxtofd_ast(pPipe p);
3060 static void pipe_tochild1_ast(pPipe p);
3061 static void pipe_tochild2_ast(pPipe p);
3062
3063 static void
3064 popen_completion_ast(pInfo info)
3065 {
3066   pInfo i = open_pipes;
3067   int iss;
3068
3069   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3070   closed_list[closed_index].pid = info->pid;
3071   closed_list[closed_index].completion = info->completion;
3072   closed_index++;
3073   if (closed_index == NKEEPCLOSED)
3074     closed_index = 0;
3075   closed_num++;
3076
3077   while (i) {
3078     if (i == info) break;
3079     i = i->next;
3080   }
3081   if (!i) return;       /* unlinked, probably freed too */
3082
3083   info->done = TRUE;
3084
3085 /*
3086     Writing to subprocess ...
3087             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3088
3089             chan_out may be waiting for "done" flag, or hung waiting
3090             for i/o completion to child...cancel the i/o.  This will
3091             put it into "snarf mode" (done but no EOF yet) that discards
3092             input.
3093
3094     Output from subprocess (stdout, stderr) needs to be flushed and
3095     shut down.   We try sending an EOF, but if the mbx is full the pipe
3096     routine should still catch the "shut_on_empty" flag, telling it to
3097     use immediate-style reads so that "mbx empty" -> EOF.
3098
3099
3100 */
3101   if (info->in && !info->in_done) {               /* only for mode=w */
3102         if (info->in->shut_on_empty && info->in->need_wake) {
3103             info->in->need_wake = FALSE;
3104             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3105         } else {
3106             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3107         }
3108   }
3109
3110   if (info->out && !info->out_done) {             /* were we also piping output? */
3111       info->out->shut_on_empty = TRUE;
3112       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3113       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3114       _ckvmssts_noperl(iss);
3115   }
3116
3117   if (info->err && !info->err_done) {        /* we were piping stderr */
3118         info->err->shut_on_empty = TRUE;
3119         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3120         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3121         _ckvmssts_noperl(iss);
3122   }
3123   _ckvmssts_noperl(sys$setef(pipe_ef));
3124
3125 }
3126
3127 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3128 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3129 static void pipe_infromchild_ast(pPipe p);
3130
3131 /*
3132     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3133     inside an AST routine without worrying about reentrancy and which Perl
3134     memory allocator is being used.
3135
3136     We read data and queue up the buffers, then spit them out one at a
3137     time to the output mailbox when the output mailbox is ready for one.
3138
3139 */
3140 #define INITIAL_TOCHILDQUEUE  2
3141
3142 static pPipe
3143 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3144 {
3145     pPipe p;
3146     pCBuf b;
3147     char mbx1[64], mbx2[64];
3148     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3149                                       DSC$K_CLASS_S, mbx1},
3150                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3151                                       DSC$K_CLASS_S, mbx2};
3152     unsigned int dviitm = DVI$_DEVBUFSIZ;
3153     int j, n;
3154
3155     n = sizeof(Pipe);
3156     _ckvmssts_noperl(lib$get_vm(&n, &p));
3157
3158     create_mbx(&p->chan_in , &d_mbx1);
3159     create_mbx(&p->chan_out, &d_mbx2);
3160     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3161
3162     p->buf           = 0;
3163     p->shut_on_empty = FALSE;
3164     p->need_wake     = FALSE;
3165     p->type          = 0;
3166     p->retry         = 0;
3167     p->iosb.status   = SS$_NORMAL;
3168     p->iosb2.status  = SS$_NORMAL;
3169     p->free          = RQE_ZERO;
3170     p->wait          = RQE_ZERO;
3171     p->curr          = 0;
3172     p->curr2         = 0;
3173     p->info          = 0;
3174 #ifdef PERL_IMPLICIT_CONTEXT
3175     p->thx           = aTHX;
3176 #endif
3177
3178     n = sizeof(CBuf) + p->bufsize;
3179
3180     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3181         _ckvmssts_noperl(lib$get_vm(&n, &b));
3182         b->buf = (char *) b + sizeof(CBuf);
3183         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3184     }
3185
3186     pipe_tochild2_ast(p);
3187     pipe_tochild1_ast(p);
3188     strcpy(wmbx, mbx1);
3189     strcpy(rmbx, mbx2);
3190     return p;
3191 }
3192
3193 /*  reads the MBX Perl is writing, and queues */
3194
3195 static void
3196 pipe_tochild1_ast(pPipe p)
3197 {
3198     pCBuf b = p->curr;
3199     int iss = p->iosb.status;
3200     int eof = (iss == SS$_ENDOFFILE);
3201     int sts;
3202 #ifdef PERL_IMPLICIT_CONTEXT
3203     pTHX = p->thx;
3204 #endif
3205
3206     if (p->retry) {
3207         if (eof) {
3208             p->shut_on_empty = TRUE;
3209             b->eof     = TRUE;
3210             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3211         } else  {
3212             _ckvmssts_noperl(iss);
3213         }
3214
3215         b->eof  = eof;
3216         b->size = p->iosb.count;
3217         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3218         if (p->need_wake) {
3219             p->need_wake = FALSE;
3220             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3221         }
3222     } else {
3223         p->retry = 1;   /* initial call */
3224     }
3225
3226     if (eof) {                  /* flush the free queue, return when done */
3227         int n = sizeof(CBuf) + p->bufsize;
3228         while (1) {
3229             iss = lib$remqti(&p->free, &b);
3230             if (iss == LIB$_QUEWASEMP) return;
3231             _ckvmssts_noperl(iss);
3232             _ckvmssts_noperl(lib$free_vm(&n, &b));
3233         }
3234     }
3235
3236     iss = lib$remqti(&p->free, &b);
3237     if (iss == LIB$_QUEWASEMP) {
3238         int n = sizeof(CBuf) + p->bufsize;
3239         _ckvmssts_noperl(lib$get_vm(&n, &b));
3240         b->buf = (char *) b + sizeof(CBuf);
3241     } else {
3242        _ckvmssts_noperl(iss);
3243     }
3244
3245     p->curr = b;
3246     iss = sys$qio(0,p->chan_in,
3247              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3248              &p->iosb,
3249              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3250     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3251     _ckvmssts_noperl(iss);
3252 }
3253
3254
3255 /* writes queued buffers to output, waits for each to complete before
3256    doing the next */
3257
3258 static void
3259 pipe_tochild2_ast(pPipe p)
3260 {
3261     pCBuf b = p->curr2;
3262     int iss = p->iosb2.status;
3263     int n = sizeof(CBuf) + p->bufsize;
3264     int done = (p->info && p->info->done) ||
3265               iss == SS$_CANCEL || iss == SS$_ABORT;
3266 #if defined(PERL_IMPLICIT_CONTEXT)
3267     pTHX = p->thx;
3268 #endif
3269
3270     do {
3271         if (p->type) {         /* type=1 has old buffer, dispose */
3272             if (p->shut_on_empty) {
3273                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3274             } else {
3275                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3276             }
3277             p->type = 0;
3278         }
3279
3280         iss = lib$remqti(&p->wait, &b);
3281         if (iss == LIB$_QUEWASEMP) {
3282             if (p->shut_on_empty) {
3283                 if (done) {
3284                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3285                     *p->pipe_done = TRUE;
3286                     _ckvmssts_noperl(sys$setef(pipe_ef));
3287                 } else {
3288                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3289                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3290                 }
3291                 return;
3292             }
3293             p->need_wake = TRUE;
3294             return;
3295         }
3296         _ckvmssts_noperl(iss);
3297         p->type = 1;
3298     } while (done);
3299
3300
3301     p->curr2 = b;
3302     if (b->eof) {
3303         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3304             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3305     } else {
3306         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3307             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3308     }
3309
3310     return;
3311
3312 }
3313
3314
3315 static pPipe
3316 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3317 {
3318     pPipe p;
3319     char mbx1[64], mbx2[64];
3320     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3321                                       DSC$K_CLASS_S, mbx1},
3322                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3323                                       DSC$K_CLASS_S, mbx2};
3324     unsigned int dviitm = DVI$_DEVBUFSIZ;
3325
3326     int n = sizeof(Pipe);
3327     _ckvmssts_noperl(lib$get_vm(&n, &p));
3328     create_mbx(&p->chan_in , &d_mbx1);
3329     create_mbx(&p->chan_out, &d_mbx2);
3330
3331     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3332     n = p->bufsize * sizeof(char);
3333     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3334     p->shut_on_empty = FALSE;
3335     p->info   = 0;
3336     p->type   = 0;
3337     p->iosb.status = SS$_NORMAL;
3338 #if defined(PERL_IMPLICIT_CONTEXT)
3339     p->thx = aTHX;
3340 #endif
3341     pipe_infromchild_ast(p);
3342
3343     strcpy(wmbx, mbx1);
3344     strcpy(rmbx, mbx2);
3345     return p;
3346 }
3347
3348 static void
3349 pipe_infromchild_ast(pPipe p)
3350 {
3351     int iss = p->iosb.status;
3352     int eof = (iss == SS$_ENDOFFILE);
3353     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3354     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3355 #if defined(PERL_IMPLICIT_CONTEXT)
3356     pTHX = p->thx;
3357 #endif
3358
3359     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3360         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3361         p->chan_out = 0;
3362     }
3363
3364     /* read completed:
3365             input shutdown if EOF from self (done or shut_on_empty)
3366             output shutdown if closing flag set (my_pclose)
3367             send data/eof from child or eof from self
3368             otherwise, re-read (snarf of data from child)
3369     */
3370
3371     if (p->type == 1) {
3372         p->type = 0;
3373         if (myeof && p->chan_in) {                  /* input shutdown */
3374             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3375             p->chan_in = 0;
3376         }
3377
3378         if (p->chan_out) {
3379             if (myeof || kideof) {      /* pass EOF to parent */
3380                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3381                                          pipe_infromchild_ast, p,
3382                                          0, 0, 0, 0, 0, 0));
3383                 return;
3384             } else if (eof) {       /* eat EOF --- fall through to read*/
3385
3386             } else {                /* transmit data */
3387                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3388                                          pipe_infromchild_ast,p,
3389                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3390                 return;
3391             }
3392         }
3393     }
3394
3395     /*  everything shut? flag as done */
3396
3397     if (!p->chan_in && !p->chan_out) {
3398         *p->pipe_done = TRUE;
3399         _ckvmssts_noperl(sys$setef(pipe_ef));
3400         return;
3401     }
3402
3403     /* write completed (or read, if snarfing from child)
3404             if still have input active,
3405                queue read...immediate mode if shut_on_empty so we get EOF if empty
3406             otherwise,
3407                check if Perl reading, generate EOFs as needed
3408     */
3409
3410     if (p->type == 0) {
3411         p->type = 1;
3412         if (p->chan_in) {
3413             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3414                           pipe_infromchild_ast,p,
3415                           p->buf, p->bufsize, 0, 0, 0, 0);
3416             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3417             _ckvmssts_noperl(iss);
3418         } else {           /* send EOFs for extra reads */
3419             p->iosb.status = SS$_ENDOFFILE;
3420             p->iosb.dvispec = 0;
3421             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3422                                      0, 0, 0,
3423                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3424         }
3425     }
3426 }
3427
3428 static pPipe
3429 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3430 {
3431     pPipe p;
3432     char mbx[64];
3433     unsigned long dviitm = DVI$_DEVBUFSIZ;
3434     struct stat s;
3435     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3436                                       DSC$K_CLASS_S, mbx};
3437     int n = sizeof(Pipe);
3438
3439     /* things like terminals and mbx's don't need this filter */
3440     if (fd && fstat(fd,&s) == 0) {
3441         unsigned long devchar;
3442         char device[65];
3443         unsigned short dev_len;
3444         struct dsc$descriptor_s d_dev;
3445         char * cptr;
3446         struct item_list_3 items[3];
3447         int status;
3448         unsigned short dvi_iosb[4];
3449
3450         cptr = getname(fd, out, 1);
3451         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3452         d_dev.dsc$a_pointer = out;
3453         d_dev.dsc$w_length = strlen(out);
3454         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3455         d_dev.dsc$b_class = DSC$K_CLASS_S;
3456
3457         items[0].len = 4;
3458         items[0].code = DVI$_DEVCHAR;
3459         items[0].bufadr = &devchar;
3460         items[0].retadr = NULL;
3461         items[1].len = 64;
3462         items[1].code = DVI$_FULLDEVNAM;
3463         items[1].bufadr = device;
3464         items[1].retadr = &dev_len;
3465         items[2].len = 0;
3466         items[2].code = 0;
3467
3468         status = sys$getdviw
3469                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3470         _ckvmssts_noperl(status);
3471         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3472             device[dev_len] = 0;
3473
3474             if (!(devchar & DEV$M_DIR)) {
3475                 strcpy(out, device);
3476                 return 0;
3477             }
3478         }
3479     }
3480
3481     _ckvmssts_noperl(lib$get_vm(&n, &p));
3482     p->fd_out = dup(fd);
3483     create_mbx(&p->chan_in, &d_mbx);
3484     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3485     n = (p->bufsize+1) * sizeof(char);
3486     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3487     p->shut_on_empty = FALSE;
3488     p->retry = 0;
3489     p->info  = 0;
3490     strcpy(out, mbx);
3491
3492     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3493                              pipe_mbxtofd_ast, p,
3494                              p->buf, p->bufsize, 0, 0, 0, 0));
3495
3496     return p;
3497 }
3498
3499 static void
3500 pipe_mbxtofd_ast(pPipe p)
3501 {
3502     int iss = p->iosb.status;
3503     int done = p->info->done;
3504     int iss2;
3505     int eof = (iss == SS$_ENDOFFILE);
3506     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3507     int err = !(iss&1) && !eof;
3508 #if defined(PERL_IMPLICIT_CONTEXT)
3509     pTHX = p->thx;
3510 #endif
3511
3512     if (done && myeof) {               /* end piping */
3513         close(p->fd_out);
3514         sys$dassgn(p->chan_in);
3515         *p->pipe_done = TRUE;
3516         _ckvmssts_noperl(sys$setef(pipe_ef));
3517         return;
3518     }
3519
3520     if (!err && !eof) {             /* good data to send to file */
3521         p->buf[p->iosb.count] = '\n';
3522         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3523         if (iss2 < 0) {
3524             p->retry++;
3525             if (p->retry < MAX_RETRY) {
3526                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3527                 return;
3528             }
3529         }
3530         p->retry = 0;
3531     } else if (err) {
3532         _ckvmssts_noperl(iss);
3533     }
3534
3535
3536     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3537           pipe_mbxtofd_ast, p,
3538           p->buf, p->bufsize, 0, 0, 0, 0);
3539     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3540     _ckvmssts_noperl(iss);
3541 }
3542
3543
3544 typedef struct _pipeloc     PLOC;
3545 typedef struct _pipeloc*   pPLOC;
3546
3547 struct _pipeloc {
3548     pPLOC   next;
3549     char    dir[NAM$C_MAXRSS+1];
3550 };
3551 static pPLOC  head_PLOC = 0;
3552
3553 void
3554 free_pipelocs(pTHX_ void *head)
3555 {
3556     pPLOC p, pnext;
3557     pPLOC *pHead = (pPLOC *)head;
3558
3559     p = *pHead;
3560     while (p) {
3561         pnext = p->next;
3562         PerlMem_free(p);
3563         p = pnext;
3564     }
3565     *pHead = 0;
3566 }
3567
3568 static void
3569 store_pipelocs(pTHX)
3570 {
3571     int    i;
3572     pPLOC  p;
3573     AV    *av = 0;
3574     SV    *dirsv;
3575     char  *dir, *x;
3576     char  *unixdir;
3577     char  temp[NAM$C_MAXRSS+1];
3578     STRLEN n_a;
3579
3580     if (head_PLOC)
3581         free_pipelocs(aTHX_ &head_PLOC);
3582
3583 /*  the . directory from @INC comes last */
3584
3585     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3586     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3587     p->next = head_PLOC;
3588     head_PLOC = p;
3589     strcpy(p->dir,"./");
3590
3591 /*  get the directory from $^X */
3592
3593     unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3594     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3595
3596 #ifdef PERL_IMPLICIT_CONTEXT
3597     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3598 #else
3599     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3600 #endif
3601         my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3602         x = strrchr(temp,']');
3603         if (x == NULL) {
3604         x = strrchr(temp,'>');
3605           if (x == NULL) {
3606             /* It could be a UNIX path */
3607             x = strrchr(temp,'/');
3608           }
3609         }
3610         if (x)
3611           x[1] = '\0';
3612         else {
3613           /* Got a bare name, so use default directory */
3614           temp[0] = '.';
3615           temp[1] = '\0';
3616         }
3617
3618         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3619             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3620             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3621             p->next = head_PLOC;
3622             head_PLOC = p;
3623             my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3624         }
3625     }
3626
3627 /*  reverse order of @INC entries, skip "." since entered above */
3628
3629 #ifdef PERL_IMPLICIT_CONTEXT
3630     if (aTHX)
3631 #endif
3632     if (PL_incgv) av = GvAVn(PL_incgv);
3633
3634     for (i = 0; av && i <= AvFILL(av); i++) {
3635         dirsv = *av_fetch(av,i,TRUE);
3636
3637         if (SvROK(dirsv)) continue;
3638         dir = SvPVx(dirsv,n_a);
3639         if (strcmp(dir,".") == 0) continue;
3640         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3641             continue;
3642
3643         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3644         p->next = head_PLOC;
3645         head_PLOC = p;
3646         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3647     }
3648
3649 /* most likely spot (ARCHLIB) put first in the list */
3650
3651 #ifdef ARCHLIB_EXP
3652     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3653         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3654         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3655         p->next = head_PLOC;
3656         head_PLOC = p;
3657         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3658     }
3659 #endif
3660     PerlMem_free(unixdir);
3661 }
3662
3663 static I32
3664 Perl_cando_by_name_int
3665    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3666 #if !defined(PERL_IMPLICIT_CONTEXT)
3667 #define cando_by_name_int               Perl_cando_by_name_int
3668 #else
3669 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3670 #endif
3671
3672 static char *
3673 find_vmspipe(pTHX)
3674 {
3675     static int   vmspipe_file_status = 0;
3676     static char  vmspipe_file[NAM$C_MAXRSS+1];
3677
3678     /* already found? Check and use ... need read+execute permission */
3679
3680     if (vmspipe_file_status == 1) {
3681         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3682          && cando_by_name_int
3683            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3684             return vmspipe_file;
3685         }
3686         vmspipe_file_status = 0;
3687     }
3688
3689     /* scan through stored @INC, $^X */
3690
3691     if (vmspipe_file_status == 0) {
3692         char file[NAM$C_MAXRSS+1];
3693         pPLOC  p = head_PLOC;
3694
3695         while (p) {
3696             char * exp_res;
3697             int dirlen;
3698             dirlen = my_strlcpy(file, p->dir, sizeof(file));
3699             my_strlcat(file, "vmspipe.com", sizeof(file));
3700             p = p->next;
3701
3702             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3703             if (!exp_res) continue;
3704
3705             if (cando_by_name_int
3706                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3707              && cando_by_name_int
3708                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3709                 vmspipe_file_status = 1;
3710                 return vmspipe_file;
3711             }
3712         }
3713         vmspipe_file_status = -1;   /* failed, use tempfiles */
3714     }
3715
3716     return 0;
3717 }
3718
3719 static FILE *
3720 vmspipe_tempfile(pTHX)
3721 {
3722     char file[NAM$C_MAXRSS+1];
3723     FILE *fp;
3724     static int index = 0;
3725     Stat_t s0, s1;
3726     int cmp_result;
3727
3728     /* create a tempfile */
3729
3730     /* we can't go from   W, shr=get to  R, shr=get without
3731        an intermediate vulnerable state, so don't bother trying...
3732
3733        and lib$spawn doesn't shr=put, so have to close the write
3734
3735        So... match up the creation date/time and the FID to
3736        make sure we're dealing with the same file
3737
3738     */
3739
3740     index++;
3741     if (!decc_filename_unix_only) {
3742       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3743       fp = fopen(file,"w");
3744       if (!fp) {
3745         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3746         fp = fopen(file,"w");
3747         if (!fp) {
3748             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3749             fp = fopen(file,"w");
3750         }
3751       }
3752      }
3753      else {
3754       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3755       fp = fopen(file,"w");
3756       if (!fp) {
3757         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3758         fp = fopen(file,"w");
3759         if (!fp) {
3760           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3761           fp = fopen(file,"w");
3762         }
3763       }
3764     }
3765     if (!fp) return 0;  /* we're hosed */
3766
3767     fprintf(fp,"$! 'f$verify(0)'\n");
3768     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3769     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3770     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3771     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3772     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3773     fprintf(fp,"$ perl_del    = \"delete\"\n");
3774     fprintf(fp,"$ pif         = \"if\"\n");
3775     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3776     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3777     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3778     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3779     fprintf(fp,"$!  --- build command line to get max possible length\n");
3780     fprintf(fp,"$c=perl_popen_cmd0\n");
3781     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3782     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3783     fprintf(fp,"$x=perl_popen_cmd3\n");
3784     fprintf(fp,"$c=c+x\n");
3785     fprintf(fp,"$ perl_on\n");
3786     fprintf(fp,"$ 'c'\n");
3787     fprintf(fp,"$ perl_status = $STATUS\n");
3788     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3789     fprintf(fp,"$ perl_exit 'perl_status'\n");
3790     fsync(fileno(fp));
3791
3792     fgetname(fp, file, 1);
3793     fstat(fileno(fp), &s0.crtl_stat);
3794     fclose(fp);
3795
3796     if (decc_filename_unix_only)
3797         int_tounixspec(file, file, NULL);
3798     fp = fopen(file,"r","shr=get");
3799     if (!fp) return 0;
3800     fstat(fileno(fp), &s1.crtl_stat);
3801
3802     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3803     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3804         fclose(fp);
3805         return 0;
3806     }
3807
3808     return fp;
3809 }
3810
3811
3812 static int vms_is_syscommand_xterm(void)
3813 {
3814     const static struct dsc$descriptor_s syscommand_dsc =
3815       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3816
3817     const static struct dsc$descriptor_s decwdisplay_dsc =
3818       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3819
3820     struct item_list_3 items[2];
3821     unsigned short dvi_iosb[4];
3822     unsigned long devchar;
3823     unsigned long devclass;
3824     int status;
3825
3826     /* Very simple check to guess if sys$command is a decterm? */
3827     /* First see if the DECW$DISPLAY: device exists */
3828     items[0].len = 4;
3829     items[0].code = DVI$_DEVCHAR;
3830     items[0].bufadr = &devchar;
3831     items[0].retadr = NULL;
3832     items[1].len = 0;
3833     items[1].code = 0;
3834
3835     status = sys$getdviw
3836         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3837
3838     if ($VMS_STATUS_SUCCESS(status)) {
3839         status = dvi_iosb[0];
3840     }
3841
3842     if (!$VMS_STATUS_SUCCESS(status)) {
3843         SETERRNO(EVMSERR, status);
3844         return -1;
3845     }
3846
3847     /* If it does, then for now assume that we are on a workstation */
3848     /* Now verify that SYS$COMMAND is a terminal */
3849     /* for creating the debugger DECTerm */
3850
3851     items[0].len = 4;
3852     items[0].code = DVI$_DEVCLASS;
3853     items[0].bufadr = &devclass;
3854     items[0].retadr = NULL;
3855     items[1].len = 0;
3856     items[1].code = 0;
3857
3858     status = sys$getdviw
3859         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3860
3861     if ($VMS_STATUS_SUCCESS(status)) {
3862         status = dvi_iosb[0];
3863     }
3864
3865     if (!$VMS_STATUS_SUCCESS(status)) {
3866         SETERRNO(EVMSERR, status);
3867         return -1;
3868     }
3869     else {
3870         if (devclass == DC$_TERM) {
3871             return 0;
3872         }
3873     }
3874     return -1;
3875 }
3876
3877 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3878 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3879 {
3880     int status;
3881     int ret_stat;
3882     char * ret_char;
3883     char device_name[65];
3884     unsigned short device_name_len;
3885     struct dsc$descriptor_s customization_dsc;
3886     struct dsc$descriptor_s device_name_dsc;
3887     const char * cptr;
3888     char customization[200];
3889     char title[40];
3890     pInfo info = NULL;
3891     char mbx1[64];
3892     unsigned short p_chan;
3893     int n;
3894     unsigned short iosb[4];
3895     const char * cust_str =
3896         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3897     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3898                                           DSC$K_CLASS_S, mbx1};
3899
3900      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3901     /*---------------------------------------*/
3902     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3903
3904
3905     /* Make sure that this is from the Perl debugger */
3906     ret_char = strstr(cmd," xterm ");
3907     if (ret_char == NULL)
3908         return NULL;
3909     cptr = ret_char + 7;
3910     ret_char = strstr(cmd,"tty");
3911     if (ret_char == NULL)
3912         return NULL;
3913     ret_char = strstr(cmd,"sleep");
3914     if (ret_char == NULL)
3915         return NULL;
3916
3917     if (decw_term_port == 0) {
3918         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3919         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3920         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3921
3922        status = lib$find_image_symbol
3923                                (&filename1_dsc,
3924                                 &decw_term_port_dsc,
3925                                 (void *)&decw_term_port,
3926                                 NULL,
3927                                 0);
3928
3929         /* Try again with the other image name */
3930         if (!$VMS_STATUS_SUCCESS(status)) {
3931
3932            status = lib$find_image_symbol
3933                                (&filename2_dsc,
3934                                 &decw_term_port_dsc,
3935                                 (void *)&decw_term_port,
3936                                 NULL,
3937                                 0);
3938
3939         }
3940
3941     }
3942
3943
3944     /* No decw$term_port, give it up */
3945     if (!$VMS_STATUS_SUCCESS(status))
3946         return NULL;
3947
3948     /* Are we on a workstation? */
3949     /* to do: capture the rows / columns and pass their properties */
3950     ret_stat = vms_is_syscommand_xterm();
3951     if (ret_stat < 0)
3952         return NULL;
3953
3954     /* Make the title: */
3955     ret_char = strstr(cptr,"-title");
3956     if (ret_char != NULL) {
3957         while ((*cptr != 0) && (*cptr != '\"')) {
3958             cptr++;
3959         }
3960         if (*cptr == '\"')
3961             cptr++;
3962         n = 0;
3963         while ((*cptr != 0) && (*cptr != '\"')) {
3964             title[n] = *cptr;
3965             n++;
3966             if (n == 39) {
3967                 title[39] = 0;
3968                 break;
3969             }
3970             cptr++;
3971         }
3972         title[n] = 0;
3973     }
3974     else {
3975             /* Default title */
3976             strcpy(title,"Perl Debug DECTerm");
3977     }
3978     sprintf(customization, cust_str, title);
3979
3980     customization_dsc.dsc$a_pointer = customization;
3981     customization_dsc.dsc$w_length = strlen(customization);
3982     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3983     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3984
3985     device_name_dsc.dsc$a_pointer = device_name;
3986     device_name_dsc.dsc$w_length = sizeof device_name -1;
3987     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3988     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3989
3990     device_name_len = 0;
3991
3992     /* Try to create the window */
3993      status = (*decw_term_port)
3994        (NULL,
3995         NULL,
3996         &customization_dsc,
3997         &device_name_dsc,
3998         &device_name_len,
3999         NULL,
4000         NULL,
4001         NULL);
4002     if (!$VMS_STATUS_SUCCESS(status)) {
4003         SETERRNO(EVMSERR, status);
4004         return NULL;
4005     }
4006
4007     device_name[device_name_len] = '\0';
4008
4009     /* Need to set this up to look like a pipe for cleanup */
4010     n = sizeof(Info);
4011     status = lib$get_vm(&n, &info);
4012     if (!$VMS_STATUS_SUCCESS(status)) {
4013         SETERRNO(ENOMEM, status);
4014         return NULL;
4015     }
4016
4017     info->mode = *mode;
4018     info->done = FALSE;
4019     info->completion = 0;
4020     info->closing    = FALSE;
4021     info->in         = 0;
4022     info->out        = 0;
4023     info->err        = 0;
4024     info->fp         = NULL;
4025     info->useFILE    = 0;
4026     info->waiting    = 0;
4027     info->in_done    = TRUE;
4028     info->out_done   = TRUE;
4029     info->err_done   = TRUE;
4030
4031     /* Assign a channel on this so that it will persist, and not login */
4032     /* We stash this channel in the info structure for reference. */
4033     /* The created xterm self destructs when the last channel is removed */
4034     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4035     /* So leave this assigned. */
4036     device_name_dsc.dsc$w_length = device_name_len;
4037     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4038     if (!$VMS_STATUS_SUCCESS(status)) {
4039         SETERRNO(EVMSERR, status);
4040         return NULL;
4041     }
4042     info->xchan_valid = 1;
4043
4044     /* Now create a mailbox to be read by the application */
4045
4046     create_mbx(&p_chan, &d_mbx1);
4047
4048     /* write the name of the created terminal to the mailbox */
4049     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4050             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4051
4052     if (!$VMS_STATUS_SUCCESS(status)) {
4053         SETERRNO(EVMSERR, status);
4054         return NULL;
4055     }
4056
4057     info->fp  = PerlIO_open(mbx1, mode);
4058
4059     /* Done with this channel */
4060     sys$dassgn(p_chan);
4061
4062     /* If any errors, then clean up */
4063     if (!info->fp) {
4064         n = sizeof(Info);
4065         _ckvmssts_noperl(lib$free_vm(&n, &info));
4066         return NULL;
4067         }
4068
4069     /* All done */
4070     return info->fp;
4071 }
4072
4073 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4074
4075 static PerlIO *
4076 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4077 {
4078     static int handler_set_up = FALSE;
4079     PerlIO * ret_fp;
4080     unsigned long int sts, flags = CLI$M_NOWAIT;
4081     /* The use of a GLOBAL table (as was done previously) rendered
4082      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4083      * environment.  Hence we've switched to LOCAL symbol table.
4084      */
4085     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4086     int j, wait = 0, n;
4087     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4088     char *in, *out, *err, mbx[512];
4089     FILE *tpipe = 0;
4090     char tfilebuf[NAM$C_MAXRSS+1];
4091     pInfo info = NULL;
4092     char cmd_sym_name[20];
4093     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4094                                       DSC$K_CLASS_S, symbol};
4095     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4096                                       DSC$K_CLASS_S, 0};
4097     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4098                                       DSC$K_CLASS_S, cmd_sym_name};
4099     struct dsc$descriptor_s *vmscmd;
4100     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4101     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4102     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4103
4104     /* Check here for Xterm create request.  This means looking for
4105      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4106      *  is possible to create an xterm.
4107      */
4108     if (*in_mode == 'r') {
4109         PerlIO * xterm_fd;
4110
4111 #if defined(PERL_IMPLICIT_CONTEXT)
4112         /* Can not fork an xterm with a NULL context */
4113         /* This probably could never happen */
4114         xterm_fd = NULL;
4115         if (aTHX != NULL)
4116 #endif
4117         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4118         if (xterm_fd != NULL)
4119             return xterm_fd;
4120     }
4121
4122     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4123
4124     /* once-per-program initialization...
4125        note that the SETAST calls and the dual test of pipe_ef
4126        makes sure that only the FIRST thread through here does
4127        the initialization...all other threads wait until it's
4128        done.
4129
4130        Yeah, uglier than a pthread call, it's got all the stuff inline
4131        rather than in a separate routine.
4132     */
4133
4134     if (!pipe_ef) {
4135         _ckvmssts_noperl(sys$setast(0));
4136         if (!pipe_ef) {
4137             unsigned long int pidcode = JPI$_PID;
4138             $DESCRIPTOR(d_delay, RETRY_DELAY);
4139             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4140             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4141             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4142         }
4143         if (!handler_set_up) {
4144           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4145           handler_set_up = TRUE;
4146         }
4147         _ckvmssts_noperl(sys$setast(1));
4148     }
4149
4150     /* see if we can find a VMSPIPE.COM */
4151
4152     tfilebuf[0] = '@';
4153     vmspipe = find_vmspipe(aTHX);
4154     if (vmspipe) {
4155         vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4156     } else {        /* uh, oh...we're in tempfile hell */
4157         tpipe = vmspipe_tempfile(aTHX);
4158         if (!tpipe) {       /* a fish popular in Boston */
4159             if (ckWARN(WARN_PIPE)) {
4160                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4161             }
4162         return NULL;
4163         }
4164         fgetname(tpipe,tfilebuf+1,1);
4165         vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4166     }
4167     vmspipedsc.dsc$a_pointer = tfilebuf;
4168
4169     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4170     if (!(sts & 1)) {
4171       switch (sts) {
4172         case RMS$_FNF:  case RMS$_DNF:
4173           set_errno(ENOENT); break;
4174         case RMS$_DIR:
4175           set_errno(ENOTDIR); break;
4176         case RMS$_DEV:
4177           set_errno(ENODEV); break;
4178         case RMS$_PRV:
4179           set_errno(EACCES); break;
4180         case RMS$_SYN:
4181           set_errno(EINVAL); break;
4182         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4183           set_errno(E2BIG); break;
4184         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4185           _ckvmssts_noperl(sts); /* fall through */
4186         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4187           set_errno(EVMSERR);
4188       }
4189       set_vaxc_errno(sts);
4190       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4191         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4192       }
4193       *psts = sts;
4194       return NULL;
4195     }
4196     n = sizeof(Info);
4197     _ckvmssts_noperl(lib$get_vm(&n, &info));
4198
4199     my_strlcpy(mode, in_mode, sizeof(mode));
4200     info->mode = *mode;
4201     info->done = FALSE;
4202     info->completion = 0;
4203     info->closing    = FALSE;
4204     info->in         = 0;
4205     info->out        = 0;
4206     info->err        = 0;
4207     info->fp         = NULL;
4208     info->useFILE    = 0;
4209     info->waiting    = 0;
4210     info->in_done    = TRUE;
4211     info->out_done   = TRUE;
4212     info->err_done   = TRUE;
4213     info->xchan      = 0;
4214     info->xchan_valid = 0;
4215
4216     in = (char *)PerlMem_malloc(VMS_MAXRSS);
4217     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4218     out = (char *)PerlMem_malloc(VMS_MAXRSS);
4219     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4220     err = (char *)PerlMem_malloc(VMS_MAXRSS);
4221     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4222
4223     in[0] = out[0] = err[0] = '\0';
4224
4225     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4226         info->useFILE = 1;
4227         strcpy(p,p+1);
4228     }
4229     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4230         wait = 1;
4231         strcpy(p,p+1);
4232     }
4233
4234     if (*mode == 'r') {             /* piping from subroutine */
4235
4236         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4237         if (info->out) {
4238             info->out->pipe_done = &info->out_done;
4239             info->out_done = FALSE;
4240             info->out->info = info;
4241         }
4242         if (!info->useFILE) {
4243             info->fp  = PerlIO_open(mbx, mode);
4244         } else {
4245             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4246             vmssetuserlnm("SYS$INPUT", mbx);
4247         }
4248
4249         if (!info->fp && info->out) {
4250             sys$cancel(info->out->chan_out);
4251
4252             while (!info->out_done) {
4253                 int done;
4254                 _ckvmssts_noperl(sys$setast(0));
4255                 done = info->out_done;
4256                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4257                 _ckvmssts_noperl(sys$setast(1));
4258                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4259             }
4260
4261             if (info->out->buf) {
4262                 n = info->out->bufsize * sizeof(char);
4263                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4264             }
4265             n = sizeof(Pipe);
4266             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4267             n = sizeof(Info);
4268             _ckvmssts_noperl(lib$free_vm(&n, &info));
4269             *psts = RMS$_FNF;
4270             return NULL;
4271         }
4272
4273         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4274         if (info->err) {
4275             info->err->pipe_done = &info->err_done;
4276             info->err_done = FALSE;
4277             info->err->info = info;
4278         }
4279
4280     } else if (*mode == 'w') {      /* piping to subroutine */
4281
4282         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4283         if (info->out) {
4284             info->out->pipe_done = &info->out_done;
4285             info->out_done = FALSE;
4286             info->out->info = info;
4287         }
4288
4289         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4290         if (info->err) {
4291             info->err->pipe_done = &info->err_done;
4292             info->err_done = FALSE;
4293             info->err->info = info;
4294         }
4295
4296         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4297         if (!info->useFILE) {
4298             info->fp  = PerlIO_open(mbx, mode);
4299         } else {
4300             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4301             vmssetuserlnm("SYS$OUTPUT", mbx);
4302         }
4303
4304         if (info->in) {
4305             info->in->pipe_done = &info->in_done;
4306             info->in_done = FALSE;
4307             info->in->info = info;
4308         }
4309
4310         /* error cleanup */
4311         if (!info->fp && info->in) {
4312             info->done = TRUE;
4313             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4314                                       0, 0, 0, 0, 0, 0, 0, 0));
4315
4316             while (!info->in_done) {
4317                 int done;
4318                 _ckvmssts_noperl(sys$setast(0));
4319                 done = info->in_done;
4320                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4321                 _ckvmssts_noperl(sys$setast(1));
4322                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4323             }
4324
4325             if (info->in->buf) {
4326                 n = info->in->bufsize * sizeof(char);
4327                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4328             }
4329             n = sizeof(Pipe);
4330             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4331             n = sizeof(Info);
4332             _ckvmssts_noperl(lib$free_vm(&n, &info));
4333             *psts = RMS$_FNF;
4334             return NULL;
4335         }
4336
4337
4338     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4339         /* Let the child inherit standard input, unless it's a directory. */
4340         Stat_t st;
4341         if (my_trnlnm("SYS$INPUT", in, 0)) {
4342             if (flex_stat(in, &st) != 0 || S_ISDIR(st.st_mode))
4343                 *in = '\0';
4344         }
4345
4346         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4347         if (info->out) {
4348             info->out->pipe_done = &info->out_done;
4349             info->out_done = FALSE;
4350             info->out->info = info;
4351         }
4352
4353         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4354         if (info->err) {
4355             info->err->pipe_done = &info->err_done;
4356             info->err_done = FALSE;
4357             info->err->info = info;
4358         }
4359     }
4360
4361     d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4362     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4363
4364     d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4365     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4366
4367     d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4368     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4369
4370     /* Done with the names for the pipes */
4371     PerlMem_free(err);
4372     PerlMem_free(out);
4373     PerlMem_free(in);
4374
4375     p = vmscmd->dsc$a_pointer;
4376     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4377     if (*p == '$') p++;                         /* remove leading $ */
4378     while (*p == ' ' || *p == '\t') p++;
4379
4380     for (j = 0; j < 4; j++) {
4381         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4382         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4383
4384     d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4385     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4386
4387         if (strlen(p) > MAX_DCL_SYMBOL) {
4388             p += MAX_DCL_SYMBOL;
4389         } else {
4390             p += strlen(p);
4391         }
4392     }
4393     _ckvmssts_noperl(sys$setast(0));
4394     info->next=open_pipes;  /* prepend to list */
4395     open_pipes=info;
4396     _ckvmssts_noperl(sys$setast(1));
4397     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4398      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4399      * have SYS$COMMAND if we need it.
4400      */
4401     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4402                       0, &info->pid, &info->completion,
4403                       0, popen_completion_ast,info,0,0,0));
4404
4405     /* if we were using a tempfile, close it now */
4406
4407     if (tpipe) fclose(tpipe);
4408
4409     /* once the subprocess is spawned, it has copied the symbols and
4410        we can get rid of ours */
4411
4412     for (j = 0; j < 4; j++) {
4413         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4414         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4415     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4416     }
4417     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4418     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4419     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4420     vms_execfree(vmscmd);
4421
4422 #ifdef PERL_IMPLICIT_CONTEXT
4423     if (aTHX)
4424 #endif
4425     PL_forkprocess = info->pid;
4426
4427     ret_fp = info->fp;
4428     if (wait) {
4429          dSAVEDERRNO;
4430          int done = 0;
4431          while (!done) {
4432              _ckvmssts_noperl(sys$setast(0));
4433              done = info->done;
4434              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4435              _ckvmssts_noperl(sys$setast(1));
4436              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4437          }
4438         *psts = info->completion;
4439 /* Caller thinks it is open and tries to close it. */
4440 /* This causes some problems, as it changes the error status */
4441 /*        my_pclose(info->fp); */
4442
4443          /* If we did not have a file pointer open, then we have to */
4444          /* clean up here or eventually we will run out of something */
4445          SAVE_ERRNO;
4446          if (info->fp == NULL) {
4447              my_pclose_pinfo(aTHX_ info);
4448          }
4449          RESTORE_ERRNO;
4450
4451     } else {
4452         *psts = info->pid;
4453     }
4454     return ret_fp;
4455 }  /* end of safe_popen */
4456
4457
4458 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4459 PerlIO *
4460 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4461 {
4462     int sts;
4463     TAINT_ENV();
4464     TAINT_PROPER("popen");
4465     PERL_FLUSHALL_FOR_CHILD;
4466     return safe_popen(aTHX_ cmd,mode,&sts);
4467 }
4468
4469 /*}}}*/
4470
4471
4472 /* Routine to close and cleanup a pipe info structure */
4473
4474 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4475
4476     unsigned long int retsts;
4477     int done, n;
4478     pInfo next, last;
4479
4480     /* If we were writing to a subprocess, insure that someone reading from
4481      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4482      * produce an EOF record in the mailbox.
4483      *
4484      *  well, at least sometimes it *does*, so we have to watch out for
4485      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4486      */
4487      if (info->fp) {
4488         if (!info->useFILE
4489 #if defined(USE_ITHREADS)
4490           && my_perl
4491 #endif
4492 #ifdef USE_PERLIO
4493           && PL_perlio_fd_refcnt
4494 #endif
4495            )
4496             PerlIO_flush(info->fp);
4497         else
4498             fflush((FILE *)info->fp);
4499     }
4500
4501     _ckvmssts(sys$setast(0));
4502      info->closing = TRUE;
4503      done = info->done && info->in_done && info->out_done && info->err_done;
4504      /* hanging on write to Perl's input? cancel it */
4505      if (info->mode == 'r' && info->out && !info->out_done) {
4506         if (info->out->chan_out) {
4507             _ckvmssts(sys$cancel(info->out->chan_out));
4508             if (!info->out->chan_in) {   /* EOF generation, need AST */
4509                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4510             }
4511         }
4512      }
4513      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4514          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4515                            0, 0, 0, 0, 0, 0));
4516     _ckvmssts(sys$setast(1));
4517     if (info->fp) {
4518      if (!info->useFILE
4519 #if defined(USE_ITHREADS)
4520          && my_perl
4521 #endif
4522 #ifdef USE_PERLIO
4523          && PL_perlio_fd_refcnt
4524 #endif
4525         )
4526         PerlIO_close(info->fp);
4527      else
4528         fclose((FILE *)info->fp);
4529     }
4530      /*
4531         we have to wait until subprocess completes, but ALSO wait until all
4532         the i/o completes...otherwise we'll be freeing the "info" structure
4533         that the i/o ASTs could still be using...
4534      */
4535
4536      while (!done) {
4537          _ckvmssts(sys$setast(0));
4538          done = info->done && info->in_done && info->out_done && info->err_done;
4539          if (!done) _ckvmssts(sys$clref(pipe_ef));
4540          _ckvmssts(sys$setast(1));
4541          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4542      }
4543      retsts = info->completion;
4544
4545     /* remove from list of open pipes */
4546     _ckvmssts(sys$setast(0));
4547     last = NULL;
4548     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4549         if (next == info)
4550             break;
4551     }
4552
4553     if (last)
4554         last->next = info->next;
4555     else
4556         open_pipes = info->next;
4557     _ckvmssts(sys$setast(1));
4558
4559     /* free buffers and structures */
4560
4561     if (info->in) {
4562         if (info->in->buf) {
4563             n = info->in->bufsize * sizeof(char);
4564             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4565         }
4566         n = sizeof(Pipe);
4567         _ckvmssts(lib$free_vm(&n, &info->in));
4568     }
4569     if (info->out) {
4570         if (info->out->buf) {
4571             n = info->out->bufsize * sizeof(char);
4572             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4573         }
4574         n = sizeof(Pipe);
4575         _ckvmssts(lib$free_vm(&n, &info->out));
4576     }
4577     if (info->err) {
4578         if (info->err->buf) {
4579             n = info->err->bufsize * sizeof(char);
4580             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4581         }
4582         n = sizeof(Pipe);
4583         _ckvmssts(lib$free_vm(&n, &info->err));
4584     }
4585     n = sizeof(Info);
4586     _ckvmssts(lib$free_vm(&n, &info));
4587
4588     return retsts;
4589 }
4590
4591
4592 /*{{{  I32 my_pclose(PerlIO *fp)*/
4593 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4594 {
4595     pInfo info, last = NULL;
4596     I32 ret_status;
4597
4598     /* Fixme - need ast and mutex protection here */
4599     for (info = open_pipes; info != NULL; last = info, info = info->next)
4600         if (info->fp == fp) break;
4601
4602     if (info == NULL) {  /* no such pipe open */
4603       set_errno(ECHILD); /* quoth POSIX */
4604       set_vaxc_errno(SS$_NONEXPR);
4605       return -1;
4606     }
4607
4608     ret_status = my_pclose_pinfo(aTHX_ info);
4609
4610     return ret_status;
4611
4612 }  /* end of my_pclose() */
4613
4614 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4615   /* Roll our own prototype because we want this regardless of whether
4616    * _VMS_WAIT is defined.
4617    */
4618
4619 #ifdef __cplusplus
4620 extern "C" {
4621 #endif
4622   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4623 #ifdef __cplusplus
4624 }
4625 #endif
4626
4627 #endif
4628 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4629    created with popen(); otherwise partially emulate waitpid() unless
4630    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4631    Also check processes not considered by the CRTL waitpid().
4632  */
4633 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4634 Pid_t
4635 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4636 {
4637     pInfo info;
4638     int done;
4639     int sts;
4640     int j;
4641
4642     if (statusp) *statusp = 0;
4643
4644     for (info = open_pipes; info != NULL; info = info->next)
4645         if (info->pid == pid) break;
4646
4647     if (info != NULL) {  /* we know about this child */
4648       while (!info->done) {
4649           _ckvmssts(sys$setast(0));
4650           done = info->done;
4651           if (!done) _ckvmssts(sys$clref(pipe_ef));
4652           _ckvmssts(sys$setast(1));
4653           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4654       }
4655
4656       if (statusp) *statusp = info->completion;
4657       return pid;
4658     }
4659
4660     /* child that already terminated? */
4661
4662     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4663         if (closed_list[j].pid == pid) {
4664             if (statusp) *statusp = closed_list[j].completion;
4665             return pid;
4666         }
4667     }
4668
4669     /* fall through if this child is not one of our own pipe children */
4670
4671 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4672
4673       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4674        * in 7.2 did we get a version that fills in the VMS completion
4675        * status as Perl has always tried to do.
4676        */
4677
4678       sts = __vms_waitpid( pid, statusp, flags );
4679
4680       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4681          return sts;
4682
4683       /* If the real waitpid tells us the child does not exist, we
4684        * fall through here to implement waiting for a child that
4685        * was created by some means other than exec() (say, spawned
4686        * from DCL) or to wait for a process that is not a subprocess
4687        * of the current process.
4688        */
4689
4690 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4691
4692     {
4693       $DESCRIPTOR(intdsc,"0 00:00:01");
4694       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4695       unsigned long int pidcode = JPI$_PID, mypid;
4696       unsigned long int interval[2];
4697       unsigned int jpi_iosb[2];
4698       struct itmlst_3 jpilist[2] = {
4699           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4700           {                      0,         0,                 0, 0}
4701       };
4702
4703       if (pid <= 0) {
4704         /* Sorry folks, we don't presently implement rooting around for
4705            the first child we can find, and we definitely don't want to
4706            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4707          */
4708         set_errno(ENOTSUP);
4709         return -1;
4710       }
4711
4712       /* Get the owner of the child so I can warn if it's not mine. If the
4713        * process doesn't exist or I don't have the privs to look at it,
4714        * I can go home early.
4715        */
4716       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4717       if (sts & 1) sts = jpi_iosb[0];
4718       if (!(sts & 1)) {
4719         switch (sts) {
4720             case SS$_NONEXPR:
4721                 set_errno(ECHILD);
4722                 break;
4723             case SS$_NOPRIV:
4724                 set_errno(EACCES);
4725                 break;
4726             default:
4727                 _ckvmssts(sts);
4728         }
4729         set_vaxc_errno(sts);
4730         return -1;
4731       }
4732
4733       if (ckWARN(WARN_EXEC)) {
4734         /* remind folks they are asking for non-standard waitpid behavior */
4735         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4736         if (ownerpid != mypid)
4737           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4738                       "waitpid: process %x is not a child of process %x",
4739                       pid,mypid);
4740       }
4741
4742       /* simply check on it once a second until it's not there anymore. */
4743
4744       _ckvmssts(sys$bintim(&intdsc,interval));
4745       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4746             _ckvmssts(sys$schdwk(0,0,interval,0));
4747             _ckvmssts(sys$hiber());
4748       }
4749       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4750
4751       _ckvmssts(sts);
4752       return pid;
4753     }
4754 }  /* end of waitpid() */
4755 /*}}}*/
4756 /*}}}*/
4757 /*}}}*/
4758
4759 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4760 char *
4761 my_gconvert(double val, int ndig, int trail, char *buf)
4762 {
4763   static char __gcvtbuf[DBL_DIG+1];
4764   char *loc;
4765
4766   loc = buf ? buf : __gcvtbuf;
4767
4768   if (val) {
4769     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4770     return gcvt(val,ndig,loc);
4771   }
4772   else {
4773     loc[0] = '0'; loc[1] = '\0';
4774     return loc;
4775   }
4776
4777 }
4778 /*}}}*/
4779
4780 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4781 static int rms_free_search_context(struct FAB * fab)
4782 {
4783 struct NAM * nam;
4784
4785     nam = fab->fab$l_nam;
4786     nam->nam$b_nop |= NAM$M_SYNCHK;
4787     nam->nam$l_rlf = NULL;
4788     fab->fab$b_dns = 0;
4789     return sys$parse(fab, NULL, NULL);
4790 }
4791
4792 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4793 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4794 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4795 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4796 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4797 #define rms_nam_esll(nam) nam.nam$b_esl
4798 #define rms_nam_esl(nam) nam.nam$b_esl
4799 #define rms_nam_name(nam) nam.nam$l_name
4800 #define rms_nam_namel(nam) nam.nam$l_name
4801 #define rms_nam_type(nam) nam.nam$l_type
4802 #define rms_nam_typel(nam) nam.nam$l_type
4803 #define rms_nam_ver(nam) nam.nam$l_ver
4804 #define rms_nam_verl(nam) nam.nam$l_ver
4805 #define rms_nam_rsll(nam) nam.nam$b_rsl
4806 #define rms_nam_rsl(nam) nam.nam$b_rsl
4807 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4808 #define rms_set_fna(fab, nam, name, size) \
4809         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4810 #define rms_get_fna(fab, nam) fab.fab$l_fna
4811 #define rms_set_dna(fab, nam, name, size) \
4812         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4813 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4814 #define rms_set_esa(nam, name, size) \
4815         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4816 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4817         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4818 #define rms_set_rsa(nam, name, size) \
4819         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4820 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4821         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4822 #define rms_nam_name_type_l_size(nam) \
4823         (nam.nam$b_name + nam.nam$b_type)
4824 #else
4825 static int rms_free_search_context(struct FAB * fab)
4826 {
4827 struct NAML * nam;
4828
4829     nam = fab->fab$l_naml;
4830     nam->naml$b_nop |= NAM$M_SYNCHK;
4831     nam->naml$l_rlf = NULL;
4832     nam->naml$l_long_defname_size = 0;
4833
4834     fab->fab$b_dns = 0;
4835     return sys$parse(fab, NULL, NULL);
4836 }
4837
4838 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4839 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4840 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4841 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4842 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4843 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4844 #define rms_nam_esl(nam) nam.naml$b_esl
4845 #define rms_nam_name(nam) nam.naml$l_name
4846 #define rms_nam_namel(nam) nam.naml$l_long_name
4847 #define rms_nam_type(nam) nam.naml$l_type
4848 #define rms_nam_typel(nam) nam.naml$l_long_type
4849 #define rms_nam_ver(nam) nam.naml$l_ver
4850 #define rms_nam_verl(nam) nam.naml$l_long_ver
4851 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4852 #define rms_nam_rsl(nam) nam.naml$b_rsl
4853 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4854 #define rms_set_fna(fab, nam, name, size) \
4855         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4856         nam.naml$l_long_filename_size = size; \
4857         nam.naml$l_long_filename = name;}
4858 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4859 #define rms_set_dna(fab, nam, name, size) \
4860         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4861         nam.naml$l_long_defname_size = size; \
4862         nam.naml$l_long_defname = name; }
4863 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4864 #define rms_set_esa(nam, name, size) \
4865         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4866         nam.naml$l_long_expand_alloc = size; \
4867         nam.naml$l_long_expand = name; }
4868 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4869         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4870         nam.naml$l_long_expand = l_name; \
4871         nam.naml$l_long_expand_alloc = l_size; }
4872 #define rms_set_rsa(nam, name, size) \
4873         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4874         nam.naml$l_long_result = name; \
4875         nam.naml$l_long_result_alloc = size; }
4876 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4877         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4878         nam.naml$l_long_result = l_name; \
4879         nam.naml$l_long_result_alloc = l_size; }
4880 #define rms_nam_name_type_l_size(nam) \
4881         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4882 #endif
4883
4884
4885 /* rms_erase
4886  * The CRTL for 8.3 and later can create symbolic links in any mode,
4887  * however in 8.3 the unlink/remove/delete routines will only properly handle
4888  * them if one of the PCP modes is active.
4889  */
4890 static int rms_erase(const char * vmsname)
4891 {
4892   int status;
4893   struct FAB myfab = cc$rms_fab;
4894   rms_setup_nam(mynam);
4895
4896   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4897   rms_bind_fab_nam(myfab, mynam);
4898
4899 #ifdef NAML$M_OPEN_SPECIAL
4900   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4901 #endif
4902
4903   status = sys$erase(&myfab, 0, 0);
4904
4905   return status;
4906 }
4907
4908
4909 static int
4910 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4911                     const struct dsc$descriptor_s * vms_dst_dsc,
4912                     unsigned long flags)
4913 {
4914     /*  VMS and UNIX handle file permissions differently and the
4915      * the same ACL trick may be needed for renaming files,
4916      * especially if they are directories.
4917      */
4918
4919    /* todo: get kill_file and rename to share common code */
4920    /* I can not find online documentation for $change_acl
4921     * it appears to be replaced by $set_security some time ago */
4922
4923 const unsigned int access_mode = 0;
4924 $DESCRIPTOR(obj_file_dsc,"FILE");
4925 char *vmsname;
4926 char *rslt;
4927 unsigned long int jpicode = JPI$_UIC;
4928 int aclsts, fndsts, rnsts = -1;
4929 unsigned int ctx = 0;
4930 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4931 struct dsc$descriptor_s * clean_dsc;
4932
4933 struct myacedef {
4934     unsigned char myace$b_length;
4935     unsigned char myace$b_type;
4936     unsigned short int myace$w_flags;
4937     unsigned long int myace$l_access;
4938     unsigned long int myace$l_ident;
4939 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4940              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4941              0},
4942              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4943
4944 struct item_list_3
4945         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4946                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4947                       {0,0,0,0}},
4948         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4949         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4950                      {0,0,0,0}};
4951
4952
4953     /* Expand the input spec using RMS, since we do not want to put
4954      * ACLs on the target of a symbolic link */
4955     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
4956     if (vmsname == NULL)
4957         return SS$_INSFMEM;
4958
4959     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4960                         vmsname,
4961                         PERL_RMSEXPAND_M_SYMLINK);
4962     if (rslt == NULL) {
4963         PerlMem_free(vmsname);
4964         return SS$_INSFMEM;
4965     }
4966
4967     /* So we get our own UIC to use as a rights identifier,
4968      * and the insert an ACE at the head of the ACL which allows us
4969      * to delete the file.
4970      */
4971     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4972
4973     fildsc.dsc$w_length = strlen(vmsname);
4974     fildsc.dsc$a_pointer = vmsname;
4975     ctx = 0;
4976     newace.myace$l_ident = oldace.myace$l_ident;
4977     rnsts = SS$_ABORT;
4978
4979     /* Grab any existing ACEs with this identifier in case we fail */
4980     clean_dsc = &fildsc;
4981     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4982                                &fildsc,
4983                                NULL,
4984                                OSS$M_WLOCK,
4985                                findlst,
4986                                &ctx,
4987                                &access_mode);
4988
4989     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4990         /* Add the new ACE . . . */
4991
4992         /* if the sys$get_security succeeded, then ctx is valid, and the
4993          * object/file descriptors will be ignored.  But otherwise they
4994          * are needed
4995          */
4996         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4997                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4998         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4999             set_errno(EVMSERR);
5000             set_vaxc_errno(aclsts);
5001             PerlMem_free(vmsname);
5002             return aclsts;
5003         }
5004
5005         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5006                                 NULL, NULL,
5007                                 &flags,
5008                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5009
5010         if ($VMS_STATUS_SUCCESS(rnsts)) {
5011             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5012         }
5013
5014         /* Put things back the way they were. */
5015         ctx = 0;
5016         aclsts = sys$get_security(&obj_file_dsc,
5017                                   clean_dsc,
5018                                   NULL,
5019                                   OSS$M_WLOCK,
5020                                   findlst,
5021                                   &ctx,
5022                                   &access_mode);
5023
5024         if ($VMS_STATUS_SUCCESS(aclsts)) {
5025         int sec_flags;
5026
5027             sec_flags = 0;
5028             if (!$VMS_STATUS_SUCCESS(fndsts))
5029                 sec_flags = OSS$M_RELCTX;
5030
5031             /* Get rid of the new ACE */
5032             aclsts = sys$set_security(NULL, NULL, NULL,
5033                                   sec_flags, dellst, &ctx, &access_mode);
5034
5035             /* If there was an old ACE, put it back */
5036             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5037                 addlst[0].bufadr = &oldace;
5038                 aclsts = sys$set_security(NULL, NULL, NULL,
5039                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5040                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5041                     set_errno(EVMSERR);
5042                     set_vaxc_errno(aclsts);
5043                     rnsts = aclsts;
5044                 }
5045             } else {
5046             int aclsts2;
5047
5048                 /* Try to clear the lock on the ACL list */
5049                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5050                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5051
5052                 /* Rename errors are most important */
5053                 if (!$VMS_STATUS_SUCCESS(rnsts))
5054                     aclsts = rnsts;
5055                 set_errno(EVMSERR);
5056                 set_vaxc_errno(aclsts);
5057                 rnsts = aclsts;
5058             }
5059         }
5060         else {
5061             if (aclsts != SS$_ACLEMPTY)
5062                 rnsts = aclsts;
5063         }
5064     }
5065     else
5066         rnsts = fndsts;
5067
5068     PerlMem_free(vmsname);
5069     return rnsts;
5070 }
5071
5072
5073 /*{{{int rename(const char *, const char * */
5074 /* Not exactly what X/Open says to do, but doing it absolutely right
5075  * and efficiently would require a lot more work.  This should be close
5076  * enough to pass all but the most strict X/Open compliance test.
5077  */
5078 int
5079 Perl_rename(pTHX_ const char *src, const char * dst)
5080 {
5081 int retval;
5082 int pre_delete = 0;
5083 int src_sts;
5084 int dst_sts;
5085 Stat_t src_st;
5086 Stat_t dst_st;
5087
5088     /* Validate the source file */
5089     src_sts = flex_lstat(src, &src_st);
5090     if (src_sts != 0) {
5091
5092         /* No source file or other problem */
5093         return src_sts;
5094     }
5095     if (src_st.st_devnam[0] == 0)  {
5096         /* This may be possible so fail if it is seen. */
5097         errno = EIO;
5098         return -1;
5099     }
5100
5101     dst_sts = flex_lstat(dst, &dst_st);
5102     if (dst_sts == 0) {
5103
5104         if (dst_st.st_dev != src_st.st_dev) {
5105             /* Must be on the same device */
5106             errno = EXDEV;
5107             return -1;
5108         }
5109
5110         /* VMS_INO_T_COMPARE is true if the inodes are different
5111          * to match the output of memcmp
5112          */
5113
5114         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5115             /* That was easy, the files are the same! */
5116             return 0;
5117         }
5118
5119         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5120             /* If source is a directory, so must be dest */
5121                 errno = EISDIR;
5122                 return -1;
5123         }
5124
5125     }
5126
5127
5128     if ((dst_sts == 0) &&
5129         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5130
5131         /* We have issues here if vms_unlink_all_versions is set
5132          * If the destination exists, and is not a directory, then
5133          * we must delete in advance.
5134          *
5135          * If the src is a directory, then we must always pre-delete
5136          * the destination.
5137          *
5138          * If we successfully delete the dst in advance, and the rename fails
5139          * X/Open requires that errno be EIO.
5140          *
5141          */
5142
5143         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5144             int d_sts;
5145             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5146                                      S_ISDIR(dst_st.st_mode));
5147
5148            /* Need to delete all versions ? */
5149            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5150                 int i = 0;
5151
5152                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5153                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5154                     if (d_sts != 0)
5155                         break;
5156                     i++;
5157
5158                     /* Make sure that we do not loop forever */
5159                     if (i > 32767) {
5160                         errno = EIO;
5161                         d_sts = -1;
5162                         break;
5163                     }
5164                 }
5165            }
5166
5167             if (d_sts != 0)
5168                 return d_sts;
5169
5170             /* We killed the destination, so only errno now is EIO */
5171             pre_delete = 1;
5172         }
5173     }
5174
5175     /* Originally the idea was to call the CRTL rename() and only
5176      * try the lib$rename_file if it failed.
5177      * It turns out that there are too many variants in what the
5178      * the CRTL rename might do, so only use lib$rename_file
5179      */
5180     retval = -1;
5181
5182     {
5183         /* Is the source and dest both in VMS format */
5184         /* if the source is a directory, then need to fileify */
5185         /*  and dest must be a directory or non-existent. */
5186
5187         char * vms_dst;
5188         int sts;
5189         char * ret_str;
5190         unsigned long flags;
5191         struct dsc$descriptor_s old_file_dsc;
5192         struct dsc$descriptor_s new_file_dsc;
5193
5194         /* We need to modify the src and dst depending
5195          * on if one or more of them are directories.
5196          */
5197
5198         vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
5199         if (vms_dst == NULL)
5200             _ckvmssts_noperl(SS$_INSFMEM);
5201
5202         if (S_ISDIR(src_st.st_mode)) {
5203         char * ret_str;
5204         char * vms_dir_file;
5205
5206             vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
5207             if (vms_dir_file == NULL)
5208                 _ckvmssts_noperl(SS$_INSFMEM);
5209
5210             /* If the dest is a directory, we must remove it */
5211             if (dst_sts == 0) {
5212                 int d_sts;
5213                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5214                 if (d_sts != 0) {
5215                     PerlMem_free(vms_dst);
5216                     errno = EIO;
5217                     return d_sts;
5218                 }
5219
5220                 pre_delete = 1;
5221             }
5222
5223            /* The dest must be a VMS file specification */
5224            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5225            if (ret_str == NULL) {
5226                 PerlMem_free(vms_dst);
5227                 errno = EIO;
5228                 return -1;
5229            }
5230
5231             /* The source must be a file specification */
5232             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5233             if (ret_str == NULL) {
5234                 PerlMem_free(vms_dst);
5235                 PerlMem_free(vms_dir_file);
5236                 errno = EIO;
5237                 return -1;
5238             }
5239             PerlMem_free(vms_dst);
5240             vms_dst = vms_dir_file;
5241
5242         } else {
5243             /* File to file or file to new dir */
5244
5245             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5246                 /* VMS pathify a dir target */
5247                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5248                 if (ret_str == NULL) {
5249                     PerlMem_free(vms_dst);
5250                     errno = EIO;
5251                     return -1;
5252                 }
5253             } else {
5254                 char * v_spec, * r_spec, * d_spec, * n_spec;
5255                 char * e_spec, * vs_spec;
5256                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5257
5258                 /* fileify a target VMS file specification */
5259                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5260                 if (ret_str == NULL) {
5261                     PerlMem_free(vms_dst);
5262                     errno = EIO;
5263                     return -1;
5264                 }
5265
5266                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5267                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5268                              &e_len, &vs_spec, &vs_len);
5269                 if (sts == 0) {
5270                      if (e_len == 0) {
5271                          /* Get rid of the version */
5272                          if (vs_len != 0) {
5273                              *vs_spec = '\0';
5274                          }
5275                          /* Need to specify a '.' so that the extension */
5276                          /* is not inherited */
5277                          strcat(vms_dst,".");
5278                      }
5279                 }
5280             }
5281         }
5282
5283         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5284         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5285         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5286         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5287
5288         new_file_dsc.dsc$a_pointer = vms_dst;
5289         new_file_dsc.dsc$w_length = strlen(vms_dst);
5290         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5291         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5292
5293         flags = 0;
5294 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5295         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5296 #endif
5297
5298         sts = lib$rename_file(&old_file_dsc,
5299                               &new_file_dsc,
5300                               NULL, NULL,
5301                               &flags,
5302                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5303         if (!$VMS_STATUS_SUCCESS(sts)) {
5304
5305            /* We could have failed because VMS style permissions do not
5306             * permit renames that UNIX will allow.  Just like the hack
5307             * in for kill_file.
5308             */
5309            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5310         }
5311
5312         PerlMem_free(vms_dst);
5313         if (!$VMS_STATUS_SUCCESS(sts)) {
5314             errno = EIO;
5315             return -1;
5316         }
5317         retval = 0;
5318     }
5319
5320     if (vms_unlink_all_versions) {
5321         /* Now get rid of any previous versions of the source file that
5322          * might still exist
5323          */
5324         int i = 0;
5325         dSAVEDERRNO;
5326         SAVE_ERRNO;
5327         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5328                                    S_ISDIR(src_st.st_mode));
5329         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5330              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5331                                        S_ISDIR(src_st.st_mode));
5332              if (src_sts != 0)
5333                  break;
5334              i++;
5335
5336              /* Make sure that we do not loop forever */
5337              if (i > 32767) {
5338                  src_sts = -1;
5339                  break;
5340              }
5341         }
5342         RESTORE_ERRNO;
5343     }
5344
5345     /* We deleted the destination, so must force the error to be EIO */
5346     if ((retval != 0) && (pre_delete != 0))
5347         errno = EIO;
5348
5349     return retval;
5350 }
5351 /*}}}*/
5352
5353
5354 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5355 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5356  * to expand file specification.  Allows for a single default file
5357  * specification and a simple mask of options.  If outbuf is non-NULL,
5358  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5359  * the resultant file specification is placed.  If outbuf is NULL, the
5360  * resultant file specification is placed into a static buffer.
5361  * The third argument, if non-NULL, is taken to be a default file
5362  * specification string.  The fourth argument is unused at present.
5363  * rmesexpand() returns the address of the resultant string if
5364  * successful, and NULL on error.
5365  *
5366  * New functionality for previously unused opts value:
5367  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5368  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5369  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5370  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5371  */
5372 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5373
5374 static char *
5375 int_rmsexpand
5376    (const char *filespec,
5377     char *outbuf,
5378     const char *defspec,
5379     unsigned opts,
5380     int * fs_utf8,
5381     int * dfs_utf8)
5382 {
5383   char * ret_spec;
5384   const char * in_spec;
5385   char * spec_buf;
5386   const char * def_spec;
5387   char * vmsfspec, *vmsdefspec;
5388   char * esa;
5389   char * esal = NULL;
5390   char * outbufl;
5391   struct FAB myfab = cc$rms_fab;
5392   rms_setup_nam(mynam);
5393   STRLEN speclen;
5394   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5395   int sts;
5396
5397   /* temp hack until UTF8 is actually implemented */
5398   if (fs_utf8 != NULL)
5399     *fs_utf8 = 0;
5400
5401   if (!filespec || !*filespec) {
5402     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5403     return NULL;
5404   }
5405
5406   vmsfspec = NULL;
5407   vmsdefspec = NULL;
5408   outbufl = NULL;
5409
5410   in_spec = filespec;
5411   isunix = 0;
5412   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5413       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5414       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5415
5416       /* If this is a UNIX file spec, convert it to VMS */
5417       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5418                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5419                            &e_len, &vs_spec, &vs_len);
5420       if (sts != 0) {
5421           isunix = 1;
5422           char * ret_spec;
5423
5424           vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5425           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5426           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5427           if (ret_spec == NULL) {
5428               PerlMem_free(vmsfspec);
5429               return NULL;
5430           }
5431           in_spec = (const char *)vmsfspec;
5432
5433           /* Unless we are forcing to VMS format, a UNIX input means
5434            * UNIX output, and that requires long names to be used
5435            */
5436           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5437 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5438               opts |= PERL_RMSEXPAND_M_LONG;
5439 #else
5440               NOOP;
5441 #endif
5442           else
5443               isunix = 0;
5444       }
5445
5446   }
5447
5448   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5449   rms_bind_fab_nam(myfab, mynam);
5450
5451   /* Process the default file specification if present */
5452   def_spec = defspec;
5453   if (defspec && *defspec) {
5454     int t_isunix;
5455     t_isunix = is_unix_filespec(defspec);
5456     if (t_isunix) {
5457       vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5458       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5459       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5460
5461       if (ret_spec == NULL) {
5462           /* Clean up and bail */
5463           PerlMem_free(vmsdefspec);
5464           if (vmsfspec != NULL)
5465               PerlMem_free(vmsfspec);
5466               return NULL;
5467           }
5468           def_spec = (const char *)vmsdefspec;
5469       }
5470       rms_set_dna(myfab, mynam,
5471                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5472   }
5473
5474   /* Now we need the expansion buffers */
5475   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
5476   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5477 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5478   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
5479   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5480 #endif
5481   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5482
5483   /* If a NAML block is used RMS always writes to the long and short
5484    * addresses unless you suppress the short name.
5485    */
5486 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5487   outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
5488   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5489 #endif
5490    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5491
5492 #ifdef NAM$M_NO_SHORT_UPCASE
5493   if (decc_efs_case_preserve)
5494     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5495 #endif
5496
5497    /* We may not want to follow symbolic links */
5498 #ifdef NAML$M_OPEN_SPECIAL
5499   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5500     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5501 #endif
5502
5503   /* First attempt to parse as an existing file */
5504   retsts = sys$parse(&myfab,0,0);
5505   if (!(retsts & STS$K_SUCCESS)) {
5506
5507     /* Could not find the file, try as syntax only if error is not fatal */
5508     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5509     if (retsts == RMS$_DNF ||
5510         retsts == RMS$_DIR ||
5511         retsts == RMS$_DEV ||
5512         retsts == RMS$_PRV) {
5513       retsts = sys$parse(&myfab,0,0);
5514       if (retsts & STS$K_SUCCESS) goto int_expanded;
5515     }
5516
5517      /* Still could not parse the file specification */
5518     /*----------------------------------------------*/
5519     sts = rms_free_search_context(&myfab); /* Free search context */
5520     if (vmsdefspec != NULL)
5521         PerlMem_free(vmsdefspec);
5522     if (vmsfspec != NULL)
5523         PerlMem_free(vmsfspec);
5524     if (outbufl != NULL)
5525         PerlMem_free(outbufl);
5526     PerlMem_free(esa);
5527     if (esal != NULL)
5528         PerlMem_free(esal);
5529     set_vaxc_errno(retsts);
5530     if      (retsts == RMS$_PRV) set_errno(EACCES);
5531     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5532     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5533     else                         set_errno(EVMSERR);
5534     return NULL;
5535   }
5536   retsts = sys$search(&myfab,0,0);
5537   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5538     sts = rms_free_search_context(&myfab); /* Free search context */
5539     if (vmsdefspec != NULL)
5540         PerlMem_free(vmsdefspec);
5541     if (vmsfspec != NULL)
5542         PerlMem_free(vmsfspec);
5543     if (outbufl != NULL)
5544         PerlMem_free(outbufl);
5545     PerlMem_free(esa);
5546     if (esal != NULL)
5547         PerlMem_free(esal);
5548     set_vaxc_errno(retsts);
5549     if      (retsts == RMS$_PRV) set_errno(EACCES);
5550     else                         set_errno(EVMSERR);
5551     return NULL;
5552   }
5553
5554   /* If the input filespec contained any lowercase characters,
5555    * downcase the result for compatibility with Unix-minded code. */
5556 int_expanded:
5557   if (!decc_efs_case_preserve) {
5558     char * tbuf;
5559     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5560       if (islower(*tbuf)) { haslower = 1; break; }
5561   }
5562
5563    /* Is a long or a short name expected */
5564   /*------------------------------------*/
5565   spec_buf = NULL;
5566 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5567   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5568     if (rms_nam_rsll(mynam)) {
5569         spec_buf = outbufl;
5570         speclen = rms_nam_rsll(mynam);
5571     }
5572     else {
5573         spec_buf = esal; /* Not esa */
5574         speclen = rms_nam_esll(mynam);
5575     }
5576   }
5577   else {
5578 #endif
5579     if (rms_nam_rsl(mynam)) {
5580         spec_buf = outbuf;
5581         speclen = rms_nam_rsl(mynam);
5582     }
5583     else {
5584         spec_buf = esa; /* Not esal */
5585         speclen = rms_nam_esl(mynam);
5586     }
5587 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5588   }
5589 #endif
5590   spec_buf[speclen] = '\0';
5591
5592   /* Trim off null fields added by $PARSE
5593    * If type > 1 char, must have been specified in original or default spec
5594    * (not true for version; $SEARCH may have added version of existing file).
5595    */
5596   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5597   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5598     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5599              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5600   }
5601   else {
5602     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5603              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5604   }
5605   if (trimver || trimtype) {
5606     if (defspec && *defspec) {
5607       char *defesal = NULL;
5608       char *defesa = NULL;
5609       defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5610       if (defesa != NULL) {
5611         struct FAB deffab = cc$rms_fab;
5612 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5613         defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5614         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5615 #endif
5616         rms_setup_nam(defnam);
5617
5618         rms_bind_fab_nam(deffab, defnam);
5619
5620         /* Cast ok */
5621         rms_set_fna
5622             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5623
5624         /* RMS needs the esa/esal as a work area if wildcards are involved */
5625         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5626
5627         rms_clear_nam_nop(defnam);
5628         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5629 #ifdef NAM$M_NO_SHORT_UPCASE
5630         if (decc_efs_case_preserve)
5631           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5632 #endif
5633 #ifdef NAML$M_OPEN_SPECIAL
5634         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5635           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5636 #endif
5637         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5638           if (trimver) {
5639              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5640           }
5641           if (trimtype) {
5642             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5643           }
5644         }
5645         if (defesal != NULL)
5646             PerlMem_free(defesal);
5647         PerlMem_free(defesa);
5648       } else {
5649           _ckvmssts_noperl(SS$_INSFMEM);
5650       }
5651     }
5652     if (trimver) {
5653       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5654         if (*(rms_nam_verl(mynam)) != '\"')
5655           speclen = rms_nam_verl(mynam) - spec_buf;
5656       }
5657       else {
5658         if (*(rms_nam_ver(mynam)) != '\"')
5659           speclen = rms_nam_ver(mynam) - spec_buf;
5660       }
5661     }
5662     if (trimtype) {
5663       /* If we didn't already trim version, copy down */
5664       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5665         if (speclen > rms_nam_verl(mynam) - spec_buf)
5666           memmove
5667            (rms_nam_typel(mynam),
5668             rms_nam_verl(mynam),
5669             speclen - (rms_nam_verl(mynam) - spec_buf));
5670           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5671       }
5672       else {
5673         if (speclen > rms_nam_ver(mynam) - spec_buf)
5674           memmove
5675            (rms_nam_type(mynam),
5676             rms_nam_ver(mynam),
5677             speclen - (rms_nam_ver(mynam) - spec_buf));
5678           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5679       }
5680     }
5681   }
5682
5683    /* Done with these copies of the input files */
5684   /*-------------------------------------------*/
5685   if (vmsfspec != NULL)
5686         PerlMem_free(vmsfspec);
5687   if (vmsdefspec != NULL)
5688         PerlMem_free(vmsdefspec);
5689
5690   /* If we just had a directory spec on input, $PARSE "helpfully"
5691    * adds an empty name and type for us */
5692 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5693   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5694     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5695         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5696         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5697       speclen = rms_nam_namel(mynam) - spec_buf;
5698   }
5699   else
5700 #endif
5701   {
5702     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5703         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5704         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5705       speclen = rms_nam_name(mynam) - spec_buf;
5706   }
5707
5708   /* Posix format specifications must have matching quotes */
5709   if (speclen < (VMS_MAXRSS - 1)) {
5710     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5711       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5712         spec_buf[speclen] = '\"';
5713         speclen++;
5714       }
5715     }
5716   }
5717   spec_buf[speclen] = '\0';
5718   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5719
5720   /* Have we been working with an expanded, but not resultant, spec? */
5721   /* Also, convert back to Unix syntax if necessary. */
5722   {
5723   int rsl;
5724
5725 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5726     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5727       rsl = rms_nam_rsll(mynam);
5728     } else
5729 #endif
5730     {
5731       rsl = rms_nam_rsl(mynam);
5732     }
5733     if (!rsl) {
5734       /* rsl is not present, it means that spec_buf is either */
5735       /* esa or esal, and needs to be copied to outbuf */
5736       /* convert to Unix if desired */
5737       if (isunix) {
5738         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5739       } else {
5740         /* VMS file specs are not in UTF-8 */
5741         if (fs_utf8 != NULL)
5742             *fs_utf8 = 0;
5743         my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5744         ret_spec = outbuf;
5745       }
5746     }
5747     else {
5748       /* Now spec_buf is either outbuf or outbufl */
5749       /* We need the result into outbuf */
5750       if (isunix) {
5751            /* If we need this in UNIX, then we need another buffer */
5752            /* to keep things in order */
5753            char * src;
5754            char * new_src = NULL;
5755            if (spec_buf == outbuf) {
5756                new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
5757                my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5758            } else {
5759                src = spec_buf;
5760            }
5761            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5762            if (new_src) {
5763                PerlMem_free(new_src);
5764            }
5765       } else {
5766            /* VMS file specs are not in UTF-8 */
5767            if (fs_utf8 != NULL)
5768                *fs_utf8 = 0;
5769
5770            /* Copy the buffer if needed */
5771            if (outbuf != spec_buf)
5772                my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5773            ret_spec = outbuf;
5774       }
5775     }
5776   }
5777
5778   /* Need to clean up the search context */
5779   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5780   sts = rms_free_search_context(&myfab); /* Free search context */
5781
5782   /* Clean up the extra buffers */
5783   if (esal != NULL)
5784       PerlMem_free(esal);
5785   PerlMem_free(esa);
5786   if (outbufl != NULL)
5787      PerlMem_free(outbufl);
5788
5789   /* Return the result */
5790   return ret_spec;
5791 }
5792
5793 /* Common simple case - Expand an already VMS spec */
5794 static char *
5795 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5796     opts |= PERL_RMSEXPAND_M_VMS_IN;
5797     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5798 }
5799
5800 /* Common simple case - Expand to a VMS spec */
5801 static char *
5802 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5803     opts |= PERL_RMSEXPAND_M_VMS;
5804     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5805 }
5806
5807
5808 /* Entry point used by perl routines */
5809 static char *
5810 mp_do_rmsexpand
5811    (pTHX_ const char *filespec,
5812     char *outbuf,
5813     int ts,
5814     const char *defspec,
5815     unsigned opts,
5816     int * fs_utf8,
5817     int * dfs_utf8)
5818 {
5819     static char __rmsexpand_retbuf[VMS_MAXRSS];
5820     char * expanded, *ret_spec, *ret_buf;
5821
5822     expanded = NULL;
5823     ret_buf = outbuf;
5824     if (ret_buf == NULL) {
5825         if (ts) {
5826             Newx(expanded, VMS_MAXRSS, char);
5827             if (expanded == NULL)
5828                 _ckvmssts(SS$_INSFMEM);
5829             ret_buf = expanded;
5830         } else {
5831             ret_buf = __rmsexpand_retbuf;
5832         }
5833     }
5834
5835
5836     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5837                              opts, fs_utf8,  dfs_utf8);
5838
5839     if (ret_spec == NULL) {
5840        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5841        if (expanded)
5842            Safefree(expanded);
5843     }
5844
5845     return ret_spec;
5846 }
5847 /*}}}*/
5848 /* External entry points */
5849 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5850 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5851 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5852 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5853 char *Perl_rmsexpand_utf8
5854   (pTHX_ const char *spec, char *buf, const char *def,
5855    unsigned opt, int * fs_utf8, int * dfs_utf8)
5856 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5857 char *Perl_rmsexpand_utf8_ts
5858   (pTHX_ const char *spec, char *buf, const char *def,
5859    unsigned opt, int * fs_utf8, int * dfs_utf8)
5860 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5861
5862
5863 /*
5864 ** The following routines are provided to make life easier when
5865 ** converting among VMS-style and Unix-style directory specifications.
5866 ** All will take input specifications in either VMS or Unix syntax. On
5867 ** failure, all return NULL.  If successful, the routines listed below
5868 ** return a pointer to a buffer containing the appropriately
5869 ** reformatted spec (and, therefore, subsequent calls to that routine
5870 ** will clobber the result), while the routines of the same names with
5871 ** a _ts suffix appended will return a pointer to a mallocd string
5872 ** containing the appropriately reformatted spec.
5873 ** In all cases, only explicit syntax is altered; no check is made that
5874 ** the resulting string is valid or that the directory in question
5875 ** actually exists.
5876 **
5877 **   fileify_dirspec() - convert a directory spec into the name of the
5878 **     directory file (i.e. what you can stat() to see if it's a dir).
5879 **     The style (VMS or Unix) of the result is the same as the style
5880 **     of the parameter passed in.
5881 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5882 **     what you prepend to a filename to indicate what directory it's in).
5883 **     The style (VMS or Unix) of the result is the same as the style
5884 **     of the parameter passed in.
5885 **   tounixpath() - convert a directory spec into a Unix-style path.
5886 **   tovmspath() - convert a directory spec into a VMS-style path.
5887 **   tounixspec() - convert any file spec into a Unix-style file spec.
5888 **   tovmsspec() - convert any file spec into a VMS-style spec.
5889 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5890 **
5891 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5892 ** Permission is given to distribute this code as part of the Perl
5893 ** standard distribution under the terms of the GNU General Public
5894 ** License or the Perl Artistic License.  Copies of each may be
5895 ** found in the Perl standard distribution.
5896  */
5897
5898 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5899 static char *
5900 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5901 {
5902     unsigned long int dirlen, retlen, hasfilename = 0;
5903     char *cp1, *cp2, *lastdir;
5904     char *trndir, *vmsdir;
5905     unsigned short int trnlnm_iter_count;
5906     int sts;
5907     if (utf8_fl != NULL)
5908         *utf8_fl = 0;
5909
5910     if (!dir || !*dir) {
5911       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5912     }
5913     dirlen = strlen(dir);
5914     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5915     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5916       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5917         dir = "/sys$disk";
5918         dirlen = 9;
5919       }
5920       else
5921         dirlen = 1;
5922     }
5923     if (dirlen > (VMS_MAXRSS - 1)) {
5924       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5925       return NULL;
5926     }
5927     trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5928     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5929     if (!strpbrk(dir+1,"/]>:")  &&
5930         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5931       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5932       trnlnm_iter_count = 0;
5933       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
5934         trnlnm_iter_count++;
5935         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5936       }
5937       dirlen = strlen(trndir);
5938     }
5939     else {
5940       memcpy(trndir, dir, dirlen);
5941       trndir[dirlen] = '\0';
5942     }
5943
5944     /* At this point we are done with *dir and use *trndir which is a
5945      * copy that can be modified.  *dir must not be modified.
5946      */
5947
5948     /* If we were handed a rooted logical name or spec, treat it like a
5949      * simple directory, so that
5950      *    $ Define myroot dev:[dir.]
5951      *    ... do_fileify_dirspec("myroot",buf,1) ...
5952      * does something useful.
5953      */
5954     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5955       trndir[--dirlen] = '\0';
5956       trndir[dirlen-1] = ']';
5957     }
5958     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5959       trndir[--dirlen] = '\0';
5960       trndir[dirlen-1] = '>';
5961     }
5962
5963     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5964       /* If we've got an explicit filename, we can just shuffle the string. */
5965       if (*(cp1+1)) hasfilename = 1;
5966       /* Similarly, we can just back up a level if we've got multiple levels
5967          of explicit directories in a VMS spec which ends with directories. */
5968       else {
5969         for (cp2 = cp1; cp2 > trndir; cp2--) {
5970           if (*cp2 == '.') {
5971             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5972 /* fix-me, can not scan EFS file specs backward like this */
5973               *cp2 = *cp1; *cp1 = '\0';
5974               hasfilename = 1;
5975               break;
5976             }
5977           }
5978           if (*cp2 == '[' || *cp2 == '<') break;
5979         }
5980       }
5981     }
5982
5983     vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5984     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5985     cp1 = strpbrk(trndir,"]:>");
5986     if (hasfilename || !cp1) { /* filename present or not VMS */
5987
5988       if (trndir[0] == '.') {
5989         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5990           PerlMem_free(trndir);
5991           PerlMem_free(vmsdir);
5992           return int_fileify_dirspec("[]", buf, NULL);
5993         }
5994         else if (trndir[1] == '.' &&
5995                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5996           PerlMem_free(trndir);
5997           PerlMem_free(vmsdir);
5998           return int_fileify_dirspec("[-]", buf, NULL);
5999         }
6000       }
6001       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6002         dirlen -= 1;                 /* to last element */
6003         lastdir = strrchr(trndir,'/');
6004       }
6005       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6006         /* If we have "/." or "/..", VMSify it and let the VMS code
6007          * below expand it, rather than repeating the code to handle
6008          * relative components of a filespec here */
6009         do {
6010           if (*(cp1+2) == '.') cp1++;
6011           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6012             char * ret_chr;
6013             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6014                 PerlMem_free(trndir);
6015                 PerlMem_free(vmsdir);
6016                 return NULL;
6017             }
6018             if (strchr(vmsdir,'/') != NULL) {
6019               /* If int_tovmsspec() returned it, it must have VMS syntax
6020                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6021                * the time to check this here only so we avoid a recursion
6022                * loop; otherwise, gigo.
6023                */
6024               PerlMem_free(trndir);
6025               PerlMem_free(vmsdir);
6026               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6027               return NULL;
6028             }
6029             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6030                 PerlMem_free(trndir);
6031                 PerlMem_free(vmsdir);
6032                 return NULL;
6033             }
6034             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6035             PerlMem_free(trndir);
6036             PerlMem_free(vmsdir);
6037             return ret_chr;
6038           }
6039           cp1++;
6040         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6041         lastdir = strrchr(trndir,'/');
6042       }
6043       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6044         char * ret_chr;
6045         /* Ditto for specs that end in an MFD -- let the VMS code
6046          * figure out whether it's a real device or a rooted logical. */
6047
6048         /* This should not happen any more.  Allowing the fake /000000
6049          * in a UNIX pathname causes all sorts of problems when trying
6050          * to run in UNIX emulation.  So the VMS to UNIX conversions
6051          * now remove the fake /000000 directories.
6052          */
6053
6054         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6055         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6056             PerlMem_free(trndir);
6057             PerlMem_free(vmsdir);
6058             return NULL;
6059         }
6060         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6061             PerlMem_free(trndir);
6062             PerlMem_free(vmsdir);
6063             return NULL;
6064         }
6065         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6066         PerlMem_free(trndir);
6067         PerlMem_free(vmsdir);
6068         return ret_chr;
6069       }
6070       else {
6071
6072         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6073              !(lastdir = cp1 = strrchr(trndir,']')) &&
6074              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6075
6076         cp2 = strrchr(cp1,'.');
6077         if (cp2) {
6078             int e_len, vs_len = 0;
6079             int is_dir = 0;
6080             char * cp3;
6081             cp3 = strchr(cp2,';');
6082             e_len = strlen(cp2);
6083             if (cp3) {
6084                 vs_len = strlen(cp3);
6085                 e_len = e_len - vs_len;
6086             }
6087             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6088             if (!is_dir) {
6089                 if (!decc_efs_charset) {
6090                     /* If this is not EFS, then not a directory */
6091                     PerlMem_free(trndir);
6092                     PerlMem_free(vmsdir);
6093                     set_errno(ENOTDIR);
6094                     set_vaxc_errno(RMS$_DIR);
6095                     return NULL;
6096                 }
6097             } else {
6098                 /* Ok, here we have an issue, technically if a .dir shows */
6099                 /* from inside a directory, then we should treat it as */
6100                 /* xxx^.dir.dir.  But we do not have that context at this */
6101                 /* point unless this is totally restructured, so we remove */
6102                 /* The .dir for now, and fix this better later */
6103                 dirlen = cp2 - trndir;
6104             }
6105             if (decc_efs_charset && !strchr(trndir,'/')) {
6106                 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6107                 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6108
6109                 for (; cp4 > cp1; cp4--) {
6110                     if (*cp4 == '.') {
6111                         if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6112                             memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6113                             *cp4 = '^';
6114                             dirlen++;
6115                         }
6116                     }
6117                 }
6118             }
6119         }
6120
6121       }
6122
6123       retlen = dirlen + 6;
6124       memcpy(buf, trndir, dirlen);
6125       buf[dirlen] = '\0';
6126
6127       /* We've picked up everything up to the directory file name.
6128          Now just add the type and version, and we're set. */
6129       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6130           strcat(buf,".dir;1");
6131       else
6132           strcat(buf,".DIR;1");
6133       PerlMem_free(trndir);
6134       PerlMem_free(vmsdir);
6135       return buf;
6136     }
6137     else {  /* VMS-style directory spec */
6138
6139       char *esa, *esal, term, *cp;
6140       char *my_esa;
6141       int my_esa_len;
6142       unsigned long int cmplen, haslower = 0;
6143       struct FAB dirfab = cc$rms_fab;
6144       rms_setup_nam(savnam);
6145       rms_setup_nam(dirnam);
6146
6147       esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
6148       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6149       esal = NULL;
6150 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6151       esal = (char *)PerlMem_malloc(VMS_MAXRSS);
6152       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6153 #endif
6154       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6155       rms_bind_fab_nam(dirfab, dirnam);
6156       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6157       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6158 #ifdef NAM$M_NO_SHORT_UPCASE
6159       if (decc_efs_case_preserve)
6160         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6161 #endif
6162
6163       for (cp = trndir; *cp; cp++)
6164         if (islower(*cp)) { haslower = 1; break; }
6165       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6166         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6167             (dirfab.fab$l_sts == RMS$_DNF) ||
6168             (dirfab.fab$l_sts == RMS$_PRV)) {
6169             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6170             sts = sys$parse(&dirfab);
6171         }
6172         if (!sts) {
6173           PerlMem_free(esa);
6174           if (esal != NULL)
6175               PerlMem_free(esal);
6176           PerlMem_free(trndir);
6177           PerlMem_free(vmsdir);
6178           set_errno(EVMSERR);
6179           set_vaxc_errno(dirfab.fab$l_sts);
6180           return NULL;
6181         }
6182       }
6183       else {
6184         savnam = dirnam;
6185         /* Does the file really exist? */
6186         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6187           /* Yes; fake the fnb bits so we'll check type below */
6188           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6189         }
6190         else { /* No; just work with potential name */
6191           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6192           else {
6193             int fab_sts;
6194             fab_sts = dirfab.fab$l_sts;
6195             sts = rms_free_search_context(&dirfab);
6196             PerlMem_free(esa);
6197             if (esal != NULL)
6198                 PerlMem_free(esal);
6199             PerlMem_free(trndir);
6200             PerlMem_free(vmsdir);
6201             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6202             return NULL;
6203           }
6204         }
6205       }
6206
6207       /* Make sure we are using the right buffer */
6208 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6209       if (esal != NULL) {
6210         my_esa = esal;
6211         my_esa_len = rms_nam_esll(dirnam);
6212       } else {
6213 #endif
6214         my_esa = esa;
6215         my_esa_len = rms_nam_esl(dirnam);
6216 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6217       }
6218 #endif
6219       my_esa[my_esa_len] = '\0';
6220       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6221         cp1 = strchr(my_esa,']');
6222         if (!cp1) cp1 = strchr(my_esa,'>');
6223         if (cp1) {  /* Should always be true */
6224           my_esa_len -= cp1 - my_esa - 1;
6225           memmove(my_esa, cp1 + 1, my_esa_len);
6226         }
6227       }
6228       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6229         /* Yep; check version while we're at it, if it's there. */
6230         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6231         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6232           /* Something other than .DIR[;1].  Bzzt. */
6233           sts = rms_free_search_context(&dirfab);
6234           PerlMem_free(esa);
6235           if (esal != NULL)
6236              PerlMem_free(esal);
6237           PerlMem_free(trndir);
6238           PerlMem_free(vmsdir);
6239           set_errno(ENOTDIR);
6240           set_vaxc_errno(RMS$_DIR);
6241           return NULL;
6242         }
6243       }
6244
6245       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6246         /* They provided at least the name; we added the type, if necessary, */
6247         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6248         sts = rms_free_search_context(&dirfab);
6249         PerlMem_free(trndir);
6250         PerlMem_free(esa);
6251         if (esal != NULL)
6252             PerlMem_free(esal);
6253         PerlMem_free(vmsdir);
6254         return buf;
6255       }
6256       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6257         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6258         *cp1 = '\0';
6259         my_esa_len -= 9;
6260       }
6261       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6262       if (cp1 == NULL) { /* should never happen */
6263         sts = rms_free_search_context(&dirfab);
6264         PerlMem_free(trndir);
6265         PerlMem_free(esa);
6266         if (esal != NULL)
6267             PerlMem_free(esal);
6268         PerlMem_free(vmsdir);
6269         return NULL;
6270       }
6271       term = *cp1;
6272       *cp1 = '\0';
6273       retlen = strlen(my_esa);
6274       cp1 = strrchr(my_esa,'.');
6275       /* ODS-5 directory specifications can have extra "." in them. */
6276       /* Fix-me, can not scan EFS file specifications backwards */
6277       while (cp1 != NULL) {
6278         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6279           break;
6280         else {
6281            cp1--;
6282            while ((cp1 > my_esa) && (*cp1 != '.'))
6283              cp1--;
6284         }
6285         if (cp1 == my_esa)
6286           cp1 = NULL;
6287       }
6288
6289       if ((cp1) != NULL) {
6290         /* There's more than one directory in the path.  Just roll back. */
6291         *cp1 = term;
6292         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6293       }
6294       else {
6295         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6296           /* Go back and expand rooted logical name */
6297           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6298 #ifdef NAM$M_NO_SHORT_UPCASE
6299           if (decc_efs_case_preserve)
6300             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6301 #endif
6302           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6303             sts = rms_free_search_context(&dirfab);
6304             PerlMem_free(esa);
6305             if (esal != NULL)
6306                 PerlMem_free(esal);
6307             PerlMem_free(trndir);
6308             PerlMem_free(vmsdir);
6309             set_errno(EVMSERR);
6310             set_vaxc_errno(dirfab.fab$l_sts);
6311             return NULL;
6312           }
6313
6314           /* This changes the length of the string of course */
6315           if (esal != NULL) {
6316               my_esa_len = rms_nam_esll(dirnam);
6317           } else {
6318               my_esa_len = rms_nam_esl(dirnam);
6319           }
6320
6321           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6322           cp1 = strstr(my_esa,"][");
6323           if (!cp1) cp1 = strstr(my_esa,"]<");
6324           dirlen = cp1 - my_esa;
6325           memcpy(buf, my_esa, dirlen);
6326           if (!strncmp(cp1+2,"000000]",7)) {
6327             buf[dirlen-1] = '\0';
6328             /* fix-me Not full ODS-5, just extra dots in directories for now */
6329             cp1 = buf + dirlen - 1;
6330             while (cp1 > buf)
6331             {
6332               if (*cp1 == '[')
6333                 break;
6334               if (*cp1 == '.') {
6335                 if (*(cp1-1) != '^')
6336                   break;
6337               }
6338               cp1--;
6339             }
6340             if (*cp1 == '.') *cp1 = ']';
6341             else {
6342               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6343               memmove(cp1+1,"000000]",7);
6344             }
6345           }
6346           else {
6347             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6348             buf[retlen] = '\0';
6349             /* Convert last '.' to ']' */
6350             cp1 = buf+retlen-1;
6351             while (*cp != '[') {
6352               cp1--;
6353               if (*cp1 == '.') {
6354                 /* Do not trip on extra dots in ODS-5 directories */
6355                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6356                 break;
6357               }
6358             }
6359             if (*cp1 == '.') *cp1 = ']';
6360             else {
6361               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6362               memmove(cp1+1,"000000]",7);
6363             }
6364           }
6365         }
6366         else {  /* This is a top-level dir.  Add the MFD to the path. */
6367           cp1 = my_esa;
6368           cp2 = buf;
6369           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6370           strcpy(cp2,":[000000]");
6371           cp1 += 2;
6372           strcpy(cp2+9,cp1);
6373         }
6374       }
6375       sts = rms_free_search_context(&dirfab);
6376       /* We've set up the string up through the filename.  Add the
6377          type and version, and we're done. */
6378       strcat(buf,".DIR;1");
6379
6380       /* $PARSE may have upcased filespec, so convert output to lower
6381        * case if input contained any lowercase characters. */
6382       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6383       PerlMem_free(trndir);
6384       PerlMem_free(esa);
6385       if (esal != NULL)
6386         PerlMem_free(esal);
6387       PerlMem_free(vmsdir);
6388       return buf;
6389     }
6390 }  /* end of int_fileify_dirspec() */
6391
6392
6393 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6394 static char *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 *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6426 { return do_fileify_dirspec(dir,buf,0,NULL); }
6427 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6428 { return do_fileify_dirspec(dir,buf,1,NULL); }
6429 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6430 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6431 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6432 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6433
6434 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6435     char * v_spec, int v_len, char * r_spec, int r_len,
6436     char * d_spec, int d_len, char * n_spec, int n_len,
6437     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6438
6439     /* VMS specification - Try to do this the simple way */
6440     if ((v_len + r_len > 0) || (d_len > 0)) {
6441         int is_dir;
6442
6443         /* No name or extension component, already a directory */
6444         if ((n_len + e_len + vs_len) == 0) {
6445             strcpy(buf, dir);
6446             return buf;
6447         }
6448
6449         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6450         /* This results from catfile() being used instead of catdir() */
6451         /* So even though it should not work, we need to allow it */
6452
6453         /* If this is .DIR;1 then do a simple conversion */
6454         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6455         if (is_dir || (e_len == 0) && (d_len > 0)) {
6456              int len;
6457              len = v_len + r_len + d_len - 1;
6458              char dclose = d_spec[d_len - 1];
6459              memcpy(buf, dir, len);
6460              buf[len] = '.';
6461              len++;
6462              memcpy(&buf[len], n_spec, n_len);
6463              len += n_len;
6464              buf[len] = dclose;
6465              buf[len + 1] = '\0';
6466              return buf;
6467         }
6468
6469 #ifdef HAS_SYMLINK
6470         else if (d_len > 0) {
6471             /* In the olden days, a directory needed to have a .DIR */
6472             /* extension to be a valid directory, but now it could  */
6473             /* be a symbolic link */
6474             int len;
6475             len = v_len + r_len + d_len - 1;
6476             char dclose = d_spec[d_len - 1];
6477             memcpy(buf, dir, len);
6478             buf[len] = '.';
6479             len++;
6480             memcpy(&buf[len], n_spec, n_len);
6481             len += n_len;
6482             if (e_len > 0) {
6483                 if (decc_efs_charset) {
6484                     if (e_len == 4
6485                         && (toupper(e_spec[1]) == 'D')
6486                         && (toupper(e_spec[2]) == 'I')
6487                         && (toupper(e_spec[3]) == 'R')) {
6488
6489                         /* Corner case: directory spec with invalid version.
6490                          * Valid would have followed is_dir path above.
6491                          */
6492                         SETERRNO(ENOTDIR, RMS$_DIR);
6493                         return NULL;
6494                     }
6495                     else {
6496                         buf[len] = '^';
6497                         len++;
6498                         memcpy(&buf[len], e_spec, e_len);
6499                         len += e_len;
6500                     }
6501                 }
6502                 else {
6503                     SETERRNO(ENOTDIR, RMS$_DIR);
6504                     return NULL;
6505                 }
6506             }
6507             buf[len] = dclose;
6508             buf[len + 1] = '\0';
6509             return buf;
6510         }
6511 #else
6512         else {
6513             set_vaxc_errno(RMS$_DIR);
6514             set_errno(ENOTDIR);
6515             return NULL;
6516         }
6517 #endif
6518     }
6519     set_vaxc_errno(RMS$_DIR);
6520     set_errno(ENOTDIR);
6521     return NULL;
6522 }
6523
6524
6525 /* Internal routine to make sure or convert a directory to be in a */
6526 /* path specification.  No utf8 flag because it is not changed or used */
6527 static char *int_pathify_dirspec(const char *dir, char *buf)
6528 {
6529     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6530     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6531     char * exp_spec, *ret_spec;
6532     char * trndir;
6533     unsigned short int trnlnm_iter_count;
6534     STRLEN trnlen;
6535     int need_to_lower;
6536
6537     if (vms_debug_fileify) {
6538         if (dir == NULL)
6539             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6540         else
6541             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6542     }
6543
6544     /* We may need to lower case the result if we translated  */
6545     /* a logical name or got the current working directory */
6546     need_to_lower = 0;
6547
6548     if (!dir || !*dir) {
6549       set_errno(EINVAL);
6550       set_vaxc_errno(SS$_BADPARAM);
6551       return NULL;
6552     }
6553
6554     trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
6555     if (trndir == NULL)
6556         _ckvmssts_noperl(SS$_INSFMEM);
6557
6558     /* If no directory specified use the current default */
6559     if (*dir)
6560         my_strlcpy(trndir, dir, VMS_MAXRSS);
6561     else {
6562         getcwd(trndir, VMS_MAXRSS - 1);
6563         need_to_lower = 1;
6564     }
6565
6566     /* now deal with bare names that could be logical names */
6567     trnlnm_iter_count = 0;
6568     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6569            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6570         trnlnm_iter_count++;
6571         need_to_lower = 1;
6572         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6573             break;
6574         trnlen = strlen(trndir);
6575
6576         /* Trap simple rooted lnms, and return lnm:[000000] */
6577         if (!strcmp(trndir+trnlen-2,".]")) {
6578             my_strlcpy(buf, dir, VMS_MAXRSS);
6579             strcat(buf, ":[000000]");
6580             PerlMem_free(trndir);
6581
6582             if (vms_debug_fileify) {
6583                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6584             }
6585             return buf;
6586         }
6587     }
6588
6589     /* At this point we do not work with *dir, but the copy in  *trndir */
6590
6591     if (need_to_lower && !decc_efs_case_preserve) {
6592         /* Legacy mode, lower case the returned value */
6593         __mystrtolower(trndir);
6594     }
6595
6596
6597     /* Some special cases, '..', '.' */
6598     sts = 0;
6599     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6600        /* Force UNIX filespec */
6601        sts = 1;
6602
6603     } else {
6604         /* Is this Unix or VMS format? */
6605         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6606                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6607                              &e_len, &vs_spec, &vs_len);
6608         if (sts == 0) {
6609
6610             /* Just a filename? */
6611             if ((v_len + r_len + d_len) == 0) {
6612
6613                 /* Now we have a problem, this could be Unix or VMS */
6614                 /* We have to guess.  .DIR usually means VMS */
6615
6616                 /* In UNIX report mode, the .DIR extension is removed */
6617                 /* if one shows up, it is for a non-directory or a directory */
6618                 /* in EFS charset mode */
6619
6620                 /* So if we are in Unix report mode, assume that this */
6621                 /* is a relative Unix directory specification */
6622
6623                 sts = 1;
6624                 if (!decc_filename_unix_report && decc_efs_charset) {
6625                     int is_dir;
6626                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6627
6628                     if (is_dir) {
6629                         /* Traditional mode, assume .DIR is directory */
6630                         buf[0] = '[';
6631                         buf[1] = '.';
6632                         memcpy(&buf[2], n_spec, n_len);
6633                         buf[n_len + 2] = ']';
6634                         buf[n_len + 3] = '\0';
6635                         PerlMem_free(trndir);
6636                         if (vms_debug_fileify) {
6637                             fprintf(stderr,
6638                                     "int_pathify_dirspec: buf = %s\n",
6639                                     buf);
6640                         }
6641                         return buf;
6642                     }
6643                 }
6644             }
6645         }
6646     }
6647     if (sts == 0) {
6648         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6649             v_spec, v_len, r_spec, r_len,
6650             d_spec, d_len, n_spec, n_len,
6651             e_spec, e_len, vs_spec, vs_len);
6652
6653         if (ret_spec != NULL) {
6654             PerlMem_free(trndir);
6655             if (vms_debug_fileify) {
6656                 fprintf(stderr,
6657                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6658             }
6659             return ret_spec;
6660         }
6661
6662         /* Simple way did not work, which means that a logical name */
6663         /* was present for the directory specification.             */
6664         /* Need to use an rmsexpand variant to decode it completely */
6665         exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
6666         if (exp_spec == NULL)
6667             _ckvmssts_noperl(SS$_INSFMEM);
6668
6669         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6670         if (ret_spec != NULL) {
6671             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6672                                  &r_spec, &r_len, &d_spec, &d_len,
6673                                  &n_spec, &n_len, &e_spec,
6674                                  &e_len, &vs_spec, &vs_len);
6675             if (sts == 0) {
6676                 ret_spec = int_pathify_dirspec_simple(
6677                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6678                     d_spec, d_len, n_spec, n_len,
6679                     e_spec, e_len, vs_spec, vs_len);
6680
6681                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6682                     /* Legacy mode, lower case the returned value */
6683                     __mystrtolower(ret_spec);
6684                 }
6685             } else {
6686                 set_vaxc_errno(RMS$_DIR);
6687                 set_errno(ENOTDIR);
6688                 ret_spec = NULL;
6689             }
6690         }
6691         PerlMem_free(exp_spec);
6692         PerlMem_free(trndir);
6693         if (vms_debug_fileify) {
6694             if (ret_spec == NULL)
6695                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6696             else
6697                 fprintf(stderr,
6698                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6699         }
6700         return ret_spec;
6701
6702     } else {
6703         /* Unix specification, Could be trivial conversion, */
6704         /* but have to deal with trailing '.dir' or extra '.' */
6705
6706         char * lastdot;
6707         char * lastslash;
6708         int is_dir;
6709         STRLEN dir_len = strlen(trndir);
6710
6711         lastslash = strrchr(trndir, '/');
6712         if (lastslash == NULL)
6713             lastslash = trndir;
6714         else
6715             lastslash++;
6716
6717         lastdot = NULL;
6718
6719         /* '..' or '.' are valid directory components */
6720         is_dir = 0;
6721         if (lastslash[0] == '.') {
6722             if (lastslash[1] == '\0') {
6723                is_dir = 1;
6724             } else if (lastslash[1] == '.') {
6725                 if (lastslash[2] == '\0') {
6726                     is_dir = 1;
6727                 } else {
6728                     /* And finally allow '...' */
6729                     if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6730                         is_dir = 1;
6731                     }
6732                 }
6733             }
6734         }
6735
6736         if (!is_dir) {
6737            lastdot = strrchr(lastslash, '.');
6738         }
6739         if (lastdot != NULL) {
6740             STRLEN e_len;
6741              /* '.dir' is discarded, and any other '.' is invalid */
6742             e_len = strlen(lastdot);
6743
6744             is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6745
6746             if (is_dir) {
6747                 dir_len = dir_len - 4;
6748             }
6749         }
6750
6751         my_strlcpy(buf, trndir, VMS_MAXRSS);
6752         if (buf[dir_len - 1] != '/') {
6753             buf[dir_len] = '/';
6754             buf[dir_len + 1] = '\0';
6755         }
6756
6757         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6758         if (!decc_efs_charset) {
6759              int dir_start = 0;
6760              char * str = buf;
6761              if (str[0] == '.') {
6762                  char * dots = str;
6763                  int cnt = 1;
6764                  while ((dots[cnt] == '.') && (cnt < 3))
6765                      cnt++;
6766                  if (cnt <= 3) {
6767                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6768                          dir_start = 1;
6769                          str += cnt;
6770                      }
6771                  }
6772              }
6773              for (; *str; ++str) {
6774                  while (*str == '/') {
6775                      dir_start = 1;
6776                      *str++;
6777                  }
6778                  if (dir_start) {
6779
6780                      /* Have to skip up to three dots which could be */
6781                      /* directories, 3 dots being a VMS extension for Perl */
6782                      char * dots = str;
6783                      int cnt = 0;
6784                      while ((dots[cnt] == '.') && (cnt < 3)) {
6785                          cnt++;
6786                      }
6787                      if (dots[cnt] == '\0')
6788                          break;
6789                      if ((cnt > 1) && (dots[cnt] != '/')) {
6790                          dir_start = 0;
6791                      } else {
6792                          str += cnt;
6793                      }
6794
6795                      /* too many dots? */
6796                      if ((cnt == 0) || (cnt > 3)) {
6797                          dir_start = 0;
6798                      }
6799                  }
6800                  if (!dir_start && (*str == '.')) {
6801                      *str = '_';
6802                  }
6803              }
6804         }
6805         PerlMem_free(trndir);
6806         ret_spec = buf;
6807         if (vms_debug_fileify) {
6808             if (ret_spec == NULL)
6809                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6810             else
6811                 fprintf(stderr,
6812                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6813         }
6814         return ret_spec;
6815     }
6816 }
6817
6818 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6819 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6820 {
6821     static char __pathify_retbuf[VMS_MAXRSS];
6822     char * pathified, *ret_spec, *ret_buf;
6823
6824     pathified = NULL;
6825     ret_buf = buf;
6826     if (ret_buf == NULL) {
6827         if (ts) {
6828             Newx(pathified, VMS_MAXRSS, char);
6829             if (pathified == NULL)
6830                 _ckvmssts(SS$_INSFMEM);
6831             ret_buf = pathified;
6832         } else {
6833             ret_buf = __pathify_retbuf;
6834         }
6835     }
6836
6837     ret_spec = int_pathify_dirspec(dir, ret_buf);
6838
6839     if (ret_spec == NULL) {
6840        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6841        if (pathified)
6842            Safefree(pathified);
6843     }
6844
6845     return ret_spec;
6846
6847 }  /* end of do_pathify_dirspec() */
6848
6849
6850 /* External entry points */
6851 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6852 { return do_pathify_dirspec(dir,buf,0,NULL); }
6853 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6854 { return do_pathify_dirspec(dir,buf,1,NULL); }
6855 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6856 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6857 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6858 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6859
6860 /* Internal tounixspec routine that does not use a thread context */
6861 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6862 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6863 {
6864   char *dirend, *cp1, *cp3, *tmp;
6865   const char *cp2;
6866   int dirlen;
6867   unsigned short int trnlnm_iter_count;
6868   int cmp_rslt, outchars_added;
6869   if (utf8_fl != NULL)
6870     *utf8_fl = 0;
6871
6872   if (vms_debug_fileify) {
6873       if (spec == NULL)
6874           fprintf(stderr, "int_tounixspec: spec = NULL\n");
6875       else
6876           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6877   }
6878
6879
6880   if (spec == NULL) {
6881       set_errno(EINVAL);
6882       set_vaxc_errno(SS$_BADPARAM);
6883       return NULL;
6884   }
6885   if (strlen(spec) > (VMS_MAXRSS-1)) {
6886       set_errno(E2BIG);
6887       set_vaxc_errno(SS$_BUFFEROVF);
6888       return NULL;
6889   }
6890
6891   /* New VMS specific format needs translation
6892    * glob passes filenames with trailing '\n' and expects this preserved.
6893    */
6894   if (decc_posix_compliant_pathnames) {
6895     if (strncmp(spec, "\"^UP^", 5) == 0) {
6896       char * uspec;
6897       char *tunix;
6898       int tunix_len;
6899       int nl_flag;
6900
6901       tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
6902       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6903       tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
6904       nl_flag = 0;
6905       if (tunix[tunix_len - 1] == '\n') {
6906         tunix[tunix_len - 1] = '\"';
6907         tunix[tunix_len] = '\0';
6908         tunix_len--;
6909         nl_flag = 1;
6910       }
6911       uspec = decc$translate_vms(tunix);
6912       PerlMem_free(tunix);
6913       if ((int)uspec > 0) {
6914         my_strlcpy(rslt, uspec, VMS_MAXRSS);
6915         if (nl_flag) {
6916           strcat(rslt,"\n");
6917         }
6918         else {
6919           /* If we can not translate it, makemaker wants as-is */
6920           my_strlcpy(rslt, spec, VMS_MAXRSS);
6921         }
6922         return rslt;
6923       }
6924     }
6925   }
6926
6927   cmp_rslt = 0; /* Presume VMS */
6928   cp1 = strchr(spec, '/');
6929   if (cp1 == NULL)
6930     cmp_rslt = 0;
6931
6932     /* Look for EFS ^/ */
6933     if (decc_efs_charset) {
6934       while (cp1 != NULL) {
6935         cp2 = cp1 - 1;
6936         if (*cp2 != '^') {
6937           /* Found illegal VMS, assume UNIX */
6938           cmp_rslt = 1;
6939           break;
6940         }
6941       cp1++;
6942       cp1 = strchr(cp1, '/');
6943     }
6944   }
6945
6946   /* Look for "." and ".." */
6947   if (decc_filename_unix_report) {
6948     if (spec[0] == '.') {
6949       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6950         cmp_rslt = 1;
6951       }
6952       else {
6953         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6954           cmp_rslt = 1;
6955         }
6956       }
6957     }
6958   }
6959
6960   cp1 = rslt;
6961   cp2 = spec;
6962
6963   /* This is already UNIX or at least nothing VMS understands,
6964    * so all we can reasonably do is unescape extended chars.
6965    */
6966   if (cmp_rslt) {
6967     while (*cp2) {
6968         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
6969         cp1 += outchars_added;
6970     }
6971     *cp1 = '\0';
6972     if (vms_debug_fileify) {
6973         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6974     }
6975     return rslt;
6976   }
6977
6978   dirend = strrchr(spec,']');
6979   if (dirend == NULL) dirend = strrchr(spec,'>');
6980   if (dirend == NULL) dirend = strchr(spec,':');
6981   if (dirend == NULL) {
6982     while (*cp2) {
6983         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
6984         cp1 += outchars_added;
6985     }
6986     *cp1 = '\0';
6987     if (vms_debug_fileify) {
6988         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6989     }
6990     return rslt;
6991   }
6992
6993   /* Special case 1 - sys$posix_root = / */
6994   if (!decc_disable_posix_root) {
6995     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6996       *cp1 = '/';
6997       cp1++;
6998       cp2 = cp2 + 15;
6999       }
7000   }
7001
7002   /* Special case 2 - Convert NLA0: to /dev/null */
7003   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7004   if (cmp_rslt == 0) {
7005     strcpy(rslt, "/dev/null");
7006     cp1 = cp1 + 9;
7007     cp2 = cp2 + 5;
7008     if (spec[6] != '\0') {
7009       cp1[9] = '/';
7010       cp1++;
7011       cp2++;
7012     }
7013   }
7014
7015    /* Also handle special case "SYS$SCRATCH:" */
7016   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7017   tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
7018   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7019   if (cmp_rslt == 0) {
7020   int islnm;
7021
7022     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7023     if (!islnm) {
7024       strcpy(rslt, "/tmp");
7025       cp1 = cp1 + 4;
7026       cp2 = cp2 + 12;
7027       if (spec[12] != '\0') {
7028         cp1[4] = '/';
7029         cp1++;
7030         cp2++;
7031       }
7032     }
7033   }
7034
7035   if (*cp2 != '[' && *cp2 != '<') {
7036     *(cp1++) = '/';
7037   }
7038   else {  /* the VMS spec begins with directories */
7039     cp2++;
7040     if (*cp2 == ']' || *cp2 == '>') {
7041       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7042       PerlMem_free(tmp);
7043       return rslt;
7044     }
7045     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7046       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7047         PerlMem_free(tmp);
7048         if (vms_debug_fileify) {
7049             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7050         }
7051         return NULL;
7052       }
7053       trnlnm_iter_count = 0;
7054       do {
7055         cp3 = tmp;
7056         while (*cp3 != ':' && *cp3) cp3++;
7057         *(cp3++) = '\0';
7058         if (strchr(cp3,']') != NULL) break;
7059         trnlnm_iter_count++;
7060         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7061       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7062       cp1 = rslt;
7063       cp3 = tmp;
7064       *(cp1++) = '/';
7065       while (*cp3) {
7066         *(cp1++) = *(cp3++);
7067         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7068             PerlMem_free(tmp);
7069             set_errno(ENAMETOOLONG);
7070             set_vaxc_errno(SS$_BUFFEROVF);
7071             if (vms_debug_fileify) {
7072                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7073             }
7074             return NULL; /* No room */
7075         }
7076       }
7077       *(cp1++) = '/';
7078     }
7079     if ((*cp2 == '^')) {
7080         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7081         cp1 += outchars_added;
7082     }
7083     else if ( *cp2 == '.') {
7084       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7085         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7086         cp2 += 3;
7087       }
7088       else cp2++;
7089     }
7090   }
7091   PerlMem_free(tmp);
7092   for (; cp2 <= dirend; cp2++) {
7093     if ((*cp2 == '^')) {
7094         /* EFS file escape, pass the next character as is */
7095         /* Fix me: HEX encoding for Unicode not implemented */
7096         *(cp1++) = *(++cp2);
7097         /* An escaped dot stays as is -- don't convert to slash */
7098         if (*cp2 == '.') cp2++;
7099     }
7100     if (*cp2 == ':') {
7101       *(cp1++) = '/';
7102       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7103     }
7104     else if (*cp2 == ']' || *cp2 == '>') {
7105       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7106     }
7107     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7108       *(cp1++) = '/';
7109       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7110         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7111                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7112         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7113             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7114       }
7115       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7116         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7117         cp2 += 2;
7118       }
7119     }
7120     else if (*cp2 == '-') {
7121       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7122         while (*cp2 == '-') {
7123           cp2++;
7124           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7125         }
7126         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7127                                                          /* filespecs like */
7128           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7129           if (vms_debug_fileify) {
7130               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7131           }
7132           return NULL;
7133         }
7134       }
7135       else *(cp1++) = *cp2;
7136     }
7137     else *(cp1++) = *cp2;
7138   }
7139   /* Translate the rest of the filename. */
7140   while (*cp2) {
7141       int dot_seen = 0;
7142       switch(*cp2) {
7143       /* Fixme - for compatibility with the CRTL we should be removing */
7144       /* spaces from the file specifications, but this may show that */
7145       /* some tests that were appearing to pass are not really passing */
7146       case '%':
7147           cp2++;
7148           *(cp1++) = '?';
7149           break;
7150       case '^':
7151           cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7152           cp1 += outchars_added;
7153           break;
7154       case ';':
7155           if (decc_filename_unix_no_version) {
7156               /* Easy, drop the version */
7157               while (*cp2)
7158                   cp2++;
7159               break;
7160           } else {
7161               /* Punt - passing the version as a dot will probably */
7162               /* break perl in weird ways, but so did passing */
7163               /* through the ; as a version.  Follow the CRTL and */
7164               /* hope for the best. */
7165               cp2++;
7166               *(cp1++) = '.';
7167           }
7168           break;
7169       case '.':
7170           if (dot_seen) {
7171               /* We will need to fix this properly later */
7172               /* As Perl may be installed on an ODS-5 volume, but not */
7173               /* have the EFS_CHARSET enabled, it still may encounter */
7174               /* filenames with extra dots in them, and a precedent got */
7175               /* set which allowed them to work, that we will uphold here */
7176               /* If extra dots are present in a name and no ^ is on them */
7177               /* VMS assumes that the first one is the extension delimiter */
7178               /* the rest have an implied ^. */
7179
7180               /* this is also a conflict as the . is also a version */
7181               /* delimiter in VMS, */
7182
7183               *(cp1++) = *(cp2++);
7184               break;
7185           }
7186           dot_seen = 1;
7187           /* This is an extension */
7188           if (decc_readdir_dropdotnotype) {
7189               cp2++;
7190               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7191                   /* Drop the dot for the extension */
7192                   break;
7193               } else {
7194                   *(cp1++) = '.';
7195               }
7196               break;
7197           }
7198       default:
7199           *(cp1++) = *(cp2++);
7200       }
7201   }
7202   *cp1 = '\0';
7203
7204   /* This still leaves /000000/ when working with a
7205    * VMS device root or concealed root.
7206    */
7207   {
7208   int ulen;
7209   char * zeros;
7210
7211       ulen = strlen(rslt);
7212
7213       /* Get rid of "000000/ in rooted filespecs */
7214       if (ulen > 7) {
7215         zeros = strstr(rslt, "/000000/");
7216         if (zeros != NULL) {
7217           int mlen;
7218           mlen = ulen - (zeros - rslt) - 7;
7219           memmove(zeros, &zeros[7], mlen);
7220           ulen = ulen - 7;
7221           rslt[ulen] = '\0';
7222         }
7223       }
7224   }
7225
7226   if (vms_debug_fileify) {
7227       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7228   }
7229   return rslt;
7230
7231 }  /* end of int_tounixspec() */
7232
7233
7234 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7235 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7236 {
7237     static char __tounixspec_retbuf[VMS_MAXRSS];
7238     char * unixspec, *ret_spec, *ret_buf;
7239
7240     unixspec = NULL;
7241     ret_buf = buf;
7242     if (ret_buf == NULL) {
7243         if (ts) {
7244             Newx(unixspec, VMS_MAXRSS, char);
7245             if (unixspec == NULL)
7246                 _ckvmssts(SS$_INSFMEM);
7247             ret_buf = unixspec;
7248         } else {
7249             ret_buf = __tounixspec_retbuf;
7250         }
7251     }
7252
7253     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7254
7255     if (ret_spec == NULL) {
7256        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7257        if (unixspec)
7258            Safefree(unixspec);
7259     }
7260
7261     return ret_spec;
7262
7263 }  /* end of do_tounixspec() */
7264 /*}}}*/
7265 /* External entry points */
7266 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7267   { return do_tounixspec(spec,buf,0, NULL); }
7268 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7269   { return do_tounixspec(spec,buf,1, NULL); }
7270 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7271   { return do_tounixspec(spec,buf,0, utf8_fl); }
7272 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7273   { return do_tounixspec(spec,buf,1, utf8_fl); }
7274
7275 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7276
7277 /*
7278  This procedure is used to identify if a path is based in either
7279  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7280  it returns the OpenVMS format directory for it.
7281
7282  It is expecting specifications of only '/' or '/xxxx/'
7283
7284  If a posix root does not exist, or 'xxxx' is not a directory
7285  in the posix root, it returns a failure.
7286
7287  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7288
7289  It is used only internally by posix_to_vmsspec_hardway().
7290  */
7291
7292 static int posix_root_to_vms
7293   (char *vmspath, int vmspath_len,
7294    const char *unixpath,
7295    const int * utf8_fl)
7296 {
7297 int sts;
7298 struct FAB myfab = cc$rms_fab;
7299 rms_setup_nam(mynam);
7300 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7301 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7302 char * esa, * esal, * rsa, * rsal;
7303 int dir_flag;
7304 int unixlen;
7305
7306     dir_flag = 0;
7307     vmspath[0] = '\0';
7308     unixlen = strlen(unixpath);
7309     if (unixlen == 0) {
7310       return RMS$_FNF;
7311     }
7312
7313 #if __CRTL_VER >= 80200000
7314   /* If not a posix spec already, convert it */
7315   if (decc_posix_compliant_pathnames) {
7316     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7317       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7318     }
7319     else {
7320       /* This is already a VMS specification, no conversion */
7321       unixlen--;
7322       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7323     }
7324   }
7325   else
7326 #endif
7327   {
7328   int path_len;
7329   int i,j;
7330
7331      /* Check to see if this is under the POSIX root */
7332      if (decc_disable_posix_root) {
7333         return RMS$_FNF;
7334      }
7335
7336      /* Skip leading / */
7337      if (unixpath[0] == '/') {
7338         unixpath++;
7339         unixlen--;
7340      }
7341
7342
7343      strcpy(vmspath,"SYS$POSIX_ROOT:");
7344
7345      /* If this is only the / , or blank, then... */
7346      if (unixpath[0] == '\0') {
7347         /* by definition, this is the answer */
7348         return SS$_NORMAL;
7349      }
7350
7351      /* Need to look up a directory */
7352      vmspath[15] = '[';
7353      vmspath[16] = '\0';
7354
7355      /* Copy and add '^' escape characters as needed */
7356      j = 16;
7357      i = 0;
7358      while (unixpath[i] != 0) {
7359      int k;
7360
7361         j += copy_expand_unix_filename_escape
7362             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7363         i += k;
7364      }
7365
7366      path_len = strlen(vmspath);
7367      if (vmspath[path_len - 1] == '/')
7368         path_len--;
7369      vmspath[path_len] = ']';
7370      path_len++;
7371      vmspath[path_len] = '\0';
7372
7373   }
7374   vmspath[vmspath_len] = 0;
7375   if (unixpath[unixlen - 1] == '/')
7376   dir_flag = 1;
7377   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7378   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7379   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7380   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7381   rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7382   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7383   rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7384   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7385   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7386   rms_bind_fab_nam(myfab, mynam);
7387   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7388   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7389   if (decc_efs_case_preserve)
7390     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7391 #ifdef NAML$M_OPEN_SPECIAL
7392   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7393 #endif
7394
7395   /* Set up the remaining naml fields */
7396   sts = sys$parse(&myfab);
7397
7398   /* It failed! Try again as a UNIX filespec */
7399   if (!(sts & 1)) {
7400     PerlMem_free(esal);
7401     PerlMem_free(esa);
7402     PerlMem_free(rsal);
7403     PerlMem_free(rsa);
7404     return sts;
7405   }
7406
7407    /* get the Device ID and the FID */
7408    sts = sys$search(&myfab);
7409
7410    /* These are no longer needed */
7411    PerlMem_free(esa);
7412    PerlMem_free(rsal);
7413    PerlMem_free(rsa);
7414
7415    /* on any failure, returned the POSIX ^UP^ filespec */
7416    if (!(sts & 1)) {
7417       PerlMem_free(esal);
7418       return sts;
7419    }
7420    specdsc.dsc$a_pointer = vmspath;
7421    specdsc.dsc$w_length = vmspath_len;
7422
7423    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7424    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7425    sts = lib$fid_to_name
7426       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7427
7428   /* on any failure, returned the POSIX ^UP^ filespec */
7429   if (!(sts & 1)) {
7430      /* This can happen if user does not have permission to read directories */
7431      if (strncmp(unixpath,"\"^UP^",5) != 0)
7432        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7433      else
7434        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7435   }
7436   else {
7437     vmspath[specdsc.dsc$w_length] = 0;
7438
7439     /* Are we expecting a directory? */
7440     if (dir_flag != 0) {
7441     int i;
7442     char *eptr;
7443
7444       eptr = NULL;
7445
7446       i = specdsc.dsc$w_length - 1;
7447       while (i > 0) {
7448       int zercnt;
7449         zercnt = 0;
7450         /* Version must be '1' */
7451         if (vmspath[i--] != '1')
7452           break;
7453         /* Version delimiter is one of ".;" */
7454         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7455           break;
7456         i--;
7457         if (vmspath[i--] != 'R')
7458           break;
7459         if (vmspath[i--] != 'I')
7460           break;
7461         if (vmspath[i--] != 'D')
7462           break;
7463         if (vmspath[i--] != '.')
7464           break;
7465         eptr = &vmspath[i+1];
7466         while (i > 0) {
7467           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7468             if (vmspath[i-1] != '^') {
7469               if (zercnt != 6) {
7470                 *eptr = vmspath[i];
7471                 eptr[1] = '\0';
7472                 vmspath[i] = '.';
7473                 break;
7474               }
7475               else {
7476                 /* Get rid of 6 imaginary zero directory filename */
7477                 vmspath[i+1] = '\0';
7478               }
7479             }
7480           }
7481           if (vmspath[i] == '0')
7482             zercnt++;
7483           else
7484             zercnt = 10;
7485           i--;
7486         }
7487         break;
7488       }
7489     }
7490   }
7491   PerlMem_free(esal);
7492   return sts;
7493 }
7494
7495 /* /dev/mumble needs to be handled special.
7496    /dev/null becomes NLA0:, And there is the potential for other stuff
7497    like /dev/tty which may need to be mapped to something.
7498 */
7499
7500 static int
7501 slash_dev_special_to_vms
7502    (const char * unixptr,
7503     char * vmspath,
7504     int vmspath_len)
7505 {
7506 char * nextslash;
7507 int len;
7508 int cmp;
7509
7510     unixptr += 4;
7511     nextslash = strchr(unixptr, '/');
7512     len = strlen(unixptr);
7513     if (nextslash != NULL)
7514         len = nextslash - unixptr;
7515     cmp = strncmp("null", unixptr, 5);
7516     if (cmp == 0) {
7517         if (vmspath_len >= 6) {
7518             strcpy(vmspath, "_NLA0:");
7519             return SS$_NORMAL;
7520         }
7521     }
7522     return 0;
7523 }
7524
7525
7526 /* The built in routines do not understand perl's special needs, so
7527     doing a manual conversion from UNIX to VMS
7528
7529     If the utf8_fl is not null and points to a non-zero value, then
7530     treat 8 bit characters as UTF-8.
7531
7532     The sequence starting with '$(' and ending with ')' will be passed
7533     through with out interpretation instead of being escaped.
7534
7535   */
7536 static int posix_to_vmsspec_hardway
7537   (char *vmspath, int vmspath_len,
7538    const char *unixpath,
7539    int dir_flag,
7540    int * utf8_fl) {
7541
7542 char *esa;
7543 const char *unixptr;
7544 const char *unixend;
7545 char *vmsptr;
7546 const char *lastslash;
7547 const char *lastdot;
7548 int unixlen;
7549 int vmslen;
7550 int dir_start;
7551 int dir_dot;
7552 int quoted;
7553 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7554 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7555
7556   if (utf8_fl != NULL)
7557     *utf8_fl = 0;
7558
7559   unixptr = unixpath;
7560   dir_dot = 0;
7561
7562   /* Ignore leading "/" characters */
7563   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7564     unixptr++;
7565   }
7566   unixlen = strlen(unixptr);
7567
7568   /* Do nothing with blank paths */
7569   if (unixlen == 0) {
7570     vmspath[0] = '\0';
7571     return SS$_NORMAL;
7572   }
7573
7574   quoted = 0;
7575   /* This could have a "^UP^ on the front */
7576   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7577     quoted = 1;
7578     unixptr+= 5;
7579     unixlen-= 5;
7580   }
7581
7582   lastslash = strrchr(unixptr,'/');
7583   lastdot = strrchr(unixptr,'.');
7584   unixend = strrchr(unixptr,'\"');
7585   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7586     unixend = unixptr + unixlen;
7587   }
7588
7589   /* last dot is last dot or past end of string */
7590   if (lastdot == NULL)
7591     lastdot = unixptr + unixlen;
7592
7593   /* if no directories, set last slash to beginning of string */
7594   if (lastslash == NULL) {
7595     lastslash = unixptr;
7596   }
7597   else {
7598     /* Watch out for trailing "." after last slash, still a directory */
7599     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7600       lastslash = unixptr + unixlen;
7601     }
7602
7603     /* Watch out for trailing ".." after last slash, still a directory */
7604     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7605       lastslash = unixptr + unixlen;
7606     }
7607
7608     /* dots in directories are aways escaped */
7609     if (lastdot < lastslash)
7610       lastdot = unixptr + unixlen;
7611   }
7612
7613   /* if (unixptr < lastslash) then we are in a directory */
7614
7615   dir_start = 0;
7616
7617   vmsptr = vmspath;
7618   vmslen = 0;
7619
7620   /* Start with the UNIX path */
7621   if (*unixptr != '/') {
7622     /* relative paths */
7623
7624     /* If allowing logical names on relative pathnames, then handle here */
7625     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7626         !decc_posix_compliant_pathnames) {
7627     char * nextslash;
7628     int seg_len;
7629     char * trn;
7630     int islnm;
7631
7632         /* Find the next slash */
7633         nextslash = strchr(unixptr,'/');
7634
7635         esa = (char *)PerlMem_malloc(vmspath_len);
7636         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7637
7638         trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7639         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7640
7641         if (nextslash != NULL) {
7642
7643             seg_len = nextslash - unixptr;
7644             memcpy(esa, unixptr, seg_len);
7645             esa[seg_len] = 0;
7646         }
7647         else {
7648             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7649         }
7650         /* trnlnm(section) */
7651         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7652
7653         if (islnm) {
7654             /* Now fix up the directory */
7655
7656             /* Split up the path to find the components */
7657             sts = vms_split_path
7658                   (trn,
7659                    &v_spec,
7660                    &v_len,
7661                    &r_spec,
7662                    &r_len,
7663                    &d_spec,
7664                    &d_len,
7665                    &n_spec,
7666                    &n_len,
7667                    &e_spec,
7668                    &e_len,
7669                    &vs_spec,
7670                    &vs_len);
7671
7672             while (sts == 0) {
7673             int cmp;
7674
7675                 /* A logical name must be a directory  or the full
7676                    specification.  It is only a full specification if
7677                    it is the only component */
7678                 if ((unixptr[seg_len] == '\0') ||
7679                     (unixptr[seg_len+1] == '\0')) {
7680
7681                     /* Is a directory being required? */
7682                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7683                         /* Not a logical name */
7684                         break;
7685                     }
7686
7687
7688                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7689                         /* This must be a directory */
7690                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7691                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7692                             vmsptr[vmslen] = ':';
7693                             vmslen++;
7694                             vmsptr[vmslen] = '\0';
7695                             return SS$_NORMAL;
7696                         }
7697                     }
7698
7699                 }
7700
7701
7702                 /* must be dev/directory - ignore version */
7703                 if ((n_len + e_len) != 0)
7704                     break;
7705
7706                 /* transfer the volume */
7707                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7708                     memcpy(vmsptr, v_spec, v_len);
7709                     vmsptr += v_len;
7710                     vmsptr[0] = '\0';
7711                     vmslen += v_len;
7712                 }
7713
7714                 /* unroot the rooted directory */
7715                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7716                     r_spec[0] = '[';
7717                     r_spec[r_len - 1] = ']';
7718
7719                     /* This should not be there, but nothing is perfect */
7720                     if (r_len > 9) {
7721                         cmp = strcmp(&r_spec[1], "000000.");
7722                         if (cmp == 0) {
7723                             r_spec += 7;
7724                             r_spec[7] = '[';
7725                             r_len -= 7;
7726                             if (r_len == 2)
7727                                 r_len = 0;
7728                         }
7729                     }
7730                     if (r_len > 0) {
7731                         memcpy(vmsptr, r_spec, r_len);
7732                         vmsptr += r_len;
7733                         vmslen += r_len;
7734                         vmsptr[0] = '\0';
7735                     }
7736                 }
7737                 /* Bring over the directory. */
7738                 if ((d_len > 0) &&
7739                     ((d_len + vmslen) < vmspath_len)) {
7740                     d_spec[0] = '[';
7741                     d_spec[d_len - 1] = ']';
7742                     if (d_len > 9) {
7743                         cmp = strcmp(&d_spec[1], "000000.");
7744                         if (cmp == 0) {
7745                             d_spec += 7;
7746                             d_spec[7] = '[';
7747                             d_len -= 7;
7748                             if (d_len == 2)
7749                                 d_len = 0;
7750                         }
7751                     }
7752
7753                     if (r_len > 0) {
7754                         /* Remove the redundant root */
7755                         if (r_len > 0) {
7756                             /* remove the ][ */
7757                             vmsptr--;
7758                             vmslen--;
7759                             d_spec++;
7760                             d_len--;
7761                         }
7762                         memcpy(vmsptr, d_spec, d_len);
7763                             vmsptr += d_len;
7764                             vmslen += d_len;
7765                             vmsptr[0] = '\0';
7766                     }
7767                 }
7768                 break;
7769             }
7770         }
7771
7772         PerlMem_free(esa);
7773         PerlMem_free(trn);
7774     }
7775
7776     if (lastslash > unixptr) {
7777     int dotdir_seen;
7778
7779       /* skip leading ./ */
7780       dotdir_seen = 0;
7781       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7782         dotdir_seen = 1;
7783         unixptr++;
7784         unixptr++;
7785       }
7786
7787       /* Are we still in a directory? */
7788       if (unixptr <= lastslash) {
7789         *vmsptr++ = '[';
7790         vmslen = 1;
7791         dir_start = 1;
7792
7793         /* if not backing up, then it is relative forward. */
7794         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7795               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7796           *vmsptr++ = '.';
7797           vmslen++;
7798           dir_dot = 1;
7799           }
7800        }
7801        else {
7802          if (dotdir_seen) {
7803            /* Perl wants an empty directory here to tell the difference
7804             * between a DCL command and a filename
7805             */
7806           *vmsptr++ = '[';
7807           *vmsptr++ = ']';
7808           vmslen = 2;
7809         }
7810       }
7811     }
7812     else {
7813       /* Handle two special files . and .. */
7814       if (unixptr[0] == '.') {
7815         if (&unixptr[1] == unixend) {
7816           *vmsptr++ = '[';
7817           *vmsptr++ = ']';
7818           vmslen += 2;
7819           *vmsptr++ = '\0';
7820           return SS$_NORMAL;
7821         }
7822         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7823           *vmsptr++ = '[';
7824           *vmsptr++ = '-';
7825           *vmsptr++ = ']';
7826           vmslen += 3;
7827           *vmsptr++ = '\0';
7828           return SS$_NORMAL;
7829         }
7830       }
7831     }
7832   }
7833   else {        /* Absolute PATH handling */
7834   int sts;
7835   char * nextslash;
7836   int seg_len;
7837     /* Need to find out where root is */
7838
7839     /* In theory, this procedure should never get an absolute POSIX pathname
7840      * that can not be found on the POSIX root.
7841      * In practice, that can not be relied on, and things will show up
7842      * here that are a VMS device name or concealed logical name instead.
7843      * So to make things work, this procedure must be tolerant.
7844      */
7845     esa = (char *)PerlMem_malloc(vmspath_len);
7846     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7847
7848     sts = SS$_NORMAL;
7849     nextslash = strchr(&unixptr[1],'/');
7850     seg_len = 0;
7851     if (nextslash != NULL) {
7852       int cmp;
7853       seg_len = nextslash - &unixptr[1];
7854       my_strlcpy(vmspath, unixptr, seg_len + 2);
7855       cmp = 1;
7856       if (seg_len == 3) {
7857         cmp = strncmp(vmspath, "dev", 4);
7858         if (cmp == 0) {
7859             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7860             if (sts == SS$_NORMAL)
7861                 return SS$_NORMAL;
7862         }
7863       }
7864       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7865     }
7866
7867     if ($VMS_STATUS_SUCCESS(sts)) {
7868       /* This is verified to be a real path */
7869
7870       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7871       if ($VMS_STATUS_SUCCESS(sts)) {
7872         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
7873         vmsptr = vmspath + vmslen;
7874         unixptr++;
7875         if (unixptr < lastslash) {
7876         char * rptr;
7877           vmsptr--;
7878           *vmsptr++ = '.';
7879           dir_start = 1;
7880           dir_dot = 1;
7881           if (vmslen > 7) {
7882           int cmp;
7883             rptr = vmsptr - 7;
7884             cmp = strcmp(rptr,"000000.");
7885             if (cmp == 0) {
7886               vmslen -= 7;
7887               vmsptr -= 7;
7888               vmsptr[1] = '\0';
7889             } /* removing 6 zeros */
7890           } /* vmslen < 7, no 6 zeros possible */
7891         } /* Not in a directory */
7892       } /* Posix root found */
7893       else {
7894         /* No posix root, fall back to default directory */
7895         strcpy(vmspath, "SYS$DISK:[");
7896         vmsptr = &vmspath[10];
7897         vmslen = 10;
7898         if (unixptr > lastslash) {
7899            *vmsptr = ']';
7900            vmsptr++;
7901            vmslen++;
7902         }
7903         else {
7904            dir_start = 1;
7905         }
7906       }
7907     } /* end of verified real path handling */
7908     else {
7909     int add_6zero;
7910     int islnm;
7911
7912       /* Ok, we have a device or a concealed root that is not in POSIX
7913        * or we have garbage.  Make the best of it.
7914        */
7915
7916       /* Posix to VMS destroyed this, so copy it again */
7917       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
7918       vmslen = strlen(vmspath); /* We know we're truncating. */
7919       vmsptr = &vmsptr[vmslen];
7920       islnm = 0;
7921
7922       /* Now do we need to add the fake 6 zero directory to it? */
7923       add_6zero = 1;
7924       if ((*lastslash == '/') && (nextslash < lastslash)) {
7925         /* No there is another directory */
7926         add_6zero = 0;
7927       }
7928       else {
7929       int trnend;
7930       int cmp;
7931
7932         /* now we have foo:bar or foo:[000000]bar to decide from */
7933         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7934
7935         if (!islnm && !decc_posix_compliant_pathnames) {
7936
7937             cmp = strncmp("bin", vmspath, 4);
7938             if (cmp == 0) {
7939                 /* bin => SYS$SYSTEM: */
7940                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7941             }
7942             else {
7943                 /* tmp => SYS$SCRATCH: */
7944                 cmp = strncmp("tmp", vmspath, 4);
7945                 if (cmp == 0) {
7946                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7947                 }
7948             }
7949         }
7950
7951         trnend = islnm ? islnm - 1 : 0;
7952
7953         /* if this was a logical name, ']' or '>' must be present */
7954         /* if not a logical name, then assume a device and hope. */
7955         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7956
7957         /* if log name and trailing '.' then rooted - treat as device */
7958         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7959
7960         /* Fix me, if not a logical name, a device lookup should be
7961          * done to see if the device is file structured.  If the device
7962          * is not file structured, the 6 zeros should not be put on.
7963          *
7964          * As it is, perl is occasionally looking for dev:[000000]tty.
7965          * which looks a little strange.
7966          *
7967          * Not that easy to detect as "/dev" may be file structured with
7968          * special device files.
7969          */
7970
7971         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
7972             (&nextslash[1] == unixend)) {
7973           /* No real directory present */
7974           add_6zero = 1;
7975         }
7976       }
7977
7978       /* Put the device delimiter on */
7979       *vmsptr++ = ':';
7980       vmslen++;
7981       unixptr = nextslash;
7982       unixptr++;
7983
7984       /* Start directory if needed */
7985       if (!islnm || add_6zero) {
7986         *vmsptr++ = '[';
7987         vmslen++;
7988         dir_start = 1;
7989       }
7990
7991       /* add fake 000000] if needed */
7992       if (add_6zero) {
7993         *vmsptr++ = '0';
7994         *vmsptr++ = '0';
7995         *vmsptr++ = '0';
7996         *vmsptr++ = '0';
7997         *vmsptr++ = '0';
7998         *vmsptr++ = '0';
7999         *vmsptr++ = ']';
8000         vmslen += 7;
8001         dir_start = 0;
8002       }
8003
8004     } /* non-POSIX translation */
8005     PerlMem_free(esa);
8006   } /* End of relative/absolute path handling */
8007
8008   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8009   int dash_flag;
8010   int in_cnt;
8011   int out_cnt;
8012
8013     dash_flag = 0;
8014
8015     if (dir_start != 0) {
8016
8017       /* First characters in a directory are handled special */
8018       while ((*unixptr == '/') ||
8019              ((*unixptr == '.') &&
8020               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8021                 (&unixptr[1]==unixend)))) {
8022       int loop_flag;
8023
8024         loop_flag = 0;
8025
8026         /* Skip redundant / in specification */
8027         while ((*unixptr == '/') && (dir_start != 0)) {
8028           loop_flag = 1;
8029           unixptr++;
8030           if (unixptr == lastslash)
8031             break;
8032         }
8033         if (unixptr == lastslash)
8034           break;
8035
8036         /* Skip redundant ./ characters */
8037         while ((*unixptr == '.') &&
8038                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8039           loop_flag = 1;
8040           unixptr++;
8041           if (unixptr == lastslash)
8042             break;
8043           if (*unixptr == '/')
8044             unixptr++;
8045         }
8046         if (unixptr == lastslash)
8047           break;
8048
8049         /* Skip redundant ../ characters */
8050         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8051              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8052           /* Set the backing up flag */
8053           loop_flag = 1;
8054           dir_dot = 0;
8055           dash_flag = 1;
8056           *vmsptr++ = '-';
8057           vmslen++;
8058           unixptr++; /* first . */
8059           unixptr++; /* second . */
8060           if (unixptr == lastslash)
8061             break;
8062           if (*unixptr == '/') /* The slash */
8063             unixptr++;
8064         }
8065         if (unixptr == lastslash)
8066           break;
8067
8068         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8069         /* Not needed when VMS is pretending to be UNIX. */
8070
8071         /* Is this loop stuck because of too many dots? */
8072         if (loop_flag == 0) {
8073           /* Exit the loop and pass the rest through */
8074           break;
8075         }
8076       }
8077
8078       /* Are we done with directories yet? */
8079       if (unixptr >= lastslash) {
8080
8081         /* Watch out for trailing dots */
8082         if (dir_dot != 0) {
8083             vmslen --;
8084             vmsptr--;
8085         }
8086         *vmsptr++ = ']';
8087         vmslen++;
8088         dash_flag = 0;
8089         dir_start = 0;
8090         if (*unixptr == '/')
8091           unixptr++;
8092       }
8093       else {
8094         /* Have we stopped backing up? */
8095         if (dash_flag) {
8096           *vmsptr++ = '.';
8097           vmslen++;
8098           dash_flag = 0;
8099           /* dir_start continues to be = 1 */
8100         }
8101         if (*unixptr == '-') {
8102           *vmsptr++ = '^';
8103           *vmsptr++ = *unixptr++;
8104           vmslen += 2;
8105           dir_start = 0;
8106
8107           /* Now are we done with directories yet? */
8108           if (unixptr >= lastslash) {
8109
8110             /* Watch out for trailing dots */
8111             if (dir_dot != 0) {
8112               vmslen --;
8113               vmsptr--;
8114             }
8115
8116             *vmsptr++ = ']';
8117             vmslen++;
8118             dash_flag = 0;
8119             dir_start = 0;
8120           }
8121         }
8122       }
8123     }
8124
8125     /* All done? */
8126     if (unixptr >= unixend)
8127       break;
8128
8129     /* Normal characters - More EFS work probably needed */
8130     dir_start = 0;
8131     dir_dot = 0;
8132
8133     switch(*unixptr) {
8134     case '/':
8135         /* remove multiple / */
8136         while (unixptr[1] == '/') {
8137            unixptr++;
8138         }
8139         if (unixptr == lastslash) {
8140           /* Watch out for trailing dots */
8141           if (dir_dot != 0) {
8142             vmslen --;
8143             vmsptr--;
8144           }
8145           *vmsptr++ = ']';
8146         }
8147         else {
8148           dir_start = 1;
8149           *vmsptr++ = '.';
8150           dir_dot = 1;
8151
8152           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8153           /* Not needed when VMS is pretending to be UNIX. */
8154
8155         }
8156         dash_flag = 0;
8157         if (unixptr != unixend)
8158           unixptr++;
8159         vmslen++;
8160         break;
8161     case '.':
8162         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8163             (&unixptr[1] == unixend)) {
8164           *vmsptr++ = '^';
8165           *vmsptr++ = '.';
8166           vmslen += 2;
8167           unixptr++;
8168
8169           /* trailing dot ==> '^..' on VMS */
8170           if (unixptr == unixend) {
8171             *vmsptr++ = '.';
8172             vmslen++;
8173             unixptr++;
8174           }
8175           break;
8176         }
8177
8178         *vmsptr++ = *unixptr++;
8179         vmslen ++;
8180         break;
8181     case '"':
8182         if (quoted && (&unixptr[1] == unixend)) {
8183             unixptr++;
8184             break;
8185         }
8186         in_cnt = copy_expand_unix_filename_escape
8187                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8188         vmsptr += out_cnt;
8189         unixptr += in_cnt;
8190         break;
8191     case '~':
8192     case ';':
8193     case '\\':
8194     case '?':
8195     case ' ':
8196     default:
8197         in_cnt = copy_expand_unix_filename_escape
8198                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8199         vmsptr += out_cnt;
8200         unixptr += in_cnt;
8201         break;
8202     }
8203   }
8204
8205   /* Make sure directory is closed */
8206   if (unixptr == lastslash) {
8207     char *vmsptr2;
8208     vmsptr2 = vmsptr - 1;
8209
8210     if (*vmsptr2 != ']') {
8211       *vmsptr2--;
8212
8213       /* directories do not end in a dot bracket */
8214       if (*vmsptr2 == '.') {
8215         vmsptr2--;
8216
8217         /* ^. is allowed */
8218         if (*vmsptr2 != '^') {
8219           vmsptr--; /* back up over the dot */
8220         }
8221       }
8222       *vmsptr++ = ']';
8223     }
8224   }
8225   else {
8226     char *vmsptr2;
8227     /* Add a trailing dot if a file with no extension */
8228     vmsptr2 = vmsptr - 1;
8229     if ((vmslen > 1) &&
8230         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8231         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8232         *vmsptr++ = '.';
8233         vmslen++;
8234     }
8235   }
8236
8237   *vmsptr = '\0';
8238   return SS$_NORMAL;
8239 }
8240 #endif
8241
8242  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8243 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8244 {
8245 char * result;
8246 int utf8_flag;
8247
8248    /* If a UTF8 flag is being passed, honor it */
8249    utf8_flag = 0;
8250    if (utf8_fl != NULL) {
8251      utf8_flag = *utf8_fl;
8252     *utf8_fl = 0;
8253    }
8254
8255    if (utf8_flag) {
8256      /* If there is a possibility of UTF8, then if any UTF8 characters
8257         are present, then they must be converted to VTF-7
8258       */
8259      result = strcpy(rslt, path); /* FIX-ME */
8260    }
8261    else
8262      result = strcpy(rslt, path);
8263
8264    return result;
8265 }
8266
8267 /* A convenience macro for copying dots in filenames and escaping
8268  * them when they haven't already been escaped, with guards to
8269  * avoid checking before the start of the buffer or advancing
8270  * beyond the end of it (allowing room for the NUL terminator).
8271  */
8272 #define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
8273     if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8274           || ((vmsefsdot) == (vmsefsbuf))) \
8275          && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
8276        ) { \
8277         *((vmsefsdot)++) = '^'; \
8278     } \
8279     if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8280         *((vmsefsdot)++) = '.'; \
8281 } STMT_END
8282
8283 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8284 static char *int_tovmsspec
8285    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8286   char *dirend;
8287   char *lastdot;
8288   char *cp1;
8289   const char *cp2;
8290   unsigned long int infront = 0, hasdir = 1;
8291   int rslt_len;
8292   int no_type_seen;
8293   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8294   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8295
8296   if (vms_debug_fileify) {
8297       if (path == NULL)
8298           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8299       else
8300           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8301   }
8302
8303   if (path == NULL) {
8304       /* If we fail, we should be setting errno */
8305       set_errno(EINVAL);
8306       set_vaxc_errno(SS$_BADPARAM);
8307       return NULL;
8308   }
8309   rslt_len = VMS_MAXRSS-1;
8310
8311   /* '.' and '..' are "[]" and "[-]" for a quick check */
8312   if (path[0] == '.') {
8313     if (path[1] == '\0') {
8314       strcpy(rslt,"[]");
8315       if (utf8_flag != NULL)
8316         *utf8_flag = 0;
8317       return rslt;
8318     }
8319     else {
8320       if (path[1] == '.' && path[2] == '\0') {
8321         strcpy(rslt,"[-]");
8322         if (utf8_flag != NULL)
8323            *utf8_flag = 0;
8324         return rslt;
8325       }
8326     }
8327   }
8328
8329    /* Posix specifications are now a native VMS format */
8330   /*--------------------------------------------------*/
8331 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8332   if (decc_posix_compliant_pathnames) {
8333     if (strncmp(path,"\"^UP^",5) == 0) {
8334       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8335       return rslt;
8336     }
8337   }
8338 #endif
8339
8340   /* This is really the only way to see if this is already in VMS format */
8341   sts = vms_split_path
8342        (path,
8343         &v_spec,
8344         &v_len,
8345         &r_spec,
8346         &r_len,
8347         &d_spec,
8348         &d_len,
8349         &n_spec,
8350         &n_len,
8351         &e_spec,
8352         &e_len,
8353         &vs_spec,
8354         &vs_len);
8355   if (sts == 0) {
8356     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8357        replacement, because the above parse just took care of most of
8358        what is needed to do vmspath when the specification is already
8359        in VMS format.
8360
8361        And if it is not already, it is easier to do the conversion as
8362        part of this routine than to call this routine and then work on
8363        the result.
8364      */
8365
8366     /* If VMS punctuation was found, it is already VMS format */
8367     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8368       if (utf8_flag != NULL)
8369         *utf8_flag = 0;
8370       my_strlcpy(rslt, path, VMS_MAXRSS);
8371       if (vms_debug_fileify) {
8372           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8373       }
8374       return rslt;
8375     }
8376     /* Now, what to do with trailing "." cases where there is no
8377        extension?  If this is a UNIX specification, and EFS characters
8378        are enabled, then the trailing "." should be converted to a "^.".
8379        But if this was already a VMS specification, then it should be
8380        left alone.
8381
8382        So in the case of ambiguity, leave the specification alone.
8383      */
8384
8385
8386     /* If there is a possibility of UTF8, then if any UTF8 characters
8387         are present, then they must be converted to VTF-7
8388      */
8389     if (utf8_flag != NULL)
8390       *utf8_flag = 0;
8391     my_strlcpy(rslt, path, VMS_MAXRSS);
8392     if (vms_debug_fileify) {
8393         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8394     }
8395     return rslt;
8396   }
8397
8398   dirend = strrchr(path,'/');
8399
8400   if (dirend == NULL) {
8401      /* If we get here with no Unix directory delimiters, then this is an
8402       * ambiguous file specification, such as a Unix glob specification, a
8403       * shell or make macro, or a filespec that would be valid except for
8404       * unescaped extended characters.  The safest thing if it's a macro
8405       * is to pass it through as-is.
8406       */
8407       if (strstr(path, "$(")) {
8408           my_strlcpy(rslt, path, VMS_MAXRSS);
8409           if (vms_debug_fileify) {
8410               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8411           }
8412           return rslt;
8413       }
8414       hasdir = 0;
8415   }
8416   else if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8417     if (!*(dirend+2)) dirend +=2;
8418     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8419     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8420   }
8421
8422   cp1 = rslt;
8423   cp2 = path;
8424   lastdot = strrchr(cp2,'.');
8425   if (*cp2 == '/') {
8426     char *trndev;
8427     int islnm, rooted;
8428     STRLEN trnend;
8429
8430     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8431     if (!*(cp2+1)) {
8432       if (decc_disable_posix_root) {
8433         strcpy(rslt,"sys$disk:[000000]");
8434       }
8435       else {
8436         strcpy(rslt,"sys$posix_root:[000000]");
8437       }
8438       if (utf8_flag != NULL)
8439         *utf8_flag = 0;
8440       if (vms_debug_fileify) {
8441           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8442       }
8443       return rslt;
8444     }
8445     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8446     *cp1 = '\0';
8447     trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8448     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8449     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8450
8451      /* DECC special handling */
8452     if (!islnm) {
8453       if (strcmp(rslt,"bin") == 0) {
8454         strcpy(rslt,"sys$system");
8455         cp1 = rslt + 10;
8456         *cp1 = 0;
8457         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8458       }
8459       else if (strcmp(rslt,"tmp") == 0) {
8460         strcpy(rslt,"sys$scratch");
8461         cp1 = rslt + 11;
8462         *cp1 = 0;
8463         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8464       }
8465       else if (!decc_disable_posix_root) {
8466         strcpy(rslt, "sys$posix_root");
8467         cp1 = rslt + 14;
8468         *cp1 = 0;
8469         cp2 = path;
8470         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8471         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8472       }
8473       else if (strcmp(rslt,"dev") == 0) {
8474         if (strncmp(cp2,"/null", 5) == 0) {
8475           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8476             strcpy(rslt,"NLA0");
8477             cp1 = rslt + 4;
8478             *cp1 = 0;
8479             cp2 = cp2 + 5;
8480             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8481           }
8482         }
8483       }
8484     }
8485
8486     trnend = islnm ? strlen(trndev) - 1 : 0;
8487     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8488     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8489     /* If the first element of the path is a logical name, determine
8490      * whether it has to be translated so we can add more directories. */
8491     if (!islnm || rooted) {
8492       *(cp1++) = ':';
8493       *(cp1++) = '[';
8494       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8495       else cp2++;
8496     }
8497     else {
8498       if (cp2 != dirend) {
8499         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8500         cp1 = rslt + trnend;
8501         if (*cp2 != 0) {
8502           *(cp1++) = '.';
8503           cp2++;
8504         }
8505       }
8506       else {
8507         if (decc_disable_posix_root) {
8508           *(cp1++) = ':';
8509           hasdir = 0;
8510         }
8511       }
8512     }
8513     PerlMem_free(trndev);
8514   }
8515   else if (hasdir) {
8516     *(cp1++) = '[';
8517     if (*cp2 == '.') {
8518       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8519         cp2 += 2;         /* skip over "./" - it's redundant */
8520         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8521       }
8522       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8523         *(cp1++) = '-';                                 /* "../" --> "-" */
8524         cp2 += 3;
8525       }
8526       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8527                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8528         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8529         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8530         cp2 += 4;
8531       }
8532       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8533         /* Escape the extra dots in EFS file specifications */
8534         *(cp1++) = '^';
8535       }
8536       if (cp2 > dirend) cp2 = dirend;
8537     }
8538     else *(cp1++) = '.';
8539   }
8540   for (; cp2 < dirend; cp2++) {
8541     if (*cp2 == '/') {
8542       if (*(cp2-1) == '/') continue;
8543       if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
8544       infront = 0;
8545     }
8546     else if (!infront && *cp2 == '.') {
8547       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8548       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8549       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8550         if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
8551         else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
8552         else {
8553           *(cp1++) = '-';
8554         }
8555         cp2 += 2;
8556         if (cp2 == dirend) break;
8557       }
8558       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8559                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8560         if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8561         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8562         if (!*(cp2+3)) {
8563           *(cp1++) = '.';  /* Simulate trailing '/' */
8564           cp2 += 2;  /* for loop will incr this to == dirend */
8565         }
8566         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8567       }
8568       else {
8569         if (decc_efs_charset == 0) {
8570           if (cp1 > rslt && *(cp1-1) == '^')
8571             cp1--;         /* remove the escape, if any */
8572           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8573         }
8574         else {
8575           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8576         }
8577       }
8578     }
8579     else {
8580       if (!infront && cp1 > rslt && *(cp1-1) == '-')  *(cp1++) = '.';
8581       if (*cp2 == '.') {
8582         if (decc_efs_charset == 0) {
8583           if (cp1 > rslt && *(cp1-1) == '^')
8584             cp1--;         /* remove the escape, if any */
8585           *(cp1++) = '_';
8586         }
8587         else {
8588           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8589         }
8590       }
8591       else                  *(cp1++) =  *cp2;
8592       infront = 1;
8593     }
8594   }
8595   if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8596   if (hasdir) *(cp1++) = ']';
8597   if (*cp2 && *cp2 == '/') cp2++;  /* check in case we ended with trailing '/' */
8598   no_type_seen = 0;
8599   if (cp2 > lastdot)
8600     no_type_seen = 1;
8601   while (*cp2) {
8602     switch(*cp2) {
8603     case '?':
8604         if (decc_efs_charset == 0)
8605           *(cp1++) = '%';
8606         else
8607           *(cp1++) = '?';
8608         cp2++;
8609     case ' ':
8610         if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
8611             *(cp1)++ = '^';
8612         *(cp1)++ = '_';
8613         cp2++;
8614         break;
8615     case '.':
8616         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8617             decc_readdir_dropdotnotype) {
8618           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8619           cp2++;
8620
8621           /* trailing dot ==> '^..' on VMS */
8622           if (*cp2 == '\0') {
8623             *(cp1++) = '.';
8624             no_type_seen = 0;
8625           }
8626         }
8627         else {
8628           *(cp1++) = *(cp2++);
8629           no_type_seen = 0;
8630         }
8631         break;
8632     case '$':
8633          /* This could be a macro to be passed through */
8634         *(cp1++) = *(cp2++);
8635         if (*cp2 == '(') {
8636         const char * save_cp2;
8637         char * save_cp1;
8638         int is_macro;
8639
8640             /* paranoid check */
8641             save_cp2 = cp2;
8642             save_cp1 = cp1;
8643             is_macro = 0;
8644
8645             /* Test through */
8646             *(cp1++) = *(cp2++);
8647             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8648                 *(cp1++) = *(cp2++);
8649                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8650                     *(cp1++) = *(cp2++);
8651                 }
8652                 if (*cp2 == ')') {
8653                     *(cp1++) = *(cp2++);
8654                     is_macro = 1;
8655                 }
8656             }
8657             if (is_macro == 0) {
8658                 /* Not really a macro - never mind */
8659                 cp2 = save_cp2;
8660                 cp1 = save_cp1;
8661             }
8662         }
8663         break;
8664     case '\"':
8665     case '~':
8666     case '`':
8667     case '!':
8668     case '#':
8669     case '%':
8670     case '^':
8671         /* Don't escape again if following character is
8672          * already something we escape.
8673          */
8674         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8675             *(cp1++) = *(cp2++);
8676             break;
8677         }
8678         /* But otherwise fall through and escape it. */
8679     case '&':
8680     case '(':
8681     case ')':
8682     case '=':
8683     case '+':
8684     case '\'':
8685     case '@':
8686     case '[':
8687     case ']':
8688     case '{':
8689     case '}':
8690     case ':':
8691     case '\\':
8692     case '|':
8693     case '<':
8694     case '>':
8695         if (cp2 > path && *(cp2-1) != '^') /* not previously escaped */
8696             *(cp1++) = '^';
8697         *(cp1++) = *(cp2++);
8698         break;
8699     case ';':
8700         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8701          * which is wrong.  UNIX notation should be ".dir." unless
8702          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8703          * changing this behavior could break more things at this time.
8704          * efs character set effectively does not allow "." to be a version
8705          * delimiter as a further complication about changing this.
8706          */
8707         if (decc_filename_unix_report != 0) {
8708           *(cp1++) = '^';
8709         }
8710         *(cp1++) = *(cp2++);
8711         break;
8712     default:
8713         *(cp1++) = *(cp2++);
8714     }
8715   }
8716   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8717   char *lcp1;
8718     lcp1 = cp1;
8719     lcp1--;
8720      /* Fix me for "^]", but that requires making sure that you do
8721       * not back up past the start of the filename
8722       */
8723     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8724       *cp1++ = '.';
8725   }
8726   *cp1 = '\0';
8727
8728   if (utf8_flag != NULL)
8729     *utf8_flag = 0;
8730   if (vms_debug_fileify) {
8731       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8732   }
8733   return rslt;
8734
8735 }  /* end of int_tovmsspec() */
8736
8737
8738 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8739 static char *mp_do_tovmsspec
8740    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8741   static char __tovmsspec_retbuf[VMS_MAXRSS];
8742     char * vmsspec, *ret_spec, *ret_buf;
8743
8744     vmsspec = NULL;
8745     ret_buf = buf;
8746     if (ret_buf == NULL) {
8747         if (ts) {
8748             Newx(vmsspec, VMS_MAXRSS, char);
8749             if (vmsspec == NULL)
8750                 _ckvmssts(SS$_INSFMEM);
8751             ret_buf = vmsspec;
8752         } else {
8753             ret_buf = __tovmsspec_retbuf;
8754         }
8755     }
8756
8757     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8758
8759     if (ret_spec == NULL) {
8760        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8761        if (vmsspec)
8762            Safefree(vmsspec);
8763     }
8764
8765     return ret_spec;
8766
8767 }  /* end of mp_do_tovmsspec() */
8768 /*}}}*/
8769 /* External entry points */
8770 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8771   { return do_tovmsspec(path,buf,0,NULL); }
8772 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8773   { return do_tovmsspec(path,buf,1,NULL); }
8774 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8775   { return do_tovmsspec(path,buf,0,utf8_fl); }
8776 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8777   { return do_tovmsspec(path,buf,1,utf8_fl); }
8778
8779 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8780 /* Internal routine for use with out an explicit context present */
8781 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
8782
8783     char * ret_spec, *pathified;
8784
8785     if (path == NULL)
8786         return NULL;
8787
8788     pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8789     if (pathified == NULL)
8790         _ckvmssts_noperl(SS$_INSFMEM);
8791
8792     ret_spec = int_pathify_dirspec(path, pathified);
8793
8794     if (ret_spec == NULL) {
8795         PerlMem_free(pathified);
8796         return NULL;
8797     }
8798
8799     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8800
8801     PerlMem_free(pathified);
8802     return ret_spec;
8803
8804 }
8805
8806 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8807 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8808   static char __tovmspath_retbuf[VMS_MAXRSS];
8809   int vmslen;
8810   char *pathified, *vmsified, *cp;
8811
8812   if (path == NULL) return NULL;
8813   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8814   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8815   if (int_pathify_dirspec(path, pathified) == NULL) {
8816     PerlMem_free(pathified);
8817     return NULL;
8818   }
8819
8820   vmsified = NULL;
8821   if (buf == NULL)
8822      Newx(vmsified, VMS_MAXRSS, char);
8823   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8824     PerlMem_free(pathified);
8825     if (vmsified) Safefree(vmsified);
8826     return NULL;
8827   }
8828   PerlMem_free(pathified);
8829   if (buf) {
8830     return buf;
8831   }
8832   else if (ts) {
8833     vmslen = strlen(vmsified);
8834     Newx(cp,vmslen+1,char);
8835     memcpy(cp,vmsified,vmslen);
8836     cp[vmslen] = '\0';
8837     Safefree(vmsified);
8838     return cp;
8839   }
8840   else {
8841     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8842     Safefree(vmsified);
8843     return __tovmspath_retbuf;
8844   }
8845
8846 }  /* end of do_tovmspath() */
8847 /*}}}*/
8848 /* External entry points */
8849 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8850   { return do_tovmspath(path,buf,0, NULL); }
8851 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8852   { return do_tovmspath(path,buf,1, NULL); }
8853 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8854   { return do_tovmspath(path,buf,0,utf8_fl); }
8855 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8856   { return do_tovmspath(path,buf,1,utf8_fl); }
8857
8858
8859 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8860 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8861   static char __tounixpath_retbuf[VMS_MAXRSS];
8862   int unixlen;
8863   char *pathified, *unixified, *cp;
8864
8865   if (path == NULL) return NULL;
8866   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8867   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8868   if (int_pathify_dirspec(path, pathified) == NULL) {
8869     PerlMem_free(pathified);
8870     return NULL;
8871   }
8872
8873   unixified = NULL;
8874   if (buf == NULL) {
8875       Newx(unixified, VMS_MAXRSS, char);
8876   }
8877   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8878     PerlMem_free(pathified);
8879     if (unixified) Safefree(unixified);
8880     return NULL;
8881   }
8882   PerlMem_free(pathified);
8883   if (buf) {
8884     return buf;
8885   }
8886   else if (ts) {
8887     unixlen = strlen(unixified);
8888     Newx(cp,unixlen+1,char);
8889     memcpy(cp,unixified,unixlen);
8890     cp[unixlen] = '\0';
8891     Safefree(unixified);
8892     return cp;
8893   }
8894   else {
8895     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
8896     Safefree(unixified);
8897     return __tounixpath_retbuf;
8898   }
8899
8900 }  /* end of do_tounixpath() */
8901 /*}}}*/
8902 /* External entry points */
8903 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8904   { return do_tounixpath(path,buf,0,NULL); }
8905 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8906   { return do_tounixpath(path,buf,1,NULL); }
8907 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8908   { return do_tounixpath(path,buf,0,utf8_fl); }
8909 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8910   { return do_tounixpath(path,buf,1,utf8_fl); }
8911
8912 /*
8913  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8914  *
8915  *****************************************************************************
8916  *                                                                           *
8917  *  Copyright (C) 1989-1994, 2007 by                                         *
8918  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8919  *                                                                           *
8920  *  Permission is hereby granted for the reproduction of this software       *
8921  *  on condition that this copyright notice is included in source            *
8922  *  distributions of the software.  The code may be modified and             *
8923  *  distributed under the same terms as Perl itself.                         *
8924  *                                                                           *
8925  *  27-Aug-1994 Modified for inclusion in perl5                              *
8926  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8927  *****************************************************************************
8928  */
8929
8930 /*
8931  * getredirection() is intended to aid in porting C programs
8932  * to VMS (Vax-11 C).  The native VMS environment does not support
8933  * '>' and '<' I/O redirection, or command line wild card expansion,
8934  * or a command line pipe mechanism using the '|' AND background
8935  * command execution '&'.  All of these capabilities are provided to any
8936  * C program which calls this procedure as the first thing in the
8937  * main program.
8938  * The piping mechanism will probably work with almost any 'filter' type
8939  * of program.  With suitable modification, it may useful for other
8940  * portability problems as well.
8941  *
8942  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8943  */
8944 struct list_item
8945     {
8946     struct list_item *next;
8947     char *value;
8948     };
8949
8950 static void add_item(struct list_item **head,
8951                      struct list_item **tail,
8952                      char *value,
8953                      int *count);
8954
8955 static void mp_expand_wild_cards(pTHX_ char *item,
8956                                 struct list_item **head,
8957                                 struct list_item **tail,
8958                                 int *count);
8959
8960 static int background_process(pTHX_ int argc, char **argv);
8961
8962 static void pipe_and_fork(pTHX_ char **cmargv);
8963
8964 /*{{{ void getredirection(int *ac, char ***av)*/
8965 static void
8966 mp_getredirection(pTHX_ int *ac, char ***av)
8967 /*
8968  * Process vms redirection arg's.  Exit if any error is seen.
8969  * If getredirection() processes an argument, it is erased
8970  * from the vector.  getredirection() returns a new argc and argv value.
8971  * In the event that a background command is requested (by a trailing "&"),
8972  * this routine creates a background subprocess, and simply exits the program.
8973  *
8974  * Warning: do not try to simplify the code for vms.  The code
8975  * presupposes that getredirection() is called before any data is
8976  * read from stdin or written to stdout.
8977  *
8978  * Normal usage is as follows:
8979  *
8980  *      main(argc, argv)
8981  *      int             argc;
8982  *      char            *argv[];
8983  *      {
8984  *              getredirection(&argc, &argv);
8985  *      }
8986  */
8987 {
8988     int                 argc = *ac;     /* Argument Count         */
8989     char                **argv = *av;   /* Argument Vector        */
8990     char                *ap;            /* Argument pointer       */
8991     int                 j;              /* argv[] index           */
8992     int                 item_count = 0; /* Count of Items in List */
8993     struct list_item    *list_head = 0; /* First Item in List       */
8994     struct list_item    *list_tail;     /* Last Item in List        */
8995     char                *in = NULL;     /* Input File Name          */
8996     char                *out = NULL;    /* Output File Name         */
8997     char                *outmode = "w"; /* Mode to Open Output File */
8998     char                *err = NULL;    /* Error File Name          */
8999     char                *errmode = "w"; /* Mode to Open Error File  */
9000     int                 cmargc = 0;     /* Piped Command Arg Count  */
9001     char                **cmargv = NULL;/* Piped Command Arg Vector */
9002
9003     /*
9004      * First handle the case where the last thing on the line ends with
9005      * a '&'.  This indicates the desire for the command to be run in a
9006      * subprocess, so we satisfy that desire.
9007      */
9008     ap = argv[argc-1];
9009     if (0 == strcmp("&", ap))
9010        exit(background_process(aTHX_ --argc, argv));
9011     if (*ap && '&' == ap[strlen(ap)-1])
9012         {
9013         ap[strlen(ap)-1] = '\0';
9014        exit(background_process(aTHX_ argc, argv));
9015         }
9016     /*
9017      * Now we handle the general redirection cases that involve '>', '>>',
9018      * '<', and pipes '|'.
9019      */
9020     for (j = 0; j < argc; ++j)
9021         {
9022         if (0 == strcmp("<", argv[j]))
9023             {
9024             if (j+1 >= argc)
9025                 {
9026                 fprintf(stderr,"No input file after < on command line");
9027                 exit(LIB$_WRONUMARG);
9028                 }
9029             in = argv[++j];
9030             continue;
9031             }
9032         if ('<' == *(ap = argv[j]))
9033             {
9034             in = 1 + ap;
9035             continue;
9036             }
9037         if (0 == strcmp(">", ap))
9038             {
9039             if (j+1 >= argc)
9040                 {
9041                 fprintf(stderr,"No output file after > on command line");
9042                 exit(LIB$_WRONUMARG);
9043                 }
9044             out = argv[++j];
9045             continue;
9046             }
9047         if ('>' == *ap)
9048             {
9049             if ('>' == ap[1])
9050                 {
9051                 outmode = "a";
9052                 if ('\0' == ap[2])
9053                     out = argv[++j];
9054                 else
9055                     out = 2 + ap;
9056                 }
9057             else
9058                 out = 1 + ap;
9059             if (j >= argc)
9060                 {
9061                 fprintf(stderr,"No output file after > or >> on command line");
9062                 exit(LIB$_WRONUMARG);
9063                 }
9064             continue;
9065             }
9066         if (('2' == *ap) && ('>' == ap[1]))
9067             {
9068             if ('>' == ap[2])
9069                 {
9070                 errmode = "a";
9071                 if ('\0' == ap[3])
9072                     err = argv[++j];
9073                 else
9074                     err = 3 + ap;
9075                 }
9076             else
9077                 if ('\0' == ap[2])
9078                     err = argv[++j];
9079                 else
9080                     err = 2 + ap;
9081             if (j >= argc)
9082                 {
9083                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9084                 exit(LIB$_WRONUMARG);
9085                 }
9086             continue;
9087             }
9088         if (0 == strcmp("|", argv[j]))
9089             {
9090             if (j+1 >= argc)
9091                 {
9092                 fprintf(stderr,"No command into which to pipe on command line");
9093                 exit(LIB$_WRONUMARG);
9094                 }
9095             cmargc = argc-(j+1);
9096             cmargv = &argv[j+1];
9097             argc = j;
9098             continue;
9099             }
9100         if ('|' == *(ap = argv[j]))
9101             {
9102             ++argv[j];
9103             cmargc = argc-j;
9104             cmargv = &argv[j];
9105             argc = j;
9106             continue;
9107             }
9108         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9109         }
9110     /*
9111      * Allocate and fill in the new argument vector, Some Unix's terminate
9112      * the list with an extra null pointer.
9113      */
9114     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9115     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9116     *av = argv;
9117     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9118         argv[j] = list_head->value;
9119     *ac = item_count;
9120     if (cmargv != NULL)
9121         {
9122         if (out != NULL)
9123             {
9124             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9125             exit(LIB$_INVARGORD);
9126             }
9127         pipe_and_fork(aTHX_ cmargv);
9128         }
9129
9130     /* Check for input from a pipe (mailbox) */
9131
9132     if (in == NULL && 1 == isapipe(0))
9133         {
9134         char mbxname[L_tmpnam];
9135         long int bufsize;
9136         long int dvi_item = DVI$_DEVBUFSIZ;
9137         $DESCRIPTOR(mbxnam, "");
9138         $DESCRIPTOR(mbxdevnam, "");
9139
9140         /* Input from a pipe, reopen it in binary mode to disable       */
9141         /* carriage control processing.                                 */
9142
9143         fgetname(stdin, mbxname, 1);
9144         mbxnam.dsc$a_pointer = mbxname;
9145         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9146         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9147         mbxdevnam.dsc$a_pointer = mbxname;
9148         mbxdevnam.dsc$w_length = sizeof(mbxname);
9149         dvi_item = DVI$_DEVNAM;
9150         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9151         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9152         set_errno(0);
9153         set_vaxc_errno(1);
9154         freopen(mbxname, "rb", stdin);
9155         if (errno != 0)
9156             {
9157             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9158             exit(vaxc$errno);
9159             }
9160         }
9161     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9162         {
9163         fprintf(stderr,"Can't open input file %s as stdin",in);
9164         exit(vaxc$errno);
9165         }
9166     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9167         {
9168         fprintf(stderr,"Can't open output file %s as stdout",out);
9169         exit(vaxc$errno);
9170         }
9171         if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
9172
9173     if (err != NULL) {
9174         if (strcmp(err,"&1") == 0) {
9175             dup2(fileno(stdout), fileno(stderr));
9176             vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
9177         } else {
9178         FILE *tmperr;
9179         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9180             {
9181             fprintf(stderr,"Can't open error file %s as stderr",err);
9182             exit(vaxc$errno);
9183             }
9184             fclose(tmperr);
9185            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9186                 {
9187                 exit(vaxc$errno);
9188                 }
9189             vmssetuserlnm("SYS$ERROR", err);
9190         }
9191         }
9192 #ifdef ARGPROC_DEBUG
9193     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9194     for (j = 0; j < *ac;  ++j)
9195         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9196 #endif
9197    /* Clear errors we may have hit expanding wildcards, so they don't
9198       show up in Perl's $! later */
9199    set_errno(0); set_vaxc_errno(1);
9200 }  /* end of getredirection() */
9201 /*}}}*/
9202
9203 static void add_item(struct list_item **head,
9204                      struct list_item **tail,
9205                      char *value,
9206                      int *count)
9207 {
9208     if (*head == 0)
9209         {
9210         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9211         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9212         *tail = *head;
9213         }
9214     else {
9215         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9216         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9217         *tail = (*tail)->next;
9218         }
9219     (*tail)->value = value;
9220     ++(*count);
9221 }
9222
9223 static void mp_expand_wild_cards(pTHX_ char *item,
9224                               struct list_item **head,
9225                               struct list_item **tail,
9226                               int *count)
9227 {
9228 int expcount = 0;
9229 unsigned long int context = 0;
9230 int isunix = 0;
9231 int item_len = 0;
9232 char *had_version;
9233 char *had_device;
9234 int had_directory;
9235 char *devdir,*cp;
9236 char *vmsspec;
9237 $DESCRIPTOR(filespec, "");
9238 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9239 $DESCRIPTOR(resultspec, "");
9240 unsigned long int lff_flags = 0;
9241 int sts;
9242 int rms_sts;
9243
9244 #ifdef VMS_LONGNAME_SUPPORT
9245     lff_flags = LIB$M_FIL_LONG_NAMES;
9246 #endif
9247
9248     for (cp = item; *cp; cp++) {
9249         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9250         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9251     }
9252     if (!*cp || isspace(*cp))
9253         {
9254         add_item(head, tail, item, count);
9255         return;
9256         }
9257     else
9258         {
9259      /* "double quoted" wild card expressions pass as is */
9260      /* From DCL that means using e.g.:                  */
9261      /* perl program """perl.*"""                        */
9262      item_len = strlen(item);
9263      if ( '"' == *item && '"' == item[item_len-1] )
9264        {
9265        item++;
9266        item[item_len-2] = '\0';
9267        add_item(head, tail, item, count);
9268        return;
9269        }
9270      }
9271     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9272     resultspec.dsc$b_class = DSC$K_CLASS_D;
9273     resultspec.dsc$a_pointer = NULL;
9274     vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9275     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9276     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9277       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9278     if (!isunix || !filespec.dsc$a_pointer)
9279       filespec.dsc$a_pointer = item;
9280     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9281     /*
9282      * Only return version specs, if the caller specified a version
9283      */
9284     had_version = strchr(item, ';');
9285     /*
9286      * Only return device and directory specs, if the caller specified either.
9287      */
9288     had_device = strchr(item, ':');
9289     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9290
9291     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9292                                  (&filespec, &resultspec, &context,
9293                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9294         {
9295         char *string;
9296         char *c;
9297
9298         string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9299         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9300         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9301         if (NULL == had_version)
9302             *(strrchr(string, ';')) = '\0';
9303         if ((!had_directory) && (had_device == NULL))
9304             {
9305             if (NULL == (devdir = strrchr(string, ']')))
9306                 devdir = strrchr(string, '>');
9307             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9308             }
9309         /*
9310          * Be consistent with what the C RTL has already done to the rest of
9311          * the argv items and lowercase all of these names.
9312          */
9313         if (!decc_efs_case_preserve) {
9314             for (c = string; *c; ++c)
9315             if (isupper(*c))
9316                 *c = tolower(*c);
9317         }
9318         if (isunix) trim_unixpath(string,item,1);
9319         add_item(head, tail, string, count);
9320         ++expcount;
9321     }
9322     PerlMem_free(vmsspec);
9323     if (sts != RMS$_NMF)
9324         {
9325         set_vaxc_errno(sts);
9326         switch (sts)
9327             {
9328             case RMS$_FNF: case RMS$_DNF:
9329                 set_errno(ENOENT); break;
9330             case RMS$_DIR:
9331                 set_errno(ENOTDIR); break;
9332             case RMS$_DEV:
9333                 set_errno(ENODEV); break;
9334             case RMS$_FNM: case RMS$_SYN:
9335                 set_errno(EINVAL); break;
9336             case RMS$_PRV:
9337                 set_errno(EACCES); break;
9338             default:
9339                 _ckvmssts_noperl(sts);
9340             }
9341         }
9342     if (expcount == 0)
9343         add_item(head, tail, item, count);
9344     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9345     _ckvmssts_noperl(lib$find_file_end(&context));
9346 }
9347
9348 static int child_st[2];/* Event Flag set when child process completes   */
9349
9350 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9351
9352 static unsigned long int exit_handler(void)
9353 {
9354 short iosb[4];
9355
9356     if (0 == child_st[0])
9357         {
9358 #ifdef ARGPROC_DEBUG
9359         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9360 #endif
9361         fflush(stdout);     /* Have to flush pipe for binary data to    */
9362                             /* terminate properly -- <tp@mccall.com>    */
9363         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9364         sys$dassgn(child_chan);
9365         fclose(stdout);
9366         sys$synch(0, child_st);
9367         }
9368     return(1);
9369 }
9370
9371 static void sig_child(int chan)
9372 {
9373 #ifdef ARGPROC_DEBUG
9374     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9375 #endif
9376     if (child_st[0] == 0)
9377         child_st[0] = 1;
9378 }
9379
9380 static struct exit_control_block exit_block =
9381     {
9382     0,
9383     exit_handler,
9384     1,
9385     &exit_block.exit_status,
9386     0
9387     };
9388
9389 static void
9390 pipe_and_fork(pTHX_ char **cmargv)
9391 {
9392     PerlIO *fp;
9393     struct dsc$descriptor_s *vmscmd;
9394     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9395     int sts, j, l, ismcr, quote, tquote = 0;
9396
9397     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9398     vms_execfree(vmscmd);
9399
9400     j = l = 0;
9401     p = subcmd;
9402     q = cmargv[0];
9403     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9404               && toupper(*(q+2)) == 'R' && !*(q+3);
9405
9406     while (q && l < MAX_DCL_LINE_LENGTH) {
9407         if (!*q) {
9408             if (j > 0 && quote) {
9409                 *p++ = '"';
9410                 l++;
9411             }
9412             q = cmargv[++j];
9413             if (q) {
9414                 if (ismcr && j > 1) quote = 1;
9415                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9416                 *p++ = ' ';
9417                 l++;
9418                 if (quote || tquote) {
9419                     *p++ = '"';
9420                     l++;
9421                 }
9422             }
9423         } else {
9424             if ((quote||tquote) && *q == '"') {
9425                 *p++ = '"';
9426                 l++;
9427             }
9428             *p++ = *q++;
9429             l++;
9430         }
9431     }
9432     *p = '\0';
9433
9434     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9435     if (fp == NULL) {
9436         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9437     }
9438 }
9439
9440 static int background_process(pTHX_ int argc, char **argv)
9441 {
9442 char command[MAX_DCL_SYMBOL + 1] = "$";
9443 $DESCRIPTOR(value, "");
9444 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9445 static $DESCRIPTOR(null, "NLA0:");
9446 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9447 char pidstring[80];
9448 $DESCRIPTOR(pidstr, "");
9449 int pid;
9450 unsigned long int flags = 17, one = 1, retsts;
9451 int len;
9452
9453     len = my_strlcat(command, argv[0], sizeof(command));
9454     while (--argc && (len < MAX_DCL_SYMBOL))
9455         {
9456         my_strlcat(command, " \"", sizeof(command));
9457         my_strlcat(command, *(++argv), sizeof(command));
9458         len = my_strlcat(command, "\"", sizeof(command));
9459         }
9460     value.dsc$a_pointer = command;
9461     value.dsc$w_length = strlen(value.dsc$a_pointer);
9462     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9463     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9464     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9465         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9466     }
9467     else {
9468         _ckvmssts_noperl(retsts);
9469     }
9470 #ifdef ARGPROC_DEBUG
9471     PerlIO_printf(Perl_debug_log, "%s\n", command);
9472 #endif
9473     sprintf(pidstring, "%08X", pid);
9474     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9475     pidstr.dsc$a_pointer = pidstring;
9476     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9477     lib$set_symbol(&pidsymbol, &pidstr);
9478     return(SS$_NORMAL);
9479 }
9480 /*}}}*/
9481 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9482
9483
9484 /* OS-specific initialization at image activation (not thread startup) */
9485 /* Older VAXC header files lack these constants */
9486 #ifndef JPI$_RIGHTS_SIZE
9487 #  define JPI$_RIGHTS_SIZE 817
9488 #endif
9489 #ifndef KGB$M_SUBSYSTEM
9490 #  define KGB$M_SUBSYSTEM 0x8
9491 #endif
9492
9493 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9494
9495 /*{{{void vms_image_init(int *, char ***)*/
9496 void
9497 vms_image_init(int *argcp, char ***argvp)
9498 {
9499   int status;
9500   char eqv[LNM$C_NAMLENGTH+1] = "";
9501   unsigned int len, tabct = 8, tabidx = 0;
9502   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9503   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9504   unsigned short int dummy, rlen;
9505   struct dsc$descriptor_s **tabvec;
9506 #if defined(PERL_IMPLICIT_CONTEXT)
9507   pTHX = NULL;
9508 #endif
9509   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9510                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9511                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9512                                  {          0,                0,    0,      0} };
9513
9514 #ifdef KILL_BY_SIGPRC
9515     Perl_csighandler_init();
9516 #endif
9517
9518 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9519     /* This was moved from the pre-image init handler because on threaded */
9520     /* Perl it was always returning 0 for the default value. */
9521     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9522     if (status > 0) {
9523         int s;
9524         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9525         if (s > 0) {
9526             int initial;
9527             initial = decc$feature_get_value(s, 4);
9528             if (initial > 0) {
9529                 /* initial is: 0 if nothing has set the feature */
9530                 /*            -1 if initialized to default */
9531                 /*             1 if set by logical name */
9532                 /*             2 if set by decc$feature_set_value */
9533                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9534
9535                 /* If the value is not valid, force the feature off */
9536                 if (decc_disable_posix_root < 0) {
9537                     decc$feature_set_value(s, 1, 1);
9538                     decc_disable_posix_root = 1;
9539                 }
9540             }
9541             else {
9542                 /* Nothing has asked for it explicitly, so use our own default. */
9543                 decc_disable_posix_root = 1;
9544                 decc$feature_set_value(s, 1, 1);
9545             }
9546         }
9547     }
9548 #endif
9549
9550   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9551   _ckvmssts_noperl(iosb[0]);
9552   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9553     if (iprv[i]) {           /* Running image installed with privs? */
9554       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9555       will_taint = TRUE;
9556       break;
9557     }
9558   }
9559   /* Rights identifiers might trigger tainting as well. */
9560   if (!will_taint && (rlen || rsz)) {
9561     while (rlen < rsz) {
9562       /* We didn't get all the identifiers on the first pass.  Allocate a
9563        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9564        * were needed to hold all identifiers at time of last call; we'll
9565        * allocate that many unsigned long ints), and go back and get 'em.
9566        * If it gave us less than it wanted to despite ample buffer space,
9567        * something's broken.  Is your system missing a system identifier?
9568        */
9569       if (rsz <= jpilist[1].buflen) {
9570          /* Perl_croak accvios when used this early in startup. */
9571          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9572                          rsz, (unsigned long) jpilist[1].buflen,
9573                          "Check your rights database for corruption.\n");
9574          exit(SS$_ABORT);
9575       }
9576       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9577       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9578       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9579       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9580       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9581       _ckvmssts_noperl(iosb[0]);
9582     }
9583     mask = (unsigned long int *)jpilist[1].bufadr;
9584     /* Check attribute flags for each identifier (2nd longword); protected
9585      * subsystem identifiers trigger tainting.
9586      */
9587     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9588       if (mask[i] & KGB$M_SUBSYSTEM) {
9589         will_taint = TRUE;
9590         break;
9591       }
9592     }
9593     if (mask != rlst) PerlMem_free(mask);
9594   }
9595
9596   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9597    * logical, some versions of the CRTL will add a phanthom /000000/
9598    * directory.  This needs to be removed.
9599    */
9600   if (decc_filename_unix_report) {
9601   char * zeros;
9602   int ulen;
9603     ulen = strlen(argvp[0][0]);
9604     if (ulen > 7) {
9605       zeros = strstr(argvp[0][0], "/000000/");
9606       if (zeros != NULL) {
9607         int mlen;
9608         mlen = ulen - (zeros - argvp[0][0]) - 7;
9609         memmove(zeros, &zeros[7], mlen);
9610         ulen = ulen - 7;
9611         argvp[0][0][ulen] = '\0';
9612       }
9613     }
9614     /* It also may have a trailing dot that needs to be removed otherwise
9615      * it will be converted to VMS mode incorrectly.
9616      */
9617     ulen--;
9618     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9619       argvp[0][0][ulen] = '\0';
9620   }
9621
9622   /* We need to use this hack to tell Perl it should run with tainting,
9623    * since its tainting flag may be part of the PL_curinterp struct, which
9624    * hasn't been allocated when vms_image_init() is called.
9625    */
9626   if (will_taint) {
9627     char **newargv, **oldargv;
9628     oldargv = *argvp;
9629     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9630     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9631     newargv[0] = oldargv[0];
9632     newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9633     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9634     strcpy(newargv[1], "-T");
9635     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9636     (*argcp)++;
9637     newargv[*argcp] = NULL;
9638     /* We orphan the old argv, since we don't know where it's come from,
9639      * so we don't know how to free it.
9640      */
9641     *argvp = newargv;
9642   }
9643   else {  /* Did user explicitly request tainting? */
9644     int i;
9645     char *cp, **av = *argvp;
9646     for (i = 1; i < *argcp; i++) {
9647       if (*av[i] != '-') break;
9648       for (cp = av[i]+1; *cp; cp++) {
9649         if (*cp == 'T') { will_taint = 1; break; }
9650         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9651                   strchr("DFIiMmx",*cp)) break;
9652       }
9653       if (will_taint) break;
9654     }
9655   }
9656
9657   for (tabidx = 0;
9658        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9659        tabidx++) {
9660     if (!tabidx) {
9661       tabvec = (struct dsc$descriptor_s **)
9662             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9663       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9664     }
9665     else if (tabidx >= tabct) {
9666       tabct += 8;
9667       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9668       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9669     }
9670     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9671     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9672     tabvec[tabidx]->dsc$w_length  = len;
9673     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9674     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_S;
9675     tabvec[tabidx]->dsc$a_pointer = PerlMem_malloc(len + 1);
9676     if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9677     my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
9678   }
9679   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9680
9681   getredirection(argcp,argvp);
9682 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9683   {
9684 # include <reentrancy.h>
9685   decc$set_reentrancy(C$C_MULTITHREAD);
9686   }
9687 #endif
9688   return;
9689 }
9690 /*}}}*/
9691
9692
9693 /* trim_unixpath()
9694  * Trim Unix-style prefix off filespec, so it looks like what a shell
9695  * glob expansion would return (i.e. from specified prefix on, not
9696  * full path).  Note that returned filespec is Unix-style, regardless
9697  * of whether input filespec was VMS-style or Unix-style.
9698  *
9699  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9700  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9701  * vector of options; at present, only bit 0 is used, and if set tells
9702  * trim unixpath to try the current default directory as a prefix when
9703  * presented with a possibly ambiguous ... wildcard.
9704  *
9705  * Returns !=0 on success, with trimmed filespec replacing contents of
9706  * fspec, and 0 on failure, with contents of fpsec unchanged.
9707  */
9708 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9709 int
9710 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9711 {
9712   char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9713   int tmplen, reslen = 0, dirs = 0;
9714
9715   if (!wildspec || !fspec) return 0;
9716
9717   unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9718   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9719   tplate = unixwild;
9720   if (strpbrk(wildspec,"]>:") != NULL) {
9721     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9722         PerlMem_free(unixwild);
9723         return 0;
9724     }
9725   }
9726   else {
9727     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9728   }
9729   unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9730   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9731   if (strpbrk(fspec,"]>:") != NULL) {
9732     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9733         PerlMem_free(unixwild);
9734         PerlMem_free(unixified);
9735         return 0;
9736     }
9737     else base = unixified;
9738     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9739      * check to see that final result fits into (isn't longer than) fspec */
9740     reslen = strlen(fspec);
9741   }
9742   else base = fspec;
9743
9744   /* No prefix or absolute path on wildcard, so nothing to remove */
9745   if (!*tplate || *tplate == '/') {
9746     PerlMem_free(unixwild);
9747     if (base == fspec) {
9748         PerlMem_free(unixified);
9749         return 1;
9750     }
9751     tmplen = strlen(unixified);
9752     if (tmplen > reslen) {
9753         PerlMem_free(unixified);
9754         return 0;  /* not enough space */
9755     }
9756     /* Copy unixified resultant, including trailing NUL */
9757     memmove(fspec,unixified,tmplen+1);
9758     PerlMem_free(unixified);
9759     return 1;
9760   }
9761
9762   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9763   if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9764     for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9765     for (cp1 = end ;cp1 >= base; cp1--)
9766       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9767         { cp1++; break; }
9768     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9769     PerlMem_free(unixified);
9770     PerlMem_free(unixwild);
9771     return 1;
9772   }
9773   else {
9774     char *tpl, *lcres;
9775     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9776     int ells = 1, totells, segdirs, match;
9777     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9778                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9779
9780     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9781     totells = ells;
9782     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9783     tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9784     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9785     if (ellipsis == tplate && opts & 1) {
9786       /* Template begins with an ellipsis.  Since we can't tell how many
9787        * directory names at the front of the resultant to keep for an
9788        * arbitrary starting point, we arbitrarily choose the current
9789        * default directory as a starting point.  If it's there as a prefix,
9790        * clip it off.  If not, fall through and act as if the leading
9791        * ellipsis weren't there (i.e. return shortest possible path that
9792        * could match template).
9793        */
9794       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9795           PerlMem_free(tpl);
9796           PerlMem_free(unixified);
9797           PerlMem_free(unixwild);
9798           return 0;
9799       }
9800       if (!decc_efs_case_preserve) {
9801         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9802           if (_tolower(*cp1) != _tolower(*cp2)) break;
9803       }
9804       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9805       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9806       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9807         memmove(fspec,cp2+1,end - cp2);
9808         PerlMem_free(tpl);
9809         PerlMem_free(unixified);
9810         PerlMem_free(unixwild);
9811         return 1;
9812       }
9813     }
9814     /* First off, back up over constant elements at end of path */
9815     if (dirs) {
9816       for (front = end ; front >= base; front--)
9817          if (*front == '/' && !dirs--) { front++; break; }
9818     }
9819     lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9820     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9821     for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9822          cp1++,cp2++) {
9823             if (!decc_efs_case_preserve) {
9824                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9825             }
9826             else {
9827                 *cp2 = *cp1;
9828             }
9829     }
9830     if (cp1 != '\0') {
9831         PerlMem_free(tpl);
9832         PerlMem_free(unixified);
9833         PerlMem_free(unixwild);
9834         PerlMem_free(lcres);
9835         return 0;  /* Path too long. */
9836     }
9837     lcend = cp2;
9838     *cp2 = '\0';  /* Pick up with memcpy later */
9839     lcfront = lcres + (front - base);
9840     /* Now skip over each ellipsis and try to match the path in front of it. */
9841     while (ells--) {
9842       for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9843         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9844             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9845       if (cp1 < tplate) break; /* template started with an ellipsis */
9846       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9847         ellipsis = cp1; continue;
9848       }
9849       wilddsc.dsc$a_pointer = tpl;
9850       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9851       nextell = cp1;
9852       for (segdirs = 0, cp2 = tpl;
9853            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9854            cp1++, cp2++) {
9855          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9856          else {
9857             if (!decc_efs_case_preserve) {
9858               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9859             }
9860             else {
9861               *cp2 = *cp1;  /* else preserve case for match */
9862             }
9863          }
9864          if (*cp2 == '/') segdirs++;
9865       }
9866       if (cp1 != ellipsis - 1) {
9867           PerlMem_free(tpl);
9868           PerlMem_free(unixified);
9869           PerlMem_free(unixwild);
9870           PerlMem_free(lcres);
9871           return 0; /* Path too long */
9872       }
9873       /* Back up at least as many dirs as in template before matching */
9874       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9875         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9876       for (match = 0; cp1 > lcres;) {
9877         resdsc.dsc$a_pointer = cp1;
9878         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9879           match++;
9880           if (match == 1) lcfront = cp1;
9881         }
9882         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9883       }
9884       if (!match) {
9885         PerlMem_free(tpl);
9886         PerlMem_free(unixified);
9887         PerlMem_free(unixwild);
9888         PerlMem_free(lcres);
9889         return 0;  /* Can't find prefix ??? */
9890       }
9891       if (match > 1 && opts & 1) {
9892         /* This ... wildcard could cover more than one set of dirs (i.e.
9893          * a set of similar dir names is repeated).  If the template
9894          * contains more than 1 ..., upstream elements could resolve the
9895          * ambiguity, but it's not worth a full backtracking setup here.
9896          * As a quick heuristic, clip off the current default directory
9897          * if it's present to find the trimmed spec, else use the
9898          * shortest string that this ... could cover.
9899          */
9900         char def[NAM$C_MAXRSS+1], *st;
9901
9902         if (getcwd(def, sizeof def,0) == NULL) {
9903             PerlMem_free(unixified);
9904             PerlMem_free(unixwild);
9905             PerlMem_free(lcres);
9906             PerlMem_free(tpl);
9907             return 0;
9908         }
9909         if (!decc_efs_case_preserve) {
9910           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9911             if (_tolower(*cp1) != _tolower(*cp2)) break;
9912         }
9913         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9914         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9915         if (*cp1 == '\0' && *cp2 == '/') {
9916           memmove(fspec,cp2+1,end - cp2);
9917           PerlMem_free(tpl);
9918           PerlMem_free(unixified);
9919           PerlMem_free(unixwild);
9920           PerlMem_free(lcres);
9921           return 1;
9922         }
9923         /* Nope -- stick with lcfront from above and keep going. */
9924       }
9925     }
9926     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9927     PerlMem_free(tpl);
9928     PerlMem_free(unixified);
9929     PerlMem_free(unixwild);
9930     PerlMem_free(lcres);
9931     return 1;
9932   }
9933
9934 }  /* end of trim_unixpath() */
9935 /*}}}*/
9936
9937
9938 /*
9939  *  VMS readdir() routines.
9940  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9941  *
9942  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9943  *  Minor modifications to original routines.
9944  */
9945
9946 /* readdir may have been redefined by reentr.h, so make sure we get
9947  * the local version for what we do here.
9948  */
9949 #ifdef readdir
9950 # undef readdir
9951 #endif
9952 #if !defined(PERL_IMPLICIT_CONTEXT)
9953 # define readdir Perl_readdir
9954 #else
9955 # define readdir(a) Perl_readdir(aTHX_ a)
9956 #endif
9957
9958     /* Number of elements in vms_versions array */
9959 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9960
9961 /*
9962  *  Open a directory, return a handle for later use.
9963  */
9964 /*{{{ DIR *opendir(char*name) */
9965 DIR *
9966 Perl_opendir(pTHX_ const char *name)
9967 {
9968     DIR *dd;
9969     char *dir;
9970     Stat_t sb;
9971
9972     Newx(dir, VMS_MAXRSS, char);
9973     if (int_tovmspath(name, dir, NULL) == NULL) {
9974       Safefree(dir);
9975       return NULL;
9976     }
9977     /* Check access before stat; otherwise stat does not
9978      * accurately report whether it's a directory.
9979      */
9980     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9981       /* cando_by_name has already set errno */
9982       Safefree(dir);
9983       return NULL;
9984     }
9985     if (flex_stat(dir,&sb) == -1) return NULL;
9986     if (!S_ISDIR(sb.st_mode)) {
9987       Safefree(dir);
9988       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9989       return NULL;
9990     }
9991     /* Get memory for the handle, and the pattern. */
9992     Newx(dd,1,DIR);
9993     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9994
9995     /* Fill in the fields; mainly playing with the descriptor. */
9996     sprintf(dd->pattern, "%s*.*",dir);
9997     Safefree(dir);
9998     dd->context = 0;
9999     dd->count = 0;
10000     dd->flags = 0;
10001     /* By saying we want the result of readdir() in unix format, we are really
10002      * saying we want all the escapes removed, translating characters that
10003      * must be escaped in a VMS-format name to their unescaped form, which is
10004      * presumably allowed in a Unix-format name.
10005      */
10006     dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
10007     dd->pat.dsc$a_pointer = dd->pattern;
10008     dd->pat.dsc$w_length = strlen(dd->pattern);
10009     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10010     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10011 #if defined(USE_ITHREADS)
10012     Newx(dd->mutex,1,perl_mutex);
10013     MUTEX_INIT( (perl_mutex *) dd->mutex );
10014 #else
10015     dd->mutex = NULL;
10016 #endif
10017
10018     return dd;
10019 }  /* end of opendir() */
10020 /*}}}*/
10021
10022 /*
10023  *  Set the flag to indicate we want versions or not.
10024  */
10025 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10026 void
10027 vmsreaddirversions(DIR *dd, int flag)
10028 {
10029     if (flag)
10030         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10031     else
10032         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10033 }
10034 /*}}}*/
10035
10036 /*
10037  *  Free up an opened directory.
10038  */
10039 /*{{{ void closedir(DIR *dd)*/
10040 void
10041 Perl_closedir(DIR *dd)
10042 {
10043     int sts;
10044
10045     sts = lib$find_file_end(&dd->context);
10046     Safefree(dd->pattern);
10047 #if defined(USE_ITHREADS)
10048     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10049     Safefree(dd->mutex);
10050 #endif
10051     Safefree(dd);
10052 }
10053 /*}}}*/
10054
10055 /*
10056  *  Collect all the version numbers for the current file.
10057  */
10058 static void
10059 collectversions(pTHX_ DIR *dd)
10060 {
10061     struct dsc$descriptor_s     pat;
10062     struct dsc$descriptor_s     res;
10063     struct dirent *e;
10064     char *p, *text, *buff;
10065     int i;
10066     unsigned long context, tmpsts;
10067
10068     /* Convenient shorthand. */
10069     e = &dd->entry;
10070
10071     /* Add the version wildcard, ignoring the "*.*" put on before */
10072     i = strlen(dd->pattern);
10073     Newx(text,i + e->d_namlen + 3,char);
10074     my_strlcpy(text, dd->pattern, i + 1);
10075     sprintf(&text[i - 3], "%s;*", e->d_name);
10076
10077     /* Set up the pattern descriptor. */
10078     pat.dsc$a_pointer = text;
10079     pat.dsc$w_length = i + e->d_namlen - 1;
10080     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10081     pat.dsc$b_class = DSC$K_CLASS_S;
10082
10083     /* Set up result descriptor. */
10084     Newx(buff, VMS_MAXRSS, char);
10085     res.dsc$a_pointer = buff;
10086     res.dsc$w_length = VMS_MAXRSS - 1;
10087     res.dsc$b_dtype = DSC$K_DTYPE_T;
10088     res.dsc$b_class = DSC$K_CLASS_S;
10089
10090     /* Read files, collecting versions. */
10091     for (context = 0, e->vms_verscount = 0;
10092          e->vms_verscount < VERSIZE(e);
10093          e->vms_verscount++) {
10094         unsigned long rsts;
10095         unsigned long flags = 0;
10096
10097 #ifdef VMS_LONGNAME_SUPPORT
10098         flags = LIB$M_FIL_LONG_NAMES;
10099 #endif
10100         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10101         if (tmpsts == RMS$_NMF || context == 0) break;
10102         _ckvmssts(tmpsts);
10103         buff[VMS_MAXRSS - 1] = '\0';
10104         if ((p = strchr(buff, ';')))
10105             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10106         else
10107             e->vms_versions[e->vms_verscount] = -1;
10108     }
10109
10110     _ckvmssts(lib$find_file_end(&context));
10111     Safefree(text);
10112     Safefree(buff);
10113
10114 }  /* end of collectversions() */
10115
10116 /*
10117  *  Read the next entry from the directory.
10118  */
10119 /*{{{ struct dirent *readdir(DIR *dd)*/
10120 struct dirent *
10121 Perl_readdir(pTHX_ DIR *dd)
10122 {
10123     struct dsc$descriptor_s     res;
10124     char *p, *buff;
10125     unsigned long int tmpsts;
10126     unsigned long rsts;
10127     unsigned long flags = 0;
10128     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10129     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10130
10131     /* Set up result descriptor, and get next file. */
10132     Newx(buff, VMS_MAXRSS, char);
10133     res.dsc$a_pointer = buff;
10134     res.dsc$w_length = VMS_MAXRSS - 1;
10135     res.dsc$b_dtype = DSC$K_DTYPE_T;
10136     res.dsc$b_class = DSC$K_CLASS_S;
10137
10138 #ifdef VMS_LONGNAME_SUPPORT
10139     flags = LIB$M_FIL_LONG_NAMES;
10140 #endif
10141
10142     tmpsts = lib$find_file
10143         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10144     if (dd->context == 0)
10145         tmpsts = RMS$_NMF;  /* None left. (should be set, but make sure) */
10146
10147     if (!(tmpsts & 1)) {
10148       switch (tmpsts) {
10149         case RMS$_NMF:
10150           break;  /* no more files considered success */
10151         case RMS$_PRV:
10152           SETERRNO(EACCES, tmpsts); break;
10153         case RMS$_DEV:
10154           SETERRNO(ENODEV, tmpsts); break;
10155         case RMS$_DIR:
10156           SETERRNO(ENOTDIR, tmpsts); break;
10157         case RMS$_FNF: case RMS$_DNF:
10158           SETERRNO(ENOENT, tmpsts); break;
10159         default:
10160           SETERRNO(EVMSERR, tmpsts);
10161       }
10162       Safefree(buff);
10163       return NULL;
10164     }
10165     dd->count++;
10166     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10167     buff[res.dsc$w_length] = '\0';
10168     p = buff + res.dsc$w_length;
10169     while (--p >= buff) if (!isspace(*p)) break;
10170     *p = '\0';
10171     if (!decc_efs_case_preserve) {
10172       for (p = buff; *p; p++) *p = _tolower(*p);
10173     }
10174
10175     /* Skip any directory component and just copy the name. */
10176     sts = vms_split_path
10177        (buff,
10178         &v_spec,
10179         &v_len,
10180         &r_spec,
10181         &r_len,
10182         &d_spec,
10183         &d_len,
10184         &n_spec,
10185         &n_len,
10186         &e_spec,
10187         &e_len,
10188         &vs_spec,
10189         &vs_len);
10190
10191     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10192
10193         /* In Unix report mode, remove the ".dir;1" from the name */
10194         /* if it is a real directory. */
10195         if (decc_filename_unix_report && decc_efs_charset) {
10196             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10197                 Stat_t statbuf;
10198                 int ret_sts;
10199
10200                 ret_sts = flex_lstat(buff, &statbuf);
10201                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10202                     e_len = 0;
10203                     e_spec[0] = 0;
10204                 }
10205             }
10206         }
10207
10208         /* Drop NULL extensions on UNIX file specification */
10209         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10210             e_len = 0;
10211             e_spec[0] = '\0';
10212         }
10213     }
10214
10215     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10216     dd->entry.d_name[n_len + e_len] = '\0';
10217     dd->entry.d_namlen = n_len + e_len;
10218
10219     /* Convert the filename to UNIX format if needed */
10220     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10221
10222         /* Translate the encoded characters. */
10223         /* Fixme: Unicode handling could result in embedded 0 characters */
10224         if (strchr(dd->entry.d_name, '^') != NULL) {
10225             char new_name[256];
10226             char * q;
10227             p = dd->entry.d_name;
10228             q = new_name;
10229             while (*p != 0) {
10230                 int inchars_read, outchars_added;
10231                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10232                 p += inchars_read;
10233                 q += outchars_added;
10234                 /* fix-me */
10235                 /* if outchars_added > 1, then this is a wide file specification */
10236                 /* Wide file specifications need to be passed in Perl */
10237                 /* counted strings apparently with a Unicode flag */
10238             }
10239             *q = 0;
10240             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10241         }
10242     }
10243
10244     dd->entry.vms_verscount = 0;
10245     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10246     Safefree(buff);
10247     return &dd->entry;
10248
10249 }  /* end of readdir() */
10250 /*}}}*/
10251
10252 /*
10253  *  Read the next entry from the directory -- thread-safe version.
10254  */
10255 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10256 int
10257 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10258 {
10259     int retval;
10260
10261     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10262
10263     entry = readdir(dd);
10264     *result = entry;
10265     retval = ( *result == NULL ? errno : 0 );
10266
10267     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10268
10269     return retval;
10270
10271 }  /* end of readdir_r() */
10272 /*}}}*/
10273
10274 /*
10275  *  Return something that can be used in a seekdir later.
10276  */
10277 /*{{{ long telldir(DIR *dd)*/
10278 long
10279 Perl_telldir(DIR *dd)
10280 {
10281     return dd->count;
10282 }
10283 /*}}}*/
10284
10285 /*
10286  *  Return to a spot where we used to be.  Brute force.
10287  */
10288 /*{{{ void seekdir(DIR *dd,long count)*/
10289 void
10290 Perl_seekdir(pTHX_ DIR *dd, long count)
10291 {
10292     int old_flags;
10293
10294     /* If we haven't done anything yet... */
10295     if (dd->count == 0)
10296         return;
10297
10298     /* Remember some state, and clear it. */
10299     old_flags = dd->flags;
10300     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10301     _ckvmssts(lib$find_file_end(&dd->context));
10302     dd->context = 0;
10303
10304     /* The increment is in readdir(). */
10305     for (dd->count = 0; dd->count < count; )
10306         readdir(dd);
10307
10308     dd->flags = old_flags;
10309
10310 }  /* end of seekdir() */
10311 /*}}}*/
10312
10313 /* VMS subprocess management
10314  *
10315  * my_vfork() - just a vfork(), after setting a flag to record that
10316  * the current script is trying a Unix-style fork/exec.
10317  *
10318  * vms_do_aexec() and vms_do_exec() are called in response to the
10319  * perl 'exec' function.  If this follows a vfork call, then they
10320  * call out the regular perl routines in doio.c which do an
10321  * execvp (for those who really want to try this under VMS).
10322  * Otherwise, they do exactly what the perl docs say exec should
10323  * do - terminate the current script and invoke a new command
10324  * (See below for notes on command syntax.)
10325  *
10326  * do_aspawn() and do_spawn() implement the VMS side of the perl
10327  * 'system' function.
10328  *
10329  * Note on command arguments to perl 'exec' and 'system': When handled
10330  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10331  * are concatenated to form a DCL command string.  If the first non-numeric
10332  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10333  * the command string is handed off to DCL directly.  Otherwise,
10334  * the first token of the command is taken as the filespec of an image
10335  * to run.  The filespec is expanded using a default type of '.EXE' and
10336  * the process defaults for device, directory, etc., and if found, the resultant
10337  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10338  * the command string as parameters.  This is perhaps a bit complicated,
10339  * but I hope it will form a happy medium between what VMS folks expect
10340  * from lib$spawn and what Unix folks expect from exec.
10341  */
10342
10343 static int vfork_called;
10344
10345 /*{{{int my_vfork(void)*/
10346 int
10347 my_vfork(void)
10348 {
10349   vfork_called++;
10350   return vfork();
10351 }
10352 /*}}}*/
10353
10354
10355 static void
10356 vms_execfree(struct dsc$descriptor_s *vmscmd)
10357 {
10358   if (vmscmd) {
10359       if (vmscmd->dsc$a_pointer) {
10360           PerlMem_free(vmscmd->dsc$a_pointer);
10361       }
10362       PerlMem_free(vmscmd);
10363   }
10364 }
10365
10366 static char *
10367 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10368 {
10369   char *junk, *tmps = NULL;
10370   size_t cmdlen = 0;
10371   size_t rlen;
10372   SV **idx;
10373   STRLEN n_a;
10374
10375   idx = mark;
10376   if (really) {
10377     tmps = SvPV(really,rlen);
10378     if (*tmps) {
10379       cmdlen += rlen + 1;
10380       idx++;
10381     }
10382   }
10383
10384   for (idx++; idx <= sp; idx++) {
10385     if (*idx) {
10386       junk = SvPVx(*idx,rlen);
10387       cmdlen += rlen ? rlen + 1 : 0;
10388     }
10389   }
10390   Newx(PL_Cmd, cmdlen+1, char);
10391
10392   if (tmps && *tmps) {
10393     my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10394     mark++;
10395   }
10396   else *PL_Cmd = '\0';
10397   while (++mark <= sp) {
10398     if (*mark) {
10399       char *s = SvPVx(*mark,n_a);
10400       if (!*s) continue;
10401       if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10402       my_strlcat(PL_Cmd, s, cmdlen+1);
10403     }
10404   }
10405   return PL_Cmd;
10406
10407 }  /* end of setup_argstr() */
10408
10409
10410 static unsigned long int
10411 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10412                    struct dsc$descriptor_s **pvmscmd)
10413 {
10414   char * vmsspec;
10415   char * resspec;
10416   char image_name[NAM$C_MAXRSS+1];
10417   char image_argv[NAM$C_MAXRSS+1];
10418   $DESCRIPTOR(defdsc,".EXE");
10419   $DESCRIPTOR(defdsc2,".");
10420   struct dsc$descriptor_s resdsc;
10421   struct dsc$descriptor_s *vmscmd;
10422   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10423   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10424   char *s, *rest, *cp, *wordbreak;
10425   char * cmd;
10426   int cmdlen;
10427   int isdcl;
10428
10429   vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10430   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10431
10432   /* vmsspec is a DCL command buffer, not just a filename */
10433   vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10434   if (vmsspec == NULL)
10435       _ckvmssts_noperl(SS$_INSFMEM);
10436
10437   resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10438   if (resspec == NULL)
10439       _ckvmssts_noperl(SS$_INSFMEM);
10440
10441   /* Make a copy for modification */
10442   cmdlen = strlen(incmd);
10443   cmd = (char *)PerlMem_malloc(cmdlen+1);
10444   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10445   my_strlcpy(cmd, incmd, cmdlen + 1);
10446   image_name[0] = 0;
10447   image_argv[0] = 0;
10448
10449   resdsc.dsc$a_pointer = resspec;
10450   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10451   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10452   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10453
10454   vmscmd->dsc$a_pointer = NULL;
10455   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10456   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10457   vmscmd->dsc$w_length = 0;
10458   if (pvmscmd) *pvmscmd = vmscmd;
10459
10460   if (suggest_quote) *suggest_quote = 0;
10461
10462   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10463     PerlMem_free(cmd);
10464     PerlMem_free(vmsspec);
10465     PerlMem_free(resspec);
10466     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10467   }
10468
10469   s = cmd;
10470
10471   while (*s && isspace(*s)) s++;
10472
10473   if (*s == '@' || *s == '$') {
10474     vmsspec[0] = *s;  rest = s + 1;
10475     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10476   }
10477   else { cp = vmsspec; rest = s; }
10478
10479   /* If the first word is quoted, then we need to unquote it and
10480    * escape spaces within it.  We'll expand into the resspec buffer,
10481    * then copy back into the cmd buffer, expanding the latter if
10482    * necessary.
10483    */
10484   if (*rest == '"') {
10485     char *cp2;
10486     char *r = rest;
10487     bool in_quote = 0;
10488     int clen = cmdlen;
10489     int soff = s - cmd;
10490
10491     for (cp2 = resspec;
10492          *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10493          rest++) {
10494
10495       if (*rest == ' ') {    /* Escape ' ' to '^_'. */
10496         *cp2 = '^';
10497         *(++cp2) = '_';
10498         cp2++;
10499         clen++;
10500       }
10501       else if (*rest == '"') {
10502         clen--;
10503         if (in_quote) {     /* Must be closing quote. */
10504           rest++;
10505           break;
10506         }
10507         in_quote = 1;
10508       }
10509       else {
10510         *cp2 = *rest;
10511         cp2++;
10512       }
10513     }
10514     *cp2 = '\0';
10515
10516     /* Expand the command buffer if necessary. */
10517     if (clen > cmdlen) {
10518       cmd = (char *)PerlMem_realloc(cmd, clen);
10519       if (cmd == NULL)
10520         _ckvmssts_noperl(SS$_INSFMEM);
10521       /* Where we are may have changed, so recompute offsets */
10522       r = cmd + (r - s - soff);
10523       rest = cmd + (rest - s - soff);
10524       s = cmd + soff;
10525     }
10526
10527     /* Shift the non-verb portion of the command (if any) up or
10528      * down as necessary.
10529      */
10530     if (*rest)
10531       memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10532
10533     /* Copy the unquoted and escaped command verb into place. */
10534     memcpy(r, resspec, cp2 - resspec);
10535     cmd[clen] = '\0';
10536     cmdlen = clen;
10537     rest = r;         /* Rewind for subsequent operations. */
10538   }
10539
10540   if (*rest == '.' || *rest == '/') {
10541     char *cp2;
10542     for (cp2 = resspec;
10543          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10544          rest++, cp2++) *cp2 = *rest;
10545     *cp2 = '\0';
10546     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10547       s = vmsspec;
10548
10549       /* When a UNIX spec with no file type is translated to VMS, */
10550       /* A trailing '.' is appended under ODS-5 rules.            */
10551       /* Here we do not want that trailing "." as it prevents     */
10552       /* Looking for a implied ".exe" type. */
10553       if (decc_efs_charset) {
10554           int i;
10555           i = strlen(vmsspec);
10556           if (vmsspec[i-1] == '.') {
10557               vmsspec[i-1] = '\0';
10558           }
10559       }
10560
10561       if (*rest) {
10562         for (cp2 = vmsspec + strlen(vmsspec);
10563              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10564              rest++, cp2++) *cp2 = *rest;
10565         *cp2 = '\0';
10566       }
10567     }
10568   }
10569   /* Intuit whether verb (first word of cmd) is a DCL command:
10570    *   - if first nonspace char is '@', it's a DCL indirection
10571    * otherwise
10572    *   - if verb contains a filespec separator, it's not a DCL command
10573    *   - if it doesn't, caller tells us whether to default to a DCL
10574    *     command, or to a local image unless told it's DCL (by leading '$')
10575    */
10576   if (*s == '@') {
10577       isdcl = 1;
10578       if (suggest_quote) *suggest_quote = 1;
10579   } else {
10580     char *filespec = strpbrk(s,":<[.;");
10581     rest = wordbreak = strpbrk(s," \"\t/");
10582     if (!wordbreak) wordbreak = s + strlen(s);
10583     if (*s == '$') check_img = 0;
10584     if (filespec && (filespec < wordbreak)) isdcl = 0;
10585     else isdcl = !check_img;
10586   }
10587
10588   if (!isdcl) {
10589     int rsts;
10590     imgdsc.dsc$a_pointer = s;
10591     imgdsc.dsc$w_length = wordbreak - s;
10592     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10593     if (!(retsts&1)) {
10594         _ckvmssts_noperl(lib$find_file_end(&cxt));
10595         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10596       if (!(retsts & 1) && *s == '$') {
10597         _ckvmssts_noperl(lib$find_file_end(&cxt));
10598         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10599         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10600         if (!(retsts&1)) {
10601           _ckvmssts_noperl(lib$find_file_end(&cxt));
10602           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10603         }
10604       }
10605     }
10606     _ckvmssts_noperl(lib$find_file_end(&cxt));
10607
10608     if (retsts & 1) {
10609       FILE *fp;
10610       s = resspec;
10611       while (*s && !isspace(*s)) s++;
10612       *s = '\0';
10613
10614       /* check that it's really not DCL with no file extension */
10615       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10616       if (fp) {
10617         char b[256] = {0,0,0,0};
10618         read(fileno(fp), b, 256);
10619         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10620         if (isdcl) {
10621           int shebang_len;
10622
10623           /* Check for script */
10624           shebang_len = 0;
10625           if ((b[0] == '#') && (b[1] == '!'))
10626              shebang_len = 2;
10627 #ifdef ALTERNATE_SHEBANG
10628           else {
10629             shebang_len = strlen(ALTERNATE_SHEBANG);
10630             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10631               char * perlstr;
10632                 perlstr = strstr("perl",b);
10633                 if (perlstr == NULL)
10634                   shebang_len = 0;
10635             }
10636             else
10637               shebang_len = 0;
10638           }
10639 #endif
10640
10641           if (shebang_len > 0) {
10642           int i;
10643           int j;
10644           char tmpspec[NAM$C_MAXRSS + 1];
10645
10646             i = shebang_len;
10647              /* Image is following after white space */
10648             /*--------------------------------------*/
10649             while (isprint(b[i]) && isspace(b[i]))
10650                 i++;
10651
10652             j = 0;
10653             while (isprint(b[i]) && !isspace(b[i])) {
10654                 tmpspec[j++] = b[i++];
10655                 if (j >= NAM$C_MAXRSS)
10656                    break;
10657             }
10658             tmpspec[j] = '\0';
10659
10660              /* There may be some default parameters to the image */
10661             /*---------------------------------------------------*/
10662             j = 0;
10663             while (isprint(b[i])) {
10664                 image_argv[j++] = b[i++];
10665                 if (j >= NAM$C_MAXRSS)
10666                    break;
10667             }
10668             while ((j > 0) && !isprint(image_argv[j-1]))
10669                 j--;
10670             image_argv[j] = 0;
10671
10672             /* It will need to be converted to VMS format and validated */
10673             if (tmpspec[0] != '\0') {
10674               char * iname;
10675
10676                /* Try to find the exact program requested to be run */
10677               /*---------------------------------------------------*/
10678               iname = int_rmsexpand
10679                  (tmpspec, image_name, ".exe",
10680                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10681               if (iname != NULL) {
10682                 if (cando_by_name_int
10683                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10684                   /* MCR prefix needed */
10685                   isdcl = 0;
10686                 }
10687                 else {
10688                    /* Try again with a null type */
10689                   /*----------------------------*/
10690                   iname = int_rmsexpand
10691                     (tmpspec, image_name, ".",
10692                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10693                   if (iname != NULL) {
10694                     if (cando_by_name_int
10695                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10696                       /* MCR prefix needed */
10697                       isdcl = 0;
10698                     }
10699                   }
10700                 }
10701
10702                  /* Did we find the image to run the script? */
10703                 /*------------------------------------------*/
10704                 if (isdcl) {
10705                   char *tchr;
10706
10707                    /* Assume DCL or foreign command exists */
10708                   /*--------------------------------------*/
10709                   tchr = strrchr(tmpspec, '/');
10710                   if (tchr != NULL) {
10711                     tchr++;
10712                   }
10713                   else {
10714                     tchr = tmpspec;
10715                   }
10716                   my_strlcpy(image_name, tchr, sizeof(image_name));
10717                 }
10718               }
10719             }
10720           }
10721         }
10722         fclose(fp);
10723       }
10724       if (check_img && isdcl) {
10725           PerlMem_free(cmd);
10726           PerlMem_free(resspec);
10727           PerlMem_free(vmsspec);
10728           return RMS$_FNF;
10729       }
10730
10731       if (cando_by_name(S_IXUSR,0,resspec)) {
10732         vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10733         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10734         if (!isdcl) {
10735             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10736             if (image_name[0] != 0) {
10737                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10738                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10739             }
10740         } else if (image_name[0] != 0) {
10741             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10742             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10743         } else {
10744             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10745         }
10746         if (suggest_quote) *suggest_quote = 1;
10747
10748         /* If there is an image name, use original command */
10749         if (image_name[0] == 0)
10750             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10751         else {
10752             rest = cmd;
10753             while (*rest && isspace(*rest)) rest++;
10754         }
10755
10756         if (image_argv[0] != 0) {
10757           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10758           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10759         }
10760         if (rest) {
10761            int rest_len;
10762            int vmscmd_len;
10763
10764            rest_len = strlen(rest);
10765            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10766            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10767               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10768            else
10769              retsts = CLI$_BUFOVF;
10770         }
10771         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10772         PerlMem_free(cmd);
10773         PerlMem_free(vmsspec);
10774         PerlMem_free(resspec);
10775         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10776       }
10777       else
10778         retsts = RMS$_PRV;
10779     }
10780   }
10781   /* It's either a DCL command or we couldn't find a suitable image */
10782   vmscmd->dsc$w_length = strlen(cmd);
10783
10784   vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10785   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10786
10787   PerlMem_free(cmd);
10788   PerlMem_free(resspec);
10789   PerlMem_free(vmsspec);
10790
10791   /* check if it's a symbol (for quoting purposes) */
10792   if (suggest_quote && !*suggest_quote) {
10793     int iss;
10794     char equiv[LNM$C_NAMLENGTH];
10795     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10796     eqvdsc.dsc$a_pointer = equiv;
10797
10798     iss = lib$get_symbol(vmscmd,&eqvdsc);
10799     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10800   }
10801   if (!(retsts & 1)) {
10802     /* just hand off status values likely to be due to user error */
10803     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10804         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10805        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10806     else { _ckvmssts_noperl(retsts); }
10807   }
10808
10809   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10810
10811 }  /* end of setup_cmddsc() */
10812
10813
10814 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10815 bool
10816 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10817 {
10818 bool exec_sts;
10819 char * cmd;
10820
10821   if (sp > mark) {
10822     if (vfork_called) {           /* this follows a vfork - act Unixish */
10823       vfork_called--;
10824       if (vfork_called < 0) {
10825         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10826         vfork_called = 0;
10827       }
10828       else return do_aexec(really,mark,sp);
10829     }
10830                                            /* no vfork - act VMSish */
10831     cmd = setup_argstr(aTHX_ really,mark,sp);
10832     exec_sts = vms_do_exec(cmd);
10833     Safefree(cmd);  /* Clean up from setup_argstr() */
10834     return exec_sts;
10835   }
10836
10837   return FALSE;
10838 }  /* end of vms_do_aexec() */
10839 /*}}}*/
10840
10841 /* {{{bool vms_do_exec(char *cmd) */
10842 bool
10843 Perl_vms_do_exec(pTHX_ const char *cmd)
10844 {
10845   struct dsc$descriptor_s *vmscmd;
10846
10847   if (vfork_called) {             /* this follows a vfork - act Unixish */
10848     vfork_called--;
10849     if (vfork_called < 0) {
10850       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10851       vfork_called = 0;
10852     }
10853     else return do_exec(cmd);
10854   }
10855
10856   {                               /* no vfork - act VMSish */
10857     unsigned long int retsts;
10858
10859     TAINT_ENV();
10860     TAINT_PROPER("exec");
10861     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10862       retsts = lib$do_command(vmscmd);
10863
10864     switch (retsts) {
10865       case RMS$_FNF: case RMS$_DNF:
10866         set_errno(ENOENT); break;
10867       case RMS$_DIR:
10868         set_errno(ENOTDIR); break;
10869       case RMS$_DEV:
10870         set_errno(ENODEV); break;
10871       case RMS$_PRV:
10872         set_errno(EACCES); break;
10873       case RMS$_SYN:
10874         set_errno(EINVAL); break;
10875       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10876         set_errno(E2BIG); break;
10877       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10878         _ckvmssts_noperl(retsts); /* fall through */
10879       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10880         set_errno(EVMSERR);
10881     }
10882     set_vaxc_errno(retsts);
10883     if (ckWARN(WARN_EXEC)) {
10884       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10885              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10886     }
10887     vms_execfree(vmscmd);
10888   }
10889
10890   return FALSE;
10891
10892 }  /* end of vms_do_exec() */
10893 /*}}}*/
10894
10895 int do_spawn2(pTHX_ const char *, int);
10896
10897 int
10898 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10899 {
10900 unsigned long int sts;
10901 char * cmd;
10902 int flags = 0;
10903
10904   if (sp > mark) {
10905
10906     /* We'll copy the (undocumented?) Win32 behavior and allow a
10907      * numeric first argument.  But the only value we'll support
10908      * through do_aspawn is a value of 1, which means spawn without
10909      * waiting for completion -- other values are ignored.
10910      */
10911     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10912         ++mark;
10913         flags = SvIVx(*mark);
10914     }
10915
10916     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10917         flags = CLI$M_NOWAIT;
10918     else
10919         flags = 0;
10920
10921     cmd = setup_argstr(aTHX_ really, mark, sp);
10922     sts = do_spawn2(aTHX_ cmd, flags);
10923     /* pp_sys will clean up cmd */
10924     return sts;
10925   }
10926   return SS$_ABORT;
10927 }  /* end of do_aspawn() */
10928 /*}}}*/
10929
10930
10931 /* {{{int do_spawn(char* cmd) */
10932 int
10933 Perl_do_spawn(pTHX_ char* cmd)
10934 {
10935     PERL_ARGS_ASSERT_DO_SPAWN;
10936
10937     return do_spawn2(aTHX_ cmd, 0);
10938 }
10939 /*}}}*/
10940
10941 /* {{{int do_spawn_nowait(char* cmd) */
10942 int
10943 Perl_do_spawn_nowait(pTHX_ char* cmd)
10944 {
10945     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10946
10947     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10948 }
10949 /*}}}*/
10950
10951 /* {{{int do_spawn2(char *cmd) */
10952 int
10953 do_spawn2(pTHX_ const char *cmd, int flags)
10954 {
10955   unsigned long int sts, substs;
10956
10957   /* The caller of this routine expects to Safefree(PL_Cmd) */
10958   Newx(PL_Cmd,10,char);
10959
10960   TAINT_ENV();
10961   TAINT_PROPER("spawn");
10962   if (!cmd || !*cmd) {
10963     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10964     if (!(sts & 1)) {
10965       switch (sts) {
10966         case RMS$_FNF:  case RMS$_DNF:
10967           set_errno(ENOENT); break;
10968         case RMS$_DIR:
10969           set_errno(ENOTDIR); break;
10970         case RMS$_DEV:
10971           set_errno(ENODEV); break;
10972         case RMS$_PRV:
10973           set_errno(EACCES); break;
10974         case RMS$_SYN:
10975           set_errno(EINVAL); break;
10976         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10977           set_errno(E2BIG); break;
10978         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10979           _ckvmssts_noperl(sts); /* fall through */
10980         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10981           set_errno(EVMSERR);
10982       }
10983       set_vaxc_errno(sts);
10984       if (ckWARN(WARN_EXEC)) {
10985         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10986                     Strerror(errno));
10987       }
10988     }
10989     sts = substs;
10990   }
10991   else {
10992     char mode[3];
10993     PerlIO * fp;
10994     if (flags & CLI$M_NOWAIT)
10995         strcpy(mode, "n");
10996     else
10997         strcpy(mode, "nW");
10998
10999     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11000     if (fp != NULL)
11001       my_pclose(fp);
11002     /* sts will be the pid in the nowait case */
11003   }
11004   return sts;
11005 }  /* end of do_spawn2() */
11006 /*}}}*/
11007
11008
11009 static unsigned int *sockflags, sockflagsize;
11010
11011 /*
11012  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11013  * routines found in some versions of the CRTL can't deal with sockets.
11014  * We don't shim the other file open routines since a socket isn't
11015  * likely to be opened by a name.
11016  */
11017 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11018 FILE *my_fdopen(int fd, const char *mode)
11019 {
11020   FILE *fp = fdopen(fd, mode);
11021
11022   if (fp) {
11023     unsigned int fdoff = fd / sizeof(unsigned int);
11024     Stat_t sbuf; /* native stat; we don't need flex_stat */
11025     if (!sockflagsize || fdoff > sockflagsize) {
11026       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11027       else           Newx  (sockflags,fdoff+2,unsigned int);
11028       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11029       sockflagsize = fdoff + 2;
11030     }
11031     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11032       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11033   }
11034   return fp;
11035
11036 }
11037 /*}}}*/
11038
11039
11040 /*
11041  * Clear the corresponding bit when the (possibly) socket stream is closed.
11042  * There still a small hole: we miss an implicit close which might occur
11043  * via freopen().  >> Todo
11044  */
11045 /*{{{ int my_fclose(FILE *fp)*/
11046 int my_fclose(FILE *fp) {
11047   if (fp) {
11048     unsigned int fd = fileno(fp);
11049     unsigned int fdoff = fd / sizeof(unsigned int);
11050
11051     if (sockflagsize && fdoff < sockflagsize)
11052       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11053   }
11054   return fclose(fp);
11055 }
11056 /*}}}*/
11057
11058
11059 /*
11060  * A simple fwrite replacement which outputs itmsz*nitm chars without
11061  * introducing record boundaries every itmsz chars.
11062  * We are using fputs, which depends on a terminating null.  We may
11063  * well be writing binary data, so we need to accommodate not only
11064  * data with nulls sprinkled in the middle but also data with no null
11065  * byte at the end.
11066  */
11067 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11068 int
11069 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11070 {
11071   char *cp, *end, *cpd;
11072   char *data;
11073   unsigned int fd = fileno(dest);
11074   unsigned int fdoff = fd / sizeof(unsigned int);
11075   int retval;
11076   int bufsize = itmsz * nitm + 1;
11077
11078   if (fdoff < sockflagsize &&
11079       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11080     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11081     return nitm;
11082   }
11083
11084   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11085   memcpy( data, src, itmsz*nitm );
11086   data[itmsz*nitm] = '\0';
11087
11088   end = data + itmsz * nitm;
11089   retval = (int) nitm; /* on success return # items written */
11090
11091   cpd = data;
11092   while (cpd <= end) {
11093     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11094     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11095     if (cp < end)
11096       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11097     cpd = cp + 1;
11098   }
11099
11100   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11101   return retval;
11102
11103 }  /* end of my_fwrite() */
11104 /*}}}*/
11105
11106 /*{{{ int my_flush(FILE *fp)*/
11107 int
11108 Perl_my_flush(pTHX_ FILE *fp)
11109 {
11110     int res;
11111     if ((res = fflush(fp)) == 0 && fp) {
11112 #ifdef VMS_DO_SOCKETS
11113         Stat_t s;
11114         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11115 #endif
11116             res = fsync(fileno(fp));
11117     }
11118 /*
11119  * If the flush succeeded but set end-of-file, we need to clear
11120  * the error because our caller may check ferror().  BTW, this
11121  * probably means we just flushed an empty file.
11122  */
11123     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11124
11125     return res;
11126 }
11127 /*}}}*/
11128
11129 /* fgetname() is not returning the correct file specifications when
11130  * decc_filename_unix_report mode is active.  So we have to have it
11131  * aways return filenames in VMS mode and convert it ourselves.
11132  */
11133
11134 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11135 char *
11136 Perl_my_fgetname(FILE *fp, char * buf) {
11137     char * retname;
11138     char * vms_name;
11139
11140     retname = fgetname(fp, buf, 1);
11141
11142     /* If we are in VMS mode, then we are done */
11143     if (!decc_filename_unix_report || (retname == NULL)) {
11144        return retname;
11145     }
11146
11147     /* Convert this to Unix format */
11148     vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11149     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11150     retname = int_tounixspec(vms_name, buf, NULL);
11151     PerlMem_free(vms_name);
11152
11153     return retname;
11154 }
11155 /*}}}*/
11156
11157 /*
11158  * Here are replacements for the following Unix routines in the VMS environment:
11159  *      getpwuid    Get information for a particular UIC or UID
11160  *      getpwnam    Get information for a named user
11161  *      getpwent    Get information for each user in the rights database
11162  *      setpwent    Reset search to the start of the rights database
11163  *      endpwent    Finish searching for users in the rights database
11164  *
11165  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11166  * (defined in pwd.h), which contains the following fields:-
11167  *      struct passwd {
11168  *              char        *pw_name;    Username (in lower case)
11169  *              char        *pw_passwd;  Hashed password
11170  *              unsigned int pw_uid;     UIC
11171  *              unsigned int pw_gid;     UIC group  number
11172  *              char        *pw_unixdir; Default device/directory (VMS-style)
11173  *              char        *pw_gecos;   Owner name
11174  *              char        *pw_dir;     Default device/directory (Unix-style)
11175  *              char        *pw_shell;   Default CLI name (eg. DCL)
11176  *      };
11177  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11178  *
11179  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11180  * not the UIC member number (eg. what's returned by getuid()),
11181  * getpwuid() can accept either as input (if uid is specified, the caller's
11182  * UIC group is used), though it won't recognise gid=0.
11183  *
11184  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11185  * information about other users in your group or in other groups, respectively.
11186  * If the required privilege is not available, then these routines fill only
11187  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11188  * string).
11189  *
11190  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11191  */
11192
11193 /* sizes of various UAF record fields */
11194 #define UAI$S_USERNAME 12
11195 #define UAI$S_IDENT    31
11196 #define UAI$S_OWNER    31
11197 #define UAI$S_DEFDEV   31
11198 #define UAI$S_DEFDIR   63
11199 #define UAI$S_DEFCLI   31
11200 #define UAI$S_PWD       8
11201
11202 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11203                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11204                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11205
11206 static char __empty[]= "";
11207 static struct passwd __passwd_empty=
11208     {(char *) __empty, (char *) __empty, 0, 0,
11209      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11210 static int contxt= 0;
11211 static struct passwd __pwdcache;
11212 static char __pw_namecache[UAI$S_IDENT+1];
11213
11214 /*
11215  * This routine does most of the work extracting the user information.
11216  */
11217 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11218 {
11219     static struct {
11220         unsigned char length;
11221         char pw_gecos[UAI$S_OWNER+1];
11222     } owner;
11223     static union uicdef uic;
11224     static struct {
11225         unsigned char length;
11226         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11227     } defdev;
11228     static struct {
11229         unsigned char length;
11230         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11231     } defdir;
11232     static struct {
11233         unsigned char length;
11234         char pw_shell[UAI$S_DEFCLI+1];
11235     } defcli;
11236     static char pw_passwd[UAI$S_PWD+1];
11237
11238     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11239     struct dsc$descriptor_s name_desc;
11240     unsigned long int sts;
11241
11242     static struct itmlst_3 itmlst[]= {
11243         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11244         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11245         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11246         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11247         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11248         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11249         {0,                0,           NULL,    NULL}};
11250
11251     name_desc.dsc$w_length=  strlen(name);
11252     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11253     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11254     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11255
11256 /*  Note that sys$getuai returns many fields as counted strings. */
11257     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11258     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11259       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11260     }
11261     else { _ckvmssts(sts); }
11262     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11263
11264     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11265     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11266     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11267     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11268     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11269     owner.pw_gecos[lowner]=            '\0';
11270     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11271     defcli.pw_shell[ldefcli]=          '\0';
11272     if (valid_uic(uic)) {
11273         pwd->pw_uid= uic.uic$l_uic;
11274         pwd->pw_gid= uic.uic$v_group;
11275     }
11276     else
11277       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11278     pwd->pw_passwd=  pw_passwd;
11279     pwd->pw_gecos=   owner.pw_gecos;
11280     pwd->pw_dir=     defdev.pw_dir;
11281     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11282     pwd->pw_shell=   defcli.pw_shell;
11283     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11284         int ldir;
11285         ldir= strlen(pwd->pw_unixdir) - 1;
11286         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11287     }
11288     else
11289         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11290     if (!decc_efs_case_preserve)
11291         __mystrtolower(pwd->pw_unixdir);
11292     return 1;
11293 }
11294
11295 /*
11296  * Get information for a named user.
11297 */
11298 /*{{{struct passwd *getpwnam(char *name)*/
11299 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11300 {
11301     struct dsc$descriptor_s name_desc;
11302     union uicdef uic;
11303     unsigned long int sts;
11304
11305     __pwdcache = __passwd_empty;
11306     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11307       /* We still may be able to determine pw_uid and pw_gid */
11308       name_desc.dsc$w_length=  strlen(name);
11309       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11310       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11311       name_desc.dsc$a_pointer= (char *) name;
11312       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11313         __pwdcache.pw_uid= uic.uic$l_uic;
11314         __pwdcache.pw_gid= uic.uic$v_group;
11315       }
11316       else {
11317         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11318           set_vaxc_errno(sts);
11319           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11320           return NULL;
11321         }
11322         else { _ckvmssts(sts); }
11323       }
11324     }
11325     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11326     __pwdcache.pw_name= __pw_namecache;
11327     return &__pwdcache;
11328 }  /* end of my_getpwnam() */
11329 /*}}}*/
11330
11331 /*
11332  * Get information for a particular UIC or UID.
11333  * Called by my_getpwent with uid=-1 to list all users.
11334 */
11335 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11336 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11337 {
11338     const $DESCRIPTOR(name_desc,__pw_namecache);
11339     unsigned short lname;
11340     union uicdef uic;
11341     unsigned long int status;
11342
11343     if (uid == (unsigned int) -1) {
11344       do {
11345         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11346         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11347           set_vaxc_errno(status);
11348           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11349           my_endpwent();
11350           return NULL;
11351         }
11352         else { _ckvmssts(status); }
11353       } while (!valid_uic (uic));
11354     }
11355     else {
11356       uic.uic$l_uic= uid;
11357       if (!uic.uic$v_group)
11358         uic.uic$v_group= PerlProc_getgid();
11359       if (valid_uic(uic))
11360         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11361       else status = SS$_IVIDENT;
11362       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11363           status == RMS$_PRV) {
11364         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11365         return NULL;
11366       }
11367       else { _ckvmssts(status); }
11368     }
11369     __pw_namecache[lname]= '\0';
11370     __mystrtolower(__pw_namecache);
11371
11372     __pwdcache = __passwd_empty;
11373     __pwdcache.pw_name = __pw_namecache;
11374
11375 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11376     The identifier's value is usually the UIC, but it doesn't have to be,
11377     so if we can, we let fillpasswd update this. */
11378     __pwdcache.pw_uid =  uic.uic$l_uic;
11379     __pwdcache.pw_gid =  uic.uic$v_group;
11380
11381     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11382     return &__pwdcache;
11383
11384 }  /* end of my_getpwuid() */
11385 /*}}}*/
11386
11387 /*
11388  * Get information for next user.
11389 */
11390 /*{{{struct passwd *my_getpwent()*/
11391 struct passwd *Perl_my_getpwent(pTHX)
11392 {
11393     return (my_getpwuid((unsigned int) -1));
11394 }
11395 /*}}}*/
11396
11397 /*
11398  * Finish searching rights database for users.
11399 */
11400 /*{{{void my_endpwent()*/
11401 void Perl_my_endpwent(pTHX)
11402 {
11403     if (contxt) {
11404       _ckvmssts(sys$finish_rdb(&contxt));
11405       contxt= 0;
11406     }
11407 }
11408 /*}}}*/
11409
11410 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11411  * my_utime(), and flex_stat(), all of which operate on UTC unless
11412  * VMSISH_TIMES is true.
11413  */
11414 /* method used to handle UTC conversions:
11415  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11416  */
11417 static int gmtime_emulation_type;
11418 /* number of secs to add to UTC POSIX-style time to get local time */
11419 static long int utc_offset_secs;
11420
11421 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11422  * in vmsish.h.  #undef them here so we can call the CRTL routines
11423  * directly.
11424  */
11425 #undef gmtime
11426 #undef localtime
11427 #undef time
11428
11429
11430 static time_t toutc_dst(time_t loc) {
11431   struct tm *rsltmp;
11432
11433   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11434   loc -= utc_offset_secs;
11435   if (rsltmp->tm_isdst) loc -= 3600;
11436   return loc;
11437 }
11438 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11439        ((gmtime_emulation_type || my_time(NULL)), \
11440        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11441        ((secs) - utc_offset_secs))))
11442
11443 static time_t toloc_dst(time_t utc) {
11444   struct tm *rsltmp;
11445
11446   utc += utc_offset_secs;
11447   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11448   if (rsltmp->tm_isdst) utc += 3600;
11449   return utc;
11450 }
11451 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11452        ((gmtime_emulation_type || my_time(NULL)), \
11453        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11454        ((secs) + utc_offset_secs))))
11455
11456 /* my_time(), my_localtime(), my_gmtime()
11457  * By default traffic in UTC time values, using CRTL gmtime() or
11458  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11459  * Note: We need to use these functions even when the CRTL has working
11460  * UTC support, since they also handle C<use vmsish qw(times);>
11461  *
11462  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11463  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11464  */
11465
11466 /*{{{time_t my_time(time_t *timep)*/
11467 time_t Perl_my_time(pTHX_ time_t *timep)
11468 {
11469   time_t when;
11470   struct tm *tm_p;
11471
11472   if (gmtime_emulation_type == 0) {
11473     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11474                               /* results of calls to gmtime() and localtime() */
11475                               /* for same &base */
11476
11477     gmtime_emulation_type++;
11478     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11479       char off[LNM$C_NAMLENGTH+1];;
11480
11481       gmtime_emulation_type++;
11482       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11483         gmtime_emulation_type++;
11484         utc_offset_secs = 0;
11485         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11486       }
11487       else { utc_offset_secs = atol(off); }
11488     }
11489     else { /* We've got a working gmtime() */
11490       struct tm gmt, local;
11491
11492       gmt = *tm_p;
11493       tm_p = localtime(&base);
11494       local = *tm_p;
11495       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11496       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11497       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11498       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11499     }
11500   }
11501
11502   when = time(NULL);
11503 # ifdef VMSISH_TIME
11504   if (VMSISH_TIME) when = _toloc(when);
11505 # endif
11506   if (timep != NULL) *timep = when;
11507   return when;
11508
11509 }  /* end of my_time() */
11510 /*}}}*/
11511
11512
11513 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11514 struct tm *
11515 Perl_my_gmtime(pTHX_ const time_t *timep)
11516 {
11517   time_t when;
11518   struct tm *rsltmp;
11519
11520   if (timep == NULL) {
11521     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11522     return NULL;
11523   }
11524   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11525
11526   when = *timep;
11527 # ifdef VMSISH_TIME
11528   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11529 #  endif
11530   return gmtime(&when);
11531 }  /* end of my_gmtime() */
11532 /*}}}*/
11533
11534
11535 /*{{{struct tm *my_localtime(const time_t *timep)*/
11536 struct tm *
11537 Perl_my_localtime(pTHX_ const time_t *timep)
11538 {
11539   time_t when;
11540
11541   if (timep == NULL) {
11542     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11543     return NULL;
11544   }
11545   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11546   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11547
11548   when = *timep;
11549 # ifdef VMSISH_TIME
11550   if (VMSISH_TIME) when = _toutc(when);
11551 # endif
11552   /* CRTL localtime() wants UTC as input, does tz correction itself */
11553   return localtime(&when);
11554 } /*  end of my_localtime() */
11555 /*}}}*/
11556
11557 /* Reset definitions for later calls */
11558 #define gmtime(t)    my_gmtime(t)
11559 #define localtime(t) my_localtime(t)
11560 #define time(t)      my_time(t)
11561
11562
11563 /* my_utime - update modification/access time of a file
11564  *
11565  * VMS 7.3 and later implementation
11566  * Only the UTC translation is home-grown. The rest is handled by the
11567  * CRTL utime(), which will take into account the relevant feature
11568  * logicals and ODS-5 volume characteristics for true access times.
11569  *
11570  * pre VMS 7.3 implementation:
11571  * The calling sequence is identical to POSIX utime(), but under
11572  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11573  * not maintain access times.  Restrictions differ from the POSIX
11574  * definition in that the time can be changed as long as the
11575  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11576  * no separate checks are made to insure that the caller is the
11577  * owner of the file or has special privs enabled.
11578  * Code here is based on Joe Meadows' FILE utility.
11579  *
11580  */
11581
11582 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11583  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11584  * in 100 ns intervals.
11585  */
11586 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11587
11588 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11589 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11590 {
11591 #if __CRTL_VER >= 70300000
11592   struct utimbuf utc_utimes, *utc_utimesp;
11593
11594   if (utimes != NULL) {
11595     utc_utimes.actime = utimes->actime;
11596     utc_utimes.modtime = utimes->modtime;
11597 # ifdef VMSISH_TIME
11598     /* If input was local; convert to UTC for sys svc */
11599     if (VMSISH_TIME) {
11600       utc_utimes.actime = _toutc(utimes->actime);
11601       utc_utimes.modtime = _toutc(utimes->modtime);
11602     }
11603 # endif
11604     utc_utimesp = &utc_utimes;
11605   }
11606   else {
11607     utc_utimesp = NULL;
11608   }
11609
11610   return utime(file, utc_utimesp);
11611
11612 #else /* __CRTL_VER < 70300000 */
11613
11614   int i;
11615   int sts;
11616   long int bintime[2], len = 2, lowbit, unixtime,
11617            secscale = 10000000; /* seconds --> 100 ns intervals */
11618   unsigned long int chan, iosb[2], retsts;
11619   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11620   struct FAB myfab = cc$rms_fab;
11621   struct NAM mynam = cc$rms_nam;
11622 #if defined (__DECC) && defined (__VAX)
11623   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11624    * at least through VMS V6.1, which causes a type-conversion warning.
11625    */
11626 #  pragma message save
11627 #  pragma message disable cvtdiftypes
11628 #endif
11629   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11630   struct fibdef myfib;
11631 #if defined (__DECC) && defined (__VAX)
11632   /* This should be right after the declaration of myatr, but due
11633    * to a bug in VAX DEC C, this takes effect a statement early.
11634    */
11635 #  pragma message restore
11636 #endif
11637   /* cast ok for read only parameter */
11638   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11639                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11640                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11641
11642   if (file == NULL || *file == '\0') {
11643     SETERRNO(ENOENT, LIB$_INVARG);
11644     return -1;
11645   }
11646
11647   /* Convert to VMS format ensuring that it will fit in 255 characters */
11648   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11649       SETERRNO(ENOENT, LIB$_INVARG);
11650       return -1;
11651   }
11652   if (utimes != NULL) {
11653     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11654      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11655      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11656      * as input, we force the sign bit to be clear by shifting unixtime right
11657      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11658      */
11659     lowbit = (utimes->modtime & 1) ? secscale : 0;
11660     unixtime = (long int) utimes->modtime;
11661 #   ifdef VMSISH_TIME
11662     /* If input was UTC; convert to local for sys svc */
11663     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11664 #   endif
11665     unixtime >>= 1;  secscale <<= 1;
11666     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11667     if (!(retsts & 1)) {
11668       SETERRNO(EVMSERR, retsts);
11669       return -1;
11670     }
11671     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11672     if (!(retsts & 1)) {
11673       SETERRNO(EVMSERR, retsts);
11674       return -1;
11675     }
11676   }
11677   else {
11678     /* Just get the current time in VMS format directly */
11679     retsts = sys$gettim(bintime);
11680     if (!(retsts & 1)) {
11681       SETERRNO(EVMSERR, retsts);
11682       return -1;
11683     }
11684   }
11685
11686   myfab.fab$l_fna = vmsspec;
11687   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11688   myfab.fab$l_nam = &mynam;
11689   mynam.nam$l_esa = esa;
11690   mynam.nam$b_ess = (unsigned char) sizeof esa;
11691   mynam.nam$l_rsa = rsa;
11692   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11693   if (decc_efs_case_preserve)
11694       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11695
11696   /* Look for the file to be affected, letting RMS parse the file
11697    * specification for us as well.  I have set errno using only
11698    * values documented in the utime() man page for VMS POSIX.
11699    */
11700   retsts = sys$parse(&myfab,0,0);
11701   if (!(retsts & 1)) {
11702     set_vaxc_errno(retsts);
11703     if      (retsts == RMS$_PRV) set_errno(EACCES);
11704     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11705     else                         set_errno(EVMSERR);
11706     return -1;
11707   }
11708   retsts = sys$search(&myfab,0,0);
11709   if (!(retsts & 1)) {
11710     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11711     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11712     set_vaxc_errno(retsts);
11713     if      (retsts == RMS$_PRV) set_errno(EACCES);
11714     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11715     else                         set_errno(EVMSERR);
11716     return -1;
11717   }
11718
11719   devdsc.dsc$w_length = mynam.nam$b_dev;
11720   /* cast ok for read only parameter */
11721   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11722
11723   retsts = sys$assign(&devdsc,&chan,0,0);
11724   if (!(retsts & 1)) {
11725     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11726     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11727     set_vaxc_errno(retsts);
11728     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11729     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11730     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11731     else                               set_errno(EVMSERR);
11732     return -1;
11733   }
11734
11735   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11736   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11737
11738   memset((void *) &myfib, 0, sizeof myfib);
11739 #if defined(__DECC) || defined(__DECCXX)
11740   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11741   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11742   /* This prevents the revision time of the file being reset to the current
11743    * time as a result of our IO$_MODIFY $QIO. */
11744   myfib.fib$l_acctl = FIB$M_NORECORD;
11745 #else
11746   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11747   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11748   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11749 #endif
11750   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11751   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11752   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11753   _ckvmssts(sys$dassgn(chan));
11754   if (retsts & 1) retsts = iosb[0];
11755   if (!(retsts & 1)) {
11756     set_vaxc_errno(retsts);
11757     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11758     else                      set_errno(EVMSERR);
11759     return -1;
11760   }
11761
11762   return 0;
11763
11764 #endif /* #if __CRTL_VER >= 70300000 */
11765
11766 }  /* end of my_utime() */
11767 /*}}}*/
11768
11769 /*
11770  * flex_stat, flex_lstat, flex_fstat
11771  * basic stat, but gets it right when asked to stat
11772  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11773  */
11774
11775 #ifndef _USE_STD_STAT
11776 /* encode_dev packs a VMS device name string into an integer to allow
11777  * simple comparisons. This can be used, for example, to check whether two
11778  * files are located on the same device, by comparing their encoded device
11779  * names. Even a string comparison would not do, because stat() reuses the
11780  * device name buffer for each call; so without encode_dev, it would be
11781  * necessary to save the buffer and use strcmp (this would mean a number of
11782  * changes to the standard Perl code, to say nothing of what a Perl script
11783  * would have to do.
11784  *
11785  * The device lock id, if it exists, should be unique (unless perhaps compared
11786  * with lock ids transferred from other nodes). We have a lock id if the disk is
11787  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11788  * device names. Thus we use the lock id in preference, and only if that isn't
11789  * available, do we try to pack the device name into an integer (flagged by
11790  * the sign bit (LOCKID_MASK) being set).
11791  *
11792  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11793  * name and its encoded form, but it seems very unlikely that we will find
11794  * two files on different disks that share the same encoded device names,
11795  * and even more remote that they will share the same file id (if the test
11796  * is to check for the same file).
11797  *
11798  * A better method might be to use sys$device_scan on the first call, and to
11799  * search for the device, returning an index into the cached array.
11800  * The number returned would be more intelligible.
11801  * This is probably not worth it, and anyway would take quite a bit longer
11802  * on the first call.
11803  */
11804 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11805 static mydev_t encode_dev (pTHX_ const char *dev)
11806 {
11807   int i;
11808   unsigned long int f;
11809   mydev_t enc;
11810   char c;
11811   const char *q;
11812
11813   if (!dev || !dev[0]) return 0;
11814
11815 #if LOCKID_MASK
11816   {
11817     struct dsc$descriptor_s dev_desc;
11818     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11819
11820     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11821        can try that first. */
11822     dev_desc.dsc$w_length =  strlen (dev);
11823     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11824     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11825     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11826     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11827     if (!$VMS_STATUS_SUCCESS(status)) {
11828       switch (status) {
11829         case SS$_NOSUCHDEV:
11830           SETERRNO(ENODEV, status);
11831           return 0;
11832         default:
11833           _ckvmssts(status);
11834       }
11835     }
11836     if (lockid) return (lockid & ~LOCKID_MASK);
11837   }
11838 #endif
11839
11840   /* Otherwise we try to encode the device name */
11841   enc = 0;
11842   f = 1;
11843   i = 0;
11844   for (q = dev + strlen(dev); q--; q >= dev) {
11845     if (*q == ':')
11846         break;
11847     if (isdigit (*q))
11848       c= (*q) - '0';
11849     else if (isalpha (toupper (*q)))
11850       c= toupper (*q) - 'A' + (char)10;
11851     else
11852       continue; /* Skip '$'s */
11853     i++;
11854     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11855     if (i>1) f *= 36;
11856     enc += f * (unsigned long int) c;
11857   }
11858   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11859
11860 }  /* end of encode_dev() */
11861 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11862         device_no = encode_dev(aTHX_ devname)
11863 #else
11864 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11865         device_no = new_dev_no
11866 #endif
11867
11868 static int
11869 is_null_device(const char *name)
11870 {
11871   if (decc_bug_devnull != 0) {
11872     if (strncmp("/dev/null", name, 9) == 0)
11873       return 1;
11874   }
11875     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11876        The underscore prefix, controller letter, and unit number are
11877        independently optional; for our purposes, the colon punctuation
11878        is not.  The colon can be trailed by optional directory and/or
11879        filename, but two consecutive colons indicates a nodename rather
11880        than a device.  [pr]  */
11881   if (*name == '_') ++name;
11882   if (tolower(*name++) != 'n') return 0;
11883   if (tolower(*name++) != 'l') return 0;
11884   if (tolower(*name) == 'a') ++name;
11885   if (*name == '0') ++name;
11886   return (*name++ == ':') && (*name != ':');
11887 }
11888
11889 static int
11890 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11891
11892 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11893
11894 static I32
11895 Perl_cando_by_name_int
11896    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11897 {
11898   char usrname[L_cuserid];
11899   struct dsc$descriptor_s usrdsc =
11900          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11901   char *vmsname = NULL, *fileified = NULL;
11902   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11903   unsigned short int retlen, trnlnm_iter_count;
11904   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11905   union prvdef curprv;
11906   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11907          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11908          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11909   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11910          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11911          {0,0,0,0}};
11912   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11913          {0,0,0,0}};
11914   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11915   Stat_t st;
11916   static int profile_context = -1;
11917
11918   if (!fname || !*fname) return FALSE;
11919
11920   /* Make sure we expand logical names, since sys$check_access doesn't */
11921   fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11922   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11923   if (!strpbrk(fname,"/]>:")) {
11924       my_strlcpy(fileified, fname, VMS_MAXRSS);
11925       trnlnm_iter_count = 0;
11926       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11927         trnlnm_iter_count++;
11928         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11929       }
11930       fname = fileified;
11931   }
11932
11933   vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11934   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11935   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11936     /* Don't know if already in VMS format, so make sure */
11937     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11938       PerlMem_free(fileified);
11939       PerlMem_free(vmsname);
11940       return FALSE;
11941     }
11942   }
11943   else {
11944     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11945   }
11946
11947   /* sys$check_access needs a file spec, not a directory spec.
11948    * flex_stat now will handle a null thread context during startup.
11949    */
11950
11951   retlen = namdsc.dsc$w_length = strlen(vmsname);
11952   if (vmsname[retlen-1] == ']'
11953       || vmsname[retlen-1] == '>'
11954       || vmsname[retlen-1] == ':'
11955       || (!flex_stat_int(vmsname, &st, 1) &&
11956           S_ISDIR(st.st_mode))) {
11957
11958       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11959         PerlMem_free(fileified);
11960         PerlMem_free(vmsname);
11961         return FALSE;
11962       }
11963       fname = fileified;
11964   }
11965   else {
11966       fname = vmsname;
11967   }
11968
11969   retlen = namdsc.dsc$w_length = strlen(fname);
11970   namdsc.dsc$a_pointer = (char *)fname;
11971
11972   switch (bit) {
11973     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11974       access = ARM$M_EXECUTE;
11975       flags = CHP$M_READ;
11976       break;
11977     case S_IRUSR: case S_IRGRP: case S_IROTH:
11978       access = ARM$M_READ;
11979       flags = CHP$M_READ | CHP$M_USEREADALL;
11980       break;
11981     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11982       access = ARM$M_WRITE;
11983       flags = CHP$M_READ | CHP$M_WRITE;
11984       break;
11985     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11986       access = ARM$M_DELETE;
11987       flags = CHP$M_READ | CHP$M_WRITE;
11988       break;
11989     default:
11990       if (fileified != NULL)
11991         PerlMem_free(fileified);
11992       if (vmsname != NULL)
11993         PerlMem_free(vmsname);
11994       return FALSE;
11995   }
11996
11997   /* Before we call $check_access, create a user profile with the current
11998    * process privs since otherwise it just uses the default privs from the
11999    * UAF and might give false positives or negatives.  This only works on
12000    * VMS versions v6.0 and later since that's when sys$create_user_profile
12001    * became available.
12002    */
12003
12004   /* get current process privs and username */
12005   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12006   _ckvmssts_noperl(iosb[0]);
12007
12008   /* find out the space required for the profile */
12009   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12010                                     &usrprodsc.dsc$w_length,&profile_context));
12011
12012   /* allocate space for the profile and get it filled in */
12013   usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
12014   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12015   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12016                                     &usrprodsc.dsc$w_length,&profile_context));
12017
12018   /* use the profile to check access to the file; free profile & analyze results */
12019   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12020   PerlMem_free(usrprodsc.dsc$a_pointer);
12021   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12022
12023   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12024       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12025       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12026     set_vaxc_errno(retsts);
12027     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12028     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12029     else set_errno(ENOENT);
12030     if (fileified != NULL)
12031       PerlMem_free(fileified);
12032     if (vmsname != NULL)
12033       PerlMem_free(vmsname);
12034     return FALSE;
12035   }
12036   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12037     if (fileified != NULL)
12038       PerlMem_free(fileified);
12039     if (vmsname != NULL)
12040       PerlMem_free(vmsname);
12041     return TRUE;
12042   }
12043   _ckvmssts_noperl(retsts);
12044
12045   if (fileified != NULL)
12046     PerlMem_free(fileified);
12047   if (vmsname != NULL)
12048     PerlMem_free(vmsname);
12049   return FALSE;  /* Should never get here */
12050
12051 }
12052
12053 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12054 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12055  * subset of the applicable information.
12056  */
12057 bool
12058 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12059 {
12060   return cando_by_name_int
12061         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12062 }  /* end of cando() */
12063 /*}}}*/
12064
12065
12066 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12067 I32
12068 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12069 {
12070    return cando_by_name_int(bit, effective, fname, 0);
12071
12072 }  /* end of cando_by_name() */
12073 /*}}}*/
12074
12075
12076 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12077 int
12078 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12079 {
12080   dSAVE_ERRNO; /* fstat may set this even on success */
12081   if (!fstat(fd, &statbufp->crtl_stat)) {
12082     char *cptr;
12083     char *vms_filename;
12084     vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12085     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12086
12087     /* Save name for cando by name in VMS format */
12088     cptr = getname(fd, vms_filename, 1);
12089
12090     /* This should not happen, but just in case */
12091     if (cptr == NULL) {
12092         statbufp->st_devnam[0] = 0;
12093     }
12094     else {
12095         /* Make sure that the saved name fits in 255 characters */
12096         cptr = int_rmsexpand_vms
12097                        (vms_filename,
12098                         statbufp->st_devnam,
12099                         0);
12100         if (cptr == NULL)
12101             statbufp->st_devnam[0] = 0;
12102     }
12103     PerlMem_free(vms_filename);
12104
12105     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12106     VMS_DEVICE_ENCODE
12107         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12108
12109 #   ifdef VMSISH_TIME
12110     if (VMSISH_TIME) {
12111       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12112       statbufp->st_atime = _toloc(statbufp->st_atime);
12113       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12114     }
12115 #   endif
12116     RESTORE_ERRNO;
12117     return 0;
12118   }
12119   return -1;
12120
12121 }  /* end of flex_fstat() */
12122 /*}}}*/
12123
12124 static int
12125 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12126 {
12127     char *temp_fspec = NULL;
12128     char *fileified = NULL;
12129     const char *save_spec;
12130     char *ret_spec;
12131     int retval = -1;
12132     char efs_hack = 0;
12133     char already_fileified = 0;
12134     dSAVEDERRNO;
12135
12136     if (!fspec) {
12137         errno = EINVAL;
12138         return retval;
12139     }
12140
12141     if (decc_bug_devnull != 0) {
12142       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12143         memset(statbufp,0,sizeof *statbufp);
12144         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12145         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12146         statbufp->st_uid = 0x00010001;
12147         statbufp->st_gid = 0x0001;
12148         time((time_t *)&statbufp->st_mtime);
12149         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12150         return 0;
12151       }
12152     }
12153
12154     SAVE_ERRNO;
12155
12156 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12157   /*
12158    * If we are in POSIX filespec mode, accept the filename as is.
12159    */
12160   if (decc_posix_compliant_pathnames == 0) {
12161 #endif
12162
12163     /* Try for a simple stat first.  If fspec contains a filename without
12164      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12165      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12166      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12167      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12168      * the file with null type, specify this by calling flex_stat() with
12169      * a '.' at the end of fspec.
12170      */
12171
12172     if (lstat_flag == 0)
12173         retval = stat(fspec, &statbufp->crtl_stat);
12174     else
12175         retval = lstat(fspec, &statbufp->crtl_stat);
12176
12177     if (!retval) {
12178         save_spec = fspec;
12179     }
12180     else {
12181         /* In the odd case where we have write but not read access
12182          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12183          */
12184         fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12185         if (fileified == NULL)
12186               _ckvmssts_noperl(SS$_INSFMEM);
12187
12188         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12189         if (ret_spec != NULL) {
12190             if (lstat_flag == 0)
12191                 retval = stat(fileified, &statbufp->crtl_stat);
12192             else
12193                 retval = lstat(fileified, &statbufp->crtl_stat);
12194             save_spec = fileified;
12195             already_fileified = 1;
12196         }
12197     }
12198
12199     if (retval && vms_bug_stat_filename) {
12200
12201         temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12202         if (temp_fspec == NULL)
12203             _ckvmssts_noperl(SS$_INSFMEM);
12204
12205         /* We should try again as a vmsified file specification. */
12206
12207         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12208         if (ret_spec != NULL) {
12209             if (lstat_flag == 0)
12210                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12211             else
12212                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12213             save_spec = temp_fspec;
12214         }
12215     }
12216
12217     if (retval) {
12218         /* Last chance - allow multiple dots without EFS CHARSET */
12219         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12220          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12221          * enable it if it isn't already.
12222          */
12223 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12224         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12225             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12226 #endif
12227         if (lstat_flag == 0)
12228             retval = stat(fspec, &statbufp->crtl_stat);
12229         else
12230             retval = lstat(fspec, &statbufp->crtl_stat);
12231         save_spec = fspec;
12232 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12233         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12234             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12235             efs_hack = 1;
12236         }
12237 #endif
12238     }
12239
12240 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12241   } else {
12242     if (lstat_flag == 0)
12243       retval = stat(temp_fspec, &statbufp->crtl_stat);
12244     else
12245       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12246       save_spec = temp_fspec;
12247   }
12248 #endif
12249
12250 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12251   /* As you were... */
12252   if (!decc_efs_charset)
12253     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12254 #endif
12255
12256     if (!retval) {
12257       char *cptr;
12258       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12259
12260       /* If this is an lstat, do not follow the link */
12261       if (lstat_flag)
12262         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12263
12264 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12265       /* If we used the efs_hack above, we must also use it here for */
12266       /* perl_cando to work */
12267       if (efs_hack && (decc_efs_charset_index > 0)) {
12268           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12269       }
12270 #endif
12271
12272       /* If we've got a directory, save a fileified, expanded version of it
12273        * in st_devnam.  If not a directory, just an expanded version.
12274        */
12275       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12276           fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12277           if (fileified == NULL)
12278               _ckvmssts_noperl(SS$_INSFMEM);
12279
12280           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12281           if (cptr != NULL)
12282               save_spec = fileified;
12283       }
12284
12285       cptr = int_rmsexpand(save_spec,
12286                            statbufp->st_devnam,
12287                            NULL,
12288                            rmsex_flags,
12289                            0,
12290                            0);
12291
12292 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12293       if (efs_hack && (decc_efs_charset_index > 0)) {
12294           decc$feature_set_value(decc_efs_charset, 1, 0);
12295       }
12296 #endif
12297
12298       /* Fix me: If this is NULL then stat found a file, and we could */
12299       /* not convert the specification to VMS - Should never happen */
12300       if (cptr == NULL)
12301         statbufp->st_devnam[0] = 0;
12302
12303       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12304       VMS_DEVICE_ENCODE
12305         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12306 #     ifdef VMSISH_TIME
12307       if (VMSISH_TIME) {
12308         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12309         statbufp->st_atime = _toloc(statbufp->st_atime);
12310         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12311       }
12312 #     endif
12313     }
12314     /* If we were successful, leave errno where we found it */
12315     if (retval == 0) RESTORE_ERRNO;
12316     if (temp_fspec)
12317         PerlMem_free(temp_fspec);
12318     if (fileified)
12319         PerlMem_free(fileified);
12320     return retval;
12321
12322 }  /* end of flex_stat_int() */
12323
12324
12325 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12326 int
12327 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12328 {
12329    return flex_stat_int(fspec, statbufp, 0);
12330 }
12331 /*}}}*/
12332
12333 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12334 int
12335 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12336 {
12337    return flex_stat_int(fspec, statbufp, 1);
12338 }
12339 /*}}}*/
12340
12341
12342 /*{{{char *my_getlogin()*/
12343 /* VMS cuserid == Unix getlogin, except calling sequence */
12344 char *
12345 my_getlogin(void)
12346 {
12347     static char user[L_cuserid];
12348     return cuserid(user);
12349 }
12350 /*}}}*/
12351
12352
12353 /*  rmscopy - copy a file using VMS RMS routines
12354  *
12355  *  Copies contents and attributes of spec_in to spec_out, except owner
12356  *  and protection information.  Name and type of spec_in are used as
12357  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12358  *  should try to propagate timestamps from the input file to the output file.
12359  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12360  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12361  *  propagated to the output file at creation iff the output file specification
12362  *  did not contain an explicit name or type, and the revision date is always
12363  *  updated at the end of the copy operation.  If it is greater than 0, then
12364  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12365  *  other than the revision date should be propagated, and bit 1 indicates
12366  *  that the revision date should be propagated.
12367  *
12368  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12369  *
12370  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12371  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12372  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12373  * as part of the Perl standard distribution under the terms of the
12374  * GNU General Public License or the Perl Artistic License.  Copies
12375  * of each may be found in the Perl standard distribution.
12376  */ /* FIXME */
12377 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12378 int
12379 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12380 {
12381     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12382          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12383     unsigned long int sts;
12384     int dna_len;
12385     struct FAB fab_in, fab_out;
12386     struct RAB rab_in, rab_out;
12387     rms_setup_nam(nam);
12388     rms_setup_nam(nam_out);
12389     struct XABDAT xabdat;
12390     struct XABFHC xabfhc;
12391     struct XABRDT xabrdt;
12392     struct XABSUM xabsum;
12393
12394     vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12395     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12396     vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12397     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12398     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12399         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12400       PerlMem_free(vmsin);
12401       PerlMem_free(vmsout);
12402       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12403       return 0;
12404     }
12405
12406     esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12407     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12408     esal = NULL;
12409 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12410     esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12411     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12412 #endif
12413     fab_in = cc$rms_fab;
12414     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12415     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12416     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12417     fab_in.fab$l_fop = FAB$M_SQO;
12418     rms_bind_fab_nam(fab_in, nam);
12419     fab_in.fab$l_xab = (void *) &xabdat;
12420
12421     rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12422     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12423     rsal = NULL;
12424 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12425     rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12426     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12427 #endif
12428     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12429     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12430     rms_nam_esl(nam) = 0;
12431     rms_nam_rsl(nam) = 0;
12432     rms_nam_esll(nam) = 0;
12433     rms_nam_rsll(nam) = 0;
12434 #ifdef NAM$M_NO_SHORT_UPCASE
12435     if (decc_efs_case_preserve)
12436         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12437 #endif
12438
12439     xabdat = cc$rms_xabdat;        /* To get creation date */
12440     xabdat.xab$l_nxt = (void *) &xabfhc;
12441
12442     xabfhc = cc$rms_xabfhc;        /* To get record length */
12443     xabfhc.xab$l_nxt = (void *) &xabsum;
12444
12445     xabsum = cc$rms_xabsum;        /* To get key and area information */
12446
12447     if (!((sts = sys$open(&fab_in)) & 1)) {
12448       PerlMem_free(vmsin);
12449       PerlMem_free(vmsout);
12450       PerlMem_free(esa);
12451       if (esal != NULL)
12452         PerlMem_free(esal);
12453       PerlMem_free(rsa);
12454       if (rsal != NULL)
12455         PerlMem_free(rsal);
12456       set_vaxc_errno(sts);
12457       switch (sts) {
12458         case RMS$_FNF: case RMS$_DNF:
12459           set_errno(ENOENT); break;
12460         case RMS$_DIR:
12461           set_errno(ENOTDIR); break;
12462         case RMS$_DEV:
12463           set_errno(ENODEV); break;
12464         case RMS$_SYN:
12465           set_errno(EINVAL); break;
12466         case RMS$_PRV:
12467           set_errno(EACCES); break;
12468         default:
12469           set_errno(EVMSERR);
12470       }
12471       return 0;
12472     }
12473
12474     nam_out = nam;
12475     fab_out = fab_in;
12476     fab_out.fab$w_ifi = 0;
12477     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12478     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12479     fab_out.fab$l_fop = FAB$M_SQO;
12480     rms_bind_fab_nam(fab_out, nam_out);
12481     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12482     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12483     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12484     esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12485     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12486     rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12487     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12488     esal_out = NULL;
12489     rsal_out = NULL;
12490 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12491     esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12492     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12493     rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12494     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12495 #endif
12496     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12497     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12498
12499     if (preserve_dates == 0) {  /* Act like DCL COPY */
12500       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12501       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12502       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12503         PerlMem_free(vmsin);
12504         PerlMem_free(vmsout);
12505         PerlMem_free(esa);
12506         if (esal != NULL)
12507             PerlMem_free(esal);
12508         PerlMem_free(rsa);
12509         if (rsal != NULL)
12510             PerlMem_free(rsal);
12511         PerlMem_free(esa_out);
12512         if (esal_out != NULL)
12513             PerlMem_free(esal_out);
12514         PerlMem_free(rsa_out);
12515         if (rsal_out != NULL)
12516             PerlMem_free(rsal_out);
12517         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12518         set_vaxc_errno(sts);
12519         return 0;
12520       }
12521       fab_out.fab$l_xab = (void *) &xabdat;
12522       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12523         preserve_dates = 1;
12524     }
12525     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12526       preserve_dates =0;      /* bitmask from this point forward   */
12527
12528     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12529     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12530       PerlMem_free(vmsin);
12531       PerlMem_free(vmsout);
12532       PerlMem_free(esa);
12533       if (esal != NULL)
12534           PerlMem_free(esal);
12535       PerlMem_free(rsa);
12536       if (rsal != NULL)
12537           PerlMem_free(rsal);
12538       PerlMem_free(esa_out);
12539       if (esal_out != NULL)
12540           PerlMem_free(esal_out);
12541       PerlMem_free(rsa_out);
12542       if (rsal_out != NULL)
12543           PerlMem_free(rsal_out);
12544       set_vaxc_errno(sts);
12545       switch (sts) {
12546         case RMS$_DNF:
12547           set_errno(ENOENT); break;
12548         case RMS$_DIR:
12549           set_errno(ENOTDIR); break;
12550         case RMS$_DEV:
12551           set_errno(ENODEV); break;
12552         case RMS$_SYN:
12553           set_errno(EINVAL); break;
12554         case RMS$_PRV:
12555           set_errno(EACCES); break;
12556         default:
12557           set_errno(EVMSERR);
12558       }
12559       return 0;
12560     }
12561     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12562     if (preserve_dates & 2) {
12563       /* sys$close() will process xabrdt, not xabdat */
12564       xabrdt = cc$rms_xabrdt;
12565 #ifndef __GNUC__
12566       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12567 #else
12568       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12569        * is unsigned long[2], while DECC & VAXC use a struct */
12570       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12571 #endif
12572       fab_out.fab$l_xab = (void *) &xabrdt;
12573     }
12574
12575     ubf = (char *)PerlMem_malloc(32256);
12576     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12577     rab_in = cc$rms_rab;
12578     rab_in.rab$l_fab = &fab_in;
12579     rab_in.rab$l_rop = RAB$M_BIO;
12580     rab_in.rab$l_ubf = ubf;
12581     rab_in.rab$w_usz = 32256;
12582     if (!((sts = sys$connect(&rab_in)) & 1)) {
12583       sys$close(&fab_in); sys$close(&fab_out);
12584       PerlMem_free(vmsin);
12585       PerlMem_free(vmsout);
12586       PerlMem_free(ubf);
12587       PerlMem_free(esa);
12588       if (esal != NULL)
12589           PerlMem_free(esal);
12590       PerlMem_free(rsa);
12591       if (rsal != NULL)
12592           PerlMem_free(rsal);
12593       PerlMem_free(esa_out);
12594       if (esal_out != NULL)
12595           PerlMem_free(esal_out);
12596       PerlMem_free(rsa_out);
12597       if (rsal_out != NULL)
12598           PerlMem_free(rsal_out);
12599       set_errno(EVMSERR); set_vaxc_errno(sts);
12600       return 0;
12601     }
12602
12603     rab_out = cc$rms_rab;
12604     rab_out.rab$l_fab = &fab_out;
12605     rab_out.rab$l_rbf = ubf;
12606     if (!((sts = sys$connect(&rab_out)) & 1)) {
12607       sys$close(&fab_in); sys$close(&fab_out);
12608       PerlMem_free(vmsin);
12609       PerlMem_free(vmsout);
12610       PerlMem_free(ubf);
12611       PerlMem_free(esa);
12612       if (esal != NULL)
12613           PerlMem_free(esal);
12614       PerlMem_free(rsa);
12615       if (rsal != NULL)
12616           PerlMem_free(rsal);
12617       PerlMem_free(esa_out);
12618       if (esal_out != NULL)
12619           PerlMem_free(esal_out);
12620       PerlMem_free(rsa_out);
12621       if (rsal_out != NULL)
12622           PerlMem_free(rsal_out);
12623       set_errno(EVMSERR); set_vaxc_errno(sts);
12624       return 0;
12625     }
12626
12627     while ((sts = sys$read(&rab_in))) {  /* always true  */
12628       if (sts == RMS$_EOF) break;
12629       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12630       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12631         sys$close(&fab_in); sys$close(&fab_out);
12632         PerlMem_free(vmsin);
12633         PerlMem_free(vmsout);
12634         PerlMem_free(ubf);
12635         PerlMem_free(esa);
12636         if (esal != NULL)
12637             PerlMem_free(esal);
12638         PerlMem_free(rsa);
12639         if (rsal != NULL)
12640             PerlMem_free(rsal);
12641         PerlMem_free(esa_out);
12642         if (esal_out != NULL)
12643             PerlMem_free(esal_out);
12644         PerlMem_free(rsa_out);
12645         if (rsal_out != NULL)
12646             PerlMem_free(rsal_out);
12647         set_errno(EVMSERR); set_vaxc_errno(sts);
12648         return 0;
12649       }
12650     }
12651
12652
12653     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12654     sys$close(&fab_in);  sys$close(&fab_out);
12655     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12656
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
12673     if (!(sts & 1)) {
12674       set_errno(EVMSERR); set_vaxc_errno(sts);
12675       return 0;
12676     }
12677
12678     return 1;
12679
12680 }  /* end of rmscopy() */
12681 /*}}}*/
12682
12683
12684 /***  The following glue provides 'hooks' to make some of the routines
12685  * from this file available from Perl.  These routines are sufficiently
12686  * basic, and are required sufficiently early in the build process,
12687  * that's it's nice to have them available to miniperl as well as the
12688  * full Perl, so they're set up here instead of in an extension.  The
12689  * Perl code which handles importation of these names into a given
12690  * package lives in [.VMS]Filespec.pm in @INC.
12691  */
12692
12693 void
12694 rmsexpand_fromperl(pTHX_ CV *cv)
12695 {
12696   dXSARGS;
12697   char *fspec, *defspec = NULL, *rslt;
12698   STRLEN n_a;
12699   int fs_utf8, dfs_utf8;
12700
12701   fs_utf8 = 0;
12702   dfs_utf8 = 0;
12703   if (!items || items > 2)
12704     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12705   fspec = SvPV(ST(0),n_a);
12706   fs_utf8 = SvUTF8(ST(0));
12707   if (!fspec || !*fspec) XSRETURN_UNDEF;
12708   if (items == 2) {
12709     defspec = SvPV(ST(1),n_a);
12710     dfs_utf8 = SvUTF8(ST(1));
12711   }
12712   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12713   ST(0) = sv_newmortal();
12714   if (rslt != NULL) {
12715     sv_usepvn(ST(0),rslt,strlen(rslt));
12716     if (fs_utf8) {
12717         SvUTF8_on(ST(0));
12718     }
12719   }
12720   XSRETURN(1);
12721 }
12722
12723 void
12724 vmsify_fromperl(pTHX_ CV *cv)
12725 {
12726   dXSARGS;
12727   char *vmsified;
12728   STRLEN n_a;
12729   int utf8_fl;
12730
12731   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12732   utf8_fl = SvUTF8(ST(0));
12733   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12734   ST(0) = sv_newmortal();
12735   if (vmsified != NULL) {
12736     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12737     if (utf8_fl) {
12738         SvUTF8_on(ST(0));
12739     }
12740   }
12741   XSRETURN(1);
12742 }
12743
12744 void
12745 unixify_fromperl(pTHX_ CV *cv)
12746 {
12747   dXSARGS;
12748   char *unixified;
12749   STRLEN n_a;
12750   int utf8_fl;
12751
12752   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12753   utf8_fl = SvUTF8(ST(0));
12754   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12755   ST(0) = sv_newmortal();
12756   if (unixified != NULL) {
12757     sv_usepvn(ST(0),unixified,strlen(unixified));
12758     if (utf8_fl) {
12759         SvUTF8_on(ST(0));
12760     }
12761   }
12762   XSRETURN(1);
12763 }
12764
12765 void
12766 fileify_fromperl(pTHX_ CV *cv)
12767 {
12768   dXSARGS;
12769   char *fileified;
12770   STRLEN n_a;
12771   int utf8_fl;
12772
12773   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12774   utf8_fl = SvUTF8(ST(0));
12775   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12776   ST(0) = sv_newmortal();
12777   if (fileified != NULL) {
12778     sv_usepvn(ST(0),fileified,strlen(fileified));
12779     if (utf8_fl) {
12780         SvUTF8_on(ST(0));
12781     }
12782   }
12783   XSRETURN(1);
12784 }
12785
12786 void
12787 pathify_fromperl(pTHX_ CV *cv)
12788 {
12789   dXSARGS;
12790   char *pathified;
12791   STRLEN n_a;
12792   int utf8_fl;
12793
12794   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12795   utf8_fl = SvUTF8(ST(0));
12796   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12797   ST(0) = sv_newmortal();
12798   if (pathified != NULL) {
12799     sv_usepvn(ST(0),pathified,strlen(pathified));
12800     if (utf8_fl) {
12801         SvUTF8_on(ST(0));
12802     }
12803   }
12804   XSRETURN(1);
12805 }
12806
12807 void
12808 vmspath_fromperl(pTHX_ CV *cv)
12809 {
12810   dXSARGS;
12811   char *vmspath;
12812   STRLEN n_a;
12813   int utf8_fl;
12814
12815   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12816   utf8_fl = SvUTF8(ST(0));
12817   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12818   ST(0) = sv_newmortal();
12819   if (vmspath != NULL) {
12820     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12821     if (utf8_fl) {
12822         SvUTF8_on(ST(0));
12823     }
12824   }
12825   XSRETURN(1);
12826 }
12827
12828 void
12829 unixpath_fromperl(pTHX_ CV *cv)
12830 {
12831   dXSARGS;
12832   char *unixpath;
12833   STRLEN n_a;
12834   int utf8_fl;
12835
12836   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12837   utf8_fl = SvUTF8(ST(0));
12838   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12839   ST(0) = sv_newmortal();
12840   if (unixpath != NULL) {
12841     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12842     if (utf8_fl) {
12843         SvUTF8_on(ST(0));
12844     }
12845   }
12846   XSRETURN(1);
12847 }
12848
12849 void
12850 candelete_fromperl(pTHX_ CV *cv)
12851 {
12852   dXSARGS;
12853   char *fspec, *fsp;
12854   SV *mysv;
12855   IO *io;
12856   STRLEN n_a;
12857
12858   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12859
12860   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12861   Newx(fspec, VMS_MAXRSS, char);
12862   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12863   if (isGV_with_GP(mysv)) {
12864     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12865       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12866       ST(0) = &PL_sv_no;
12867       Safefree(fspec);
12868       XSRETURN(1);
12869     }
12870     fsp = fspec;
12871   }
12872   else {
12873     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12874       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12875       ST(0) = &PL_sv_no;
12876       Safefree(fspec);
12877       XSRETURN(1);
12878     }
12879   }
12880
12881   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12882   Safefree(fspec);
12883   XSRETURN(1);
12884 }
12885
12886 void
12887 rmscopy_fromperl(pTHX_ CV *cv)
12888 {
12889   dXSARGS;
12890   char *inspec, *outspec, *inp, *outp;
12891   int date_flag;
12892   SV *mysv;
12893   IO *io;
12894   STRLEN n_a;
12895
12896   if (items < 2 || items > 3)
12897     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12898
12899   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12900   Newx(inspec, VMS_MAXRSS, char);
12901   if (isGV_with_GP(mysv)) {
12902     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12903       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12904       ST(0) = sv_2mortal(newSViv(0));
12905       Safefree(inspec);
12906       XSRETURN(1);
12907     }
12908     inp = inspec;
12909   }
12910   else {
12911     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12912       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12913       ST(0) = sv_2mortal(newSViv(0));
12914       Safefree(inspec);
12915       XSRETURN(1);
12916     }
12917   }
12918   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12919   Newx(outspec, VMS_MAXRSS, char);
12920   if (isGV_with_GP(mysv)) {
12921     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12922       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12923       ST(0) = sv_2mortal(newSViv(0));
12924       Safefree(inspec);
12925       Safefree(outspec);
12926       XSRETURN(1);
12927     }
12928     outp = outspec;
12929   }
12930   else {
12931     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12932       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12933       ST(0) = sv_2mortal(newSViv(0));
12934       Safefree(inspec);
12935       Safefree(outspec);
12936       XSRETURN(1);
12937     }
12938   }
12939   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12940
12941   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12942   Safefree(inspec);
12943   Safefree(outspec);
12944   XSRETURN(1);
12945 }
12946
12947 /* The mod2fname is limited to shorter filenames by design, so it should
12948  * not be modified to support longer EFS pathnames
12949  */
12950 void
12951 mod2fname(pTHX_ CV *cv)
12952 {
12953   dXSARGS;
12954   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12955        workbuff[NAM$C_MAXRSS*1 + 1];
12956   SSize_t counter, num_entries;
12957   /* ODS-5 ups this, but we want to be consistent, so... */
12958   int max_name_len = 39;
12959   AV *in_array = (AV *)SvRV(ST(0));
12960
12961   num_entries = av_len(in_array);
12962
12963   /* All the names start with PL_. */
12964   strcpy(ultimate_name, "PL_");
12965
12966   /* Clean up our working buffer */
12967   Zero(work_name, sizeof(work_name), char);
12968
12969   /* Run through the entries and build up a working name */
12970   for(counter = 0; counter <= num_entries; counter++) {
12971     /* If it's not the first name then tack on a __ */
12972     if (counter) {
12973       my_strlcat(work_name, "__", sizeof(work_name));
12974     }
12975     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12976   }
12977
12978   /* Check to see if we actually have to bother...*/
12979   if (strlen(work_name) + 3 <= max_name_len) {
12980     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12981   } else {
12982     /* It's too darned big, so we need to go strip. We use the same */
12983     /* algorithm as xsubpp does. First, strip out doubled __ */
12984     char *source, *dest, last;
12985     dest = workbuff;
12986     last = 0;
12987     for (source = work_name; *source; source++) {
12988       if (last == *source && last == '_') {
12989         continue;
12990       }
12991       *dest++ = *source;
12992       last = *source;
12993     }
12994     /* Go put it back */
12995     my_strlcpy(work_name, workbuff, sizeof(work_name));
12996     /* Is it still too big? */
12997     if (strlen(work_name) + 3 > max_name_len) {
12998       /* Strip duplicate letters */
12999       last = 0;
13000       dest = workbuff;
13001       for (source = work_name; *source; source++) {
13002         if (last == toupper(*source)) {
13003         continue;
13004         }
13005         *dest++ = *source;
13006         last = toupper(*source);
13007       }
13008       my_strlcpy(work_name, workbuff, sizeof(work_name));
13009     }
13010
13011     /* Is it *still* too big? */
13012     if (strlen(work_name) + 3 > max_name_len) {
13013       /* Too bad, we truncate */
13014       work_name[max_name_len - 2] = 0;
13015     }
13016     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
13017   }
13018
13019   /* Okay, return it */
13020   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13021   XSRETURN(1);
13022 }
13023
13024 void
13025 hushexit_fromperl(pTHX_ CV *cv)
13026 {
13027     dXSARGS;
13028
13029     if (items > 0) {
13030         VMSISH_HUSHED = SvTRUE(ST(0));
13031     }
13032     ST(0) = boolSV(VMSISH_HUSHED);
13033     XSRETURN(1);
13034 }
13035
13036
13037 PerlIO *
13038 Perl_vms_start_glob
13039    (pTHX_ SV *tmpglob,
13040     IO *io)
13041 {
13042     PerlIO *fp;
13043     struct vs_str_st *rslt;
13044     char *vmsspec;
13045     char *rstr;
13046     char *begin, *cp;
13047     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13048     PerlIO *tmpfp;
13049     STRLEN i;
13050     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13051     struct dsc$descriptor_vs rsdsc;
13052     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13053     unsigned long hasver = 0, isunix = 0;
13054     unsigned long int lff_flags = 0;
13055     int rms_sts;
13056     int vms_old_glob = 1;
13057
13058     if (!SvOK(tmpglob)) {
13059         SETERRNO(ENOENT,RMS$_FNF);
13060         return NULL;
13061     }
13062
13063     vms_old_glob = !decc_filename_unix_report;
13064
13065 #ifdef VMS_LONGNAME_SUPPORT
13066     lff_flags = LIB$M_FIL_LONG_NAMES;
13067 #endif
13068     /* The Newx macro will not allow me to assign a smaller array
13069      * to the rslt pointer, so we will assign it to the begin char pointer
13070      * and then copy the value into the rslt pointer.
13071      */
13072     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13073     rslt = (struct vs_str_st *)begin;
13074     rslt->length = 0;
13075     rstr = &rslt->str[0];
13076     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13077     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13078     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13079     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13080
13081     Newx(vmsspec, VMS_MAXRSS, char);
13082
13083         /* We could find out if there's an explicit dev/dir or version
13084            by peeking into lib$find_file's internal context at
13085            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13086            but that's unsupported, so I don't want to do it now and
13087            have it bite someone in the future. */
13088         /* Fix-me: vms_split_path() is the only way to do this, the
13089            existing method will fail with many legal EFS or UNIX specifications
13090          */
13091
13092     cp = SvPV(tmpglob,i);
13093
13094     for (; i; i--) {
13095         if (cp[i] == ';') hasver = 1;
13096         if (cp[i] == '.') {
13097             if (sts) hasver = 1;
13098             else sts = 1;
13099         }
13100         if (cp[i] == '/') {
13101             hasdir = isunix = 1;
13102             break;
13103         }
13104         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13105             hasdir = 1;
13106             break;
13107         }
13108     }
13109
13110     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13111     if ((hasdir == 0) && decc_filename_unix_report) {
13112         isunix = 1;
13113     }
13114
13115     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13116         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13117         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13118         int wildstar = 0;
13119         int wildquery = 0;
13120         int found = 0;
13121         Stat_t st;
13122         int stat_sts;
13123         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13124         if (!stat_sts && S_ISDIR(st.st_mode)) {
13125             char * vms_dir;
13126             const char * fname;
13127             STRLEN fname_len;
13128
13129             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13130             /* path delimiter of ':>]', if so, then the old behavior has */
13131             /* obviously been specifically requested */
13132
13133             fname = SvPVX_const(tmpglob);
13134             fname_len = strlen(fname);
13135             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13136             if (vms_old_glob || (vms_dir != NULL)) {
13137                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13138                                             SvPVX(tmpglob),vmsspec,NULL);
13139                 ok = (wilddsc.dsc$a_pointer != NULL);
13140                 /* maybe passed 'foo' rather than '[.foo]', thus not
13141                    detected above */
13142                 hasdir = 1;
13143             } else {
13144                 /* Operate just on the directory, the special stat/fstat for */
13145                 /* leaves the fileified  specification in the st_devnam */
13146                 /* member. */
13147                 wilddsc.dsc$a_pointer = st.st_devnam;
13148                 ok = 1;
13149             }
13150         }
13151         else {
13152             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13153             ok = (wilddsc.dsc$a_pointer != NULL);
13154         }
13155         if (ok)
13156             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13157
13158         /* If not extended character set, replace ? with % */
13159         /* With extended character set, ? is a wildcard single character */
13160         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13161             if (*cp == '?') {
13162                 wildquery = 1;
13163                 if (!decc_efs_charset)
13164                     *cp = '%';
13165             } else if (*cp == '%') {
13166                 wildquery = 1;
13167             } else if (*cp == '*') {
13168                 wildstar = 1;
13169             }
13170         }
13171
13172         if (ok) {
13173             wv_sts = vms_split_path(
13174                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13175                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13176                 &wvs_spec, &wvs_len);
13177         } else {
13178             wn_spec = NULL;
13179             wn_len = 0;
13180             we_spec = NULL;
13181             we_len = 0;
13182         }
13183
13184         sts = SS$_NORMAL;
13185         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13186          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13187          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13188          int valid_find;
13189
13190             valid_find = 0;
13191             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13192                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13193             if (!$VMS_STATUS_SUCCESS(sts))
13194                 break;
13195
13196             /* with varying string, 1st word of buffer contains result length */
13197             rstr[rslt->length] = '\0';
13198
13199              /* Find where all the components are */
13200              v_sts = vms_split_path
13201                        (rstr,
13202                         &v_spec,
13203                         &v_len,
13204                         &r_spec,
13205                         &r_len,
13206                         &d_spec,
13207                         &d_len,
13208                         &n_spec,
13209                         &n_len,
13210                         &e_spec,
13211                         &e_len,
13212                         &vs_spec,
13213                         &vs_len);
13214
13215             /* If no version on input, truncate the version on output */
13216             if (!hasver && (vs_len > 0)) {
13217                 *vs_spec = '\0';
13218                 vs_len = 0;
13219             }
13220
13221             if (isunix) {
13222
13223                 /* In Unix report mode, remove the ".dir;1" from the name */
13224                 /* if it is a real directory */
13225                 if (decc_filename_unix_report && decc_efs_charset) {
13226                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13227                         Stat_t statbuf;
13228                         int ret_sts;
13229
13230                         ret_sts = flex_lstat(rstr, &statbuf);
13231                         if ((ret_sts == 0) &&
13232                             S_ISDIR(statbuf.st_mode)) {
13233                             e_len = 0;
13234                             e_spec[0] = 0;
13235                         }
13236                     }
13237                 }
13238
13239                 /* No version & a null extension on UNIX handling */
13240                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13241                     e_len = 0;
13242                     *e_spec = '\0';
13243                 }
13244             }
13245
13246             if (!decc_efs_case_preserve) {
13247                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13248             }
13249
13250             /* Find File treats a Null extension as return all extensions */
13251             /* This is contrary to Perl expectations */
13252
13253             if (wildstar || wildquery || vms_old_glob) {
13254                 /* really need to see if the returned file name matched */
13255                 /* but for now will assume that it matches */
13256                 valid_find = 1;
13257             } else {
13258                 /* Exact Match requested */
13259                 /* How are directories handled? - like a file */
13260                 if ((e_len == we_len) && (n_len == wn_len)) {
13261                     int t1;
13262                     t1 = e_len;
13263                     if (t1 > 0)
13264                         t1 = strncmp(e_spec, we_spec, e_len);
13265                     if (t1 == 0) {
13266                        t1 = n_len;
13267                        if (t1 > 0)
13268                            t1 = strncmp(n_spec, we_spec, n_len);
13269                        if (t1 == 0)
13270                            valid_find = 1;
13271                     }
13272                 }
13273             }
13274
13275             if (valid_find) {
13276                 found++;
13277
13278                 if (hasdir) {
13279                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13280                     begin = rstr;
13281                 }
13282                 else {
13283                     /* Start with the name */
13284                     begin = n_spec;
13285                 }
13286                 strcat(begin,"\n");
13287                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13288             }
13289         }
13290         if (cxt) (void)lib$find_file_end(&cxt);
13291
13292         if (!found) {
13293             /* Be POSIXish: return the input pattern when no matches */
13294             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13295             strcat(rstr,"\n");
13296             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13297         }
13298
13299         if (ok && sts != RMS$_NMF &&
13300             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13301         if (!ok) {
13302             if (!(sts & 1)) {
13303                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13304             }
13305             PerlIO_close(tmpfp);
13306             fp = NULL;
13307         }
13308         else {
13309             PerlIO_rewind(tmpfp);
13310             IoTYPE(io) = IoTYPE_RDONLY;
13311             IoIFP(io) = fp = tmpfp;
13312             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13313         }
13314     }
13315     Safefree(vmsspec);
13316     Safefree(rslt);
13317     return fp;
13318 }
13319
13320
13321 static char *
13322 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13323                    int *utf8_fl);
13324
13325 void
13326 unixrealpath_fromperl(pTHX_ CV *cv)
13327 {
13328     dXSARGS;
13329     char *fspec, *rslt_spec, *rslt;
13330     STRLEN n_a;
13331
13332     if (!items || items != 1)
13333         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13334
13335     fspec = SvPV(ST(0),n_a);
13336     if (!fspec || !*fspec) XSRETURN_UNDEF;
13337
13338     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13339     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13340
13341     ST(0) = sv_newmortal();
13342     if (rslt != NULL)
13343         sv_usepvn(ST(0),rslt,strlen(rslt));
13344     else
13345         Safefree(rslt_spec);
13346         XSRETURN(1);
13347 }
13348
13349 static char *
13350 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13351                    int *utf8_fl);
13352
13353 void
13354 vmsrealpath_fromperl(pTHX_ CV *cv)
13355 {
13356     dXSARGS;
13357     char *fspec, *rslt_spec, *rslt;
13358     STRLEN n_a;
13359
13360     if (!items || items != 1)
13361         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13362
13363     fspec = SvPV(ST(0),n_a);
13364     if (!fspec || !*fspec) XSRETURN_UNDEF;
13365
13366     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13367     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13368
13369     ST(0) = sv_newmortal();
13370     if (rslt != NULL)
13371         sv_usepvn(ST(0),rslt,strlen(rslt));
13372     else
13373         Safefree(rslt_spec);
13374         XSRETURN(1);
13375 }
13376
13377 #ifdef HAS_SYMLINK
13378 /*
13379  * A thin wrapper around decc$symlink to make sure we follow the
13380  * standard and do not create a symlink with a zero-length name,
13381  * and convert the target to Unix format, as the CRTL can't handle
13382  * targets in VMS format.
13383  */
13384 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13385 int
13386 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13387 {
13388     int sts;
13389     char * utarget;
13390
13391     if (!link_name || !*link_name) {
13392       SETERRNO(ENOENT, SS$_NOSUCHFILE);
13393       return -1;
13394     }
13395
13396     utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13397     /* An untranslatable filename should be passed through. */
13398     (void) int_tounixspec(contents, utarget, NULL);
13399     sts = symlink(utarget, link_name);
13400     PerlMem_free(utarget);
13401     return sts;
13402 }
13403 /*}}}*/
13404
13405 #endif /* HAS_SYMLINK */
13406
13407 int do_vms_case_tolerant(void);
13408
13409 void
13410 case_tolerant_process_fromperl(pTHX_ CV *cv)
13411 {
13412   dXSARGS;
13413   ST(0) = boolSV(do_vms_case_tolerant());
13414   XSRETURN(1);
13415 }
13416
13417 #ifdef USE_ITHREADS
13418
13419 void
13420 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13421                           struct interp_intern *dst)
13422 {
13423     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13424
13425     memcpy(dst,src,sizeof(struct interp_intern));
13426 }
13427
13428 #endif
13429
13430 void
13431 Perl_sys_intern_clear(pTHX)
13432 {
13433 }
13434
13435 void
13436 Perl_sys_intern_init(pTHX)
13437 {
13438     unsigned int ix = RAND_MAX;
13439     double x;
13440
13441     VMSISH_HUSHED = 0;
13442
13443     MY_POSIX_EXIT = vms_posix_exit;
13444
13445     x = (float)ix;
13446     MY_INV_RAND_MAX = 1./x;
13447 }
13448
13449 void
13450 init_os_extras(void)
13451 {
13452   dTHX;
13453   char* file = __FILE__;
13454   if (decc_disable_to_vms_logname_translation) {
13455     no_translate_barewords = TRUE;
13456   } else {
13457     no_translate_barewords = FALSE;
13458   }
13459
13460   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13461   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13462   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13463   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13464   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13465   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13466   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13467   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13468   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13469   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13470   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13471   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13472   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13473   newXSproto("VMS::Filespec::case_tolerant_process",
13474       case_tolerant_process_fromperl,file,"");
13475
13476   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13477
13478   return;
13479 }
13480
13481 #if __CRTL_VER == 80200000
13482 /* This missed getting in to the DECC SDK for 8.2 */
13483 char *realpath(const char *file_name, char * resolved_name, ...);
13484 #endif
13485
13486 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13487 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13488  * The perl fallback routine to provide realpath() is not as efficient
13489  * on OpenVMS.
13490  */
13491
13492 #ifdef __cplusplus
13493 extern "C" {
13494 #endif
13495
13496 /* Hack, use old stat() as fastest way of getting ino_t and device */
13497 int decc$stat(const char *name, void * statbuf);
13498 #if !defined(__VAX) && __CRTL_VER >= 80200000
13499 int decc$lstat(const char *name, void * statbuf);
13500 #else
13501 #define decc$lstat decc$stat
13502 #endif
13503
13504 #ifdef __cplusplus
13505 }
13506 #endif
13507
13508
13509 /* Realpath is fragile.  In 8.3 it does not work if the feature
13510  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13511  * links are implemented in RMS, not the CRTL. It also can fail if the
13512  * user does not have read/execute access to some of the directories.
13513  * So in order for Do What I Mean mode to work, if realpath() fails,
13514  * fall back to looking up the filename by the device name and FID.
13515  */
13516
13517 int vms_fid_to_name(char * outname, int outlen,
13518                     const char * name, int lstat_flag, mode_t * mode)
13519 {
13520 #pragma message save
13521 #pragma message disable MISALGNDSTRCT
13522 #pragma message disable MISALGNDMEM
13523 #pragma member_alignment save
13524 #pragma nomember_alignment
13525 struct statbuf_t {
13526     char           * st_dev;
13527     unsigned short st_ino[3];
13528     unsigned short old_st_mode;
13529     unsigned long  padl[30];  /* plenty of room */
13530 } statbuf;
13531 #pragma message restore
13532 #pragma member_alignment restore
13533
13534     int sts;
13535     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13536     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13537     char *fileified;
13538     char *temp_fspec;
13539     char *ret_spec;
13540
13541     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13542      * unexpected answers
13543      */
13544
13545     fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13546     if (fileified == NULL)
13547         _ckvmssts_noperl(SS$_INSFMEM);
13548
13549     temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13550     if (temp_fspec == NULL)
13551         _ckvmssts_noperl(SS$_INSFMEM);
13552
13553     sts = -1;
13554     /* First need to try as a directory */
13555     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13556     if (ret_spec != NULL) {
13557         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13558         if (ret_spec != NULL) {
13559             if (lstat_flag == 0)
13560                 sts = decc$stat(fileified, &statbuf);
13561             else
13562                 sts = decc$lstat(fileified, &statbuf);
13563         }
13564     }
13565
13566     /* Then as a VMS file spec */
13567     if (sts != 0) {
13568         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13569         if (ret_spec != NULL) {
13570             if (lstat_flag == 0) {
13571                 sts = decc$stat(temp_fspec, &statbuf);
13572             } else {
13573                 sts = decc$lstat(temp_fspec, &statbuf);
13574             }
13575         }
13576     }
13577
13578     if (sts) {
13579         /* Next try - allow multiple dots with out EFS CHARSET */
13580         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13581          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13582          * enable it if it isn't already.
13583          */
13584 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13585         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13586             decc$feature_set_value(decc_efs_charset_index, 1, 1);
13587 #endif
13588         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13589         if (lstat_flag == 0) {
13590             sts = decc$stat(name, &statbuf);
13591         } else {
13592             sts = decc$lstat(name, &statbuf);
13593         }
13594 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13595         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13596             decc$feature_set_value(decc_efs_charset_index, 1, 0);
13597 #endif
13598     }
13599
13600
13601     /* and then because the Perl Unix to VMS conversion is not perfect */
13602     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13603     /* characters from filenames so we need to try it as-is */
13604     if (sts) {
13605         if (lstat_flag == 0) {
13606             sts = decc$stat(name, &statbuf);
13607         } else {
13608             sts = decc$lstat(name, &statbuf);
13609         }
13610     }
13611
13612     if (sts == 0) {
13613         int vms_sts;
13614
13615         dvidsc.dsc$a_pointer=statbuf.st_dev;
13616         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13617
13618         specdsc.dsc$a_pointer = outname;
13619         specdsc.dsc$w_length = outlen-1;
13620
13621         vms_sts = lib$fid_to_name
13622             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13623         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13624             outname[specdsc.dsc$w_length] = 0;
13625
13626             /* Return the mode */
13627             if (mode) {
13628                 *mode = statbuf.old_st_mode;
13629             }
13630         }
13631     }
13632     PerlMem_free(temp_fspec);
13633     PerlMem_free(fileified);
13634     return sts;
13635 }
13636
13637
13638
13639 static char *
13640 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13641                    int *utf8_fl)
13642 {
13643     char * rslt = NULL;
13644
13645 #ifdef HAS_SYMLINK
13646     if (decc_posix_compliant_pathnames > 0 ) {
13647         /* realpath currently only works if posix compliant pathnames are
13648          * enabled.  It may start working when they are not, but in that
13649          * case we still want the fallback behavior for backwards compatibility
13650          */
13651         rslt = realpath(filespec, outbuf);
13652     }
13653 #endif
13654
13655     if (rslt == NULL) {
13656         char * vms_spec;
13657         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13658         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13659         mode_t my_mode;
13660
13661         /* Fall back to fid_to_name */
13662
13663         Newx(vms_spec, VMS_MAXRSS + 1, char);
13664
13665         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13666         if (sts == 0) {
13667
13668
13669             /* Now need to trim the version off */
13670             sts = vms_split_path
13671                   (vms_spec,
13672                    &v_spec,
13673                    &v_len,
13674                    &r_spec,
13675                    &r_len,
13676                    &d_spec,
13677                    &d_len,
13678                    &n_spec,
13679                    &n_len,
13680                    &e_spec,
13681                    &e_len,
13682                    &vs_spec,
13683                    &vs_len);
13684
13685
13686                 if (sts == 0) {
13687                     int haslower = 0;
13688                     const char *cp;
13689
13690                     /* Trim off the version */
13691                     int file_len = v_len + r_len + d_len + n_len + e_len;
13692                     vms_spec[file_len] = 0;
13693
13694                     /* Trim off the .DIR if this is a directory */
13695                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13696                         if (S_ISDIR(my_mode)) {
13697                             e_len = 0;
13698                             e_spec[0] = 0;
13699                         }
13700                     }
13701
13702                     /* Drop NULL extensions on UNIX file specification */
13703                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
13704                         e_len = 0;
13705                         e_spec[0] = '\0';
13706                     }
13707
13708                     /* The result is expected to be in UNIX format */
13709                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13710
13711                     /* Downcase if input had any lower case letters and
13712                      * case preservation is not in effect.
13713                      */
13714                     if (!decc_efs_case_preserve) {
13715                         for (cp = filespec; *cp; cp++)
13716                             if (islower(*cp)) { haslower = 1; break; }
13717
13718                         if (haslower) __mystrtolower(rslt);
13719                     }
13720                 }
13721         } else {
13722
13723             /* Now for some hacks to deal with backwards and forward */
13724             /* compatibility */
13725             if (!decc_efs_charset) {
13726
13727                 /* 1. ODS-2 mode wants to do a syntax only translation */
13728                 rslt = int_rmsexpand(filespec, outbuf,
13729                                     NULL, 0, NULL, utf8_fl);
13730
13731             } else {
13732                 if (decc_filename_unix_report) {
13733                     char * dir_name;
13734                     char * vms_dir_name;
13735                     char * file_name;
13736
13737                     /* 2. ODS-5 / UNIX report mode should return a failure */
13738                     /*    if the parent directory also does not exist */
13739                     /*    Otherwise, get the real path for the parent */
13740                     /*    and add the child to it. */
13741
13742                     /* basename / dirname only available for VMS 7.0+ */
13743                     /* So we may need to implement them as common routines */
13744
13745                     Newx(dir_name, VMS_MAXRSS + 1, char);
13746                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13747                     dir_name[0] = '\0';
13748                     file_name = NULL;
13749
13750                     /* First try a VMS parse */
13751                     sts = vms_split_path
13752                           (filespec,
13753                            &v_spec,
13754                            &v_len,
13755                            &r_spec,
13756                            &r_len,
13757                            &d_spec,
13758                            &d_len,
13759                            &n_spec,
13760                            &n_len,
13761                            &e_spec,
13762                            &e_len,
13763                            &vs_spec,
13764                            &vs_len);
13765
13766                     if (sts == 0) {
13767                         /* This is VMS */
13768
13769                         int dir_len = v_len + r_len + d_len + n_len;
13770                         if (dir_len > 0) {
13771                            memcpy(dir_name, filespec, dir_len);
13772                            dir_name[dir_len] = '\0';
13773                            file_name = (char *)&filespec[dir_len + 1];
13774                         }
13775                     } else {
13776                         /* This must be UNIX */
13777                         char * tchar;
13778
13779                         tchar = strrchr(filespec, '/');
13780
13781                         if (tchar != NULL) {
13782                             int dir_len = tchar - filespec;
13783                             memcpy(dir_name, filespec, dir_len);
13784                             dir_name[dir_len] = '\0';
13785                             file_name = (char *) &filespec[dir_len + 1];
13786                         }
13787                     }
13788
13789                     /* Dir name is defaulted */
13790                     if (dir_name[0] == 0) {
13791                         dir_name[0] = '.';
13792                         dir_name[1] = '\0';
13793                     }
13794
13795                     /* Need realpath for the directory */
13796                     sts = vms_fid_to_name(vms_dir_name,
13797                                           VMS_MAXRSS + 1,
13798                                           dir_name, 0, NULL);
13799
13800                     if (sts == 0) {
13801                         /* Now need to pathify it. */
13802                         char *tdir = int_pathify_dirspec(vms_dir_name,
13803                                                          outbuf);
13804
13805                         /* And now add the original filespec to it */
13806                         if (file_name != NULL) {
13807                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13808                         }
13809                         return outbuf;
13810                     }
13811                     Safefree(vms_dir_name);
13812                     Safefree(dir_name);
13813                 }
13814             }
13815         }
13816         Safefree(vms_spec);
13817     }
13818     return rslt;
13819 }
13820
13821 static char *
13822 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13823                    int *utf8_fl)
13824 {
13825     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13826     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13827
13828     /* Fall back to fid_to_name */
13829
13830     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13831     if (sts != 0) {
13832         return NULL;
13833     }
13834     else {
13835
13836
13837         /* Now need to trim the version off */
13838         sts = vms_split_path
13839                   (outbuf,
13840                    &v_spec,
13841                    &v_len,
13842                    &r_spec,
13843                    &r_len,
13844                    &d_spec,
13845                    &d_len,
13846                    &n_spec,
13847                    &n_len,
13848                    &e_spec,
13849                    &e_len,
13850                    &vs_spec,
13851                    &vs_len);
13852
13853
13854         if (sts == 0) {
13855             int haslower = 0;
13856             const char *cp;
13857
13858             /* Trim off the version */
13859             int file_len = v_len + r_len + d_len + n_len + e_len;
13860             outbuf[file_len] = 0;
13861
13862             /* Downcase if input had any lower case letters and
13863              * case preservation is not in effect.
13864              */
13865             if (!decc_efs_case_preserve) {
13866                 for (cp = filespec; *cp; cp++)
13867                     if (islower(*cp)) { haslower = 1; break; }
13868
13869                 if (haslower) __mystrtolower(outbuf);
13870             }
13871         }
13872     }
13873     return outbuf;
13874 }
13875
13876
13877 /*}}}*/
13878 /* External entry points */
13879 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13880 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13881
13882 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13883 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13884
13885 /* case_tolerant */
13886
13887 /*{{{int do_vms_case_tolerant(void)*/
13888 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13889  * controlled by a process setting.
13890  */
13891 int do_vms_case_tolerant(void)
13892 {
13893     return vms_process_case_tolerant;
13894 }
13895 /*}}}*/
13896 /* External entry points */
13897 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13898 int Perl_vms_case_tolerant(void)
13899 { return do_vms_case_tolerant(); }
13900 #else
13901 int Perl_vms_case_tolerant(void)
13902 { return vms_process_case_tolerant; }
13903 #endif
13904
13905
13906  /* Start of DECC RTL Feature handling */
13907
13908 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13909
13910 static int
13911 set_feature_default(const char *name, int value)
13912 {
13913     int status;
13914     int index;
13915     char val_str[10];
13916
13917     /* If the feature has been explicitly disabled in the environment,
13918      * then don't enable it here.
13919      */
13920     if (value > 0) {
13921         status = simple_trnlnm(name, val_str, sizeof(val_str));
13922         if ($VMS_STATUS_SUCCESS(status)) {
13923             val_str[0] = _toupper(val_str[0]);
13924             if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
13925                 return 0;
13926         }
13927     }
13928
13929     index = decc$feature_get_index(name);
13930
13931     status = decc$feature_set_value(index, 1, value);
13932     if (index == -1 || (status == -1)) {
13933       return -1;
13934     }
13935
13936     status = decc$feature_get_value(index, 1);
13937     if (status != value) {
13938       return -1;
13939     }
13940
13941     /* Various things may check for an environment setting
13942      * rather than the feature directly, so set that too.
13943      */
13944     vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13945
13946     return 0;
13947 }
13948 #endif
13949
13950
13951 /* C RTL Feature settings */
13952
13953 #if defined(__DECC) || defined(__DECCXX)
13954
13955 #ifdef __cplusplus
13956 extern "C" {
13957 #endif
13958
13959 extern void
13960 vmsperl_set_features(void)
13961 {
13962     int status;
13963     int s;
13964     char val_str[10];
13965 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13966     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13967     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13968     unsigned long case_perm;
13969     unsigned long case_image;
13970 #endif
13971
13972     /* Allow an exception to bring Perl into the VMS debugger */
13973     vms_debug_on_exception = 0;
13974     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13975     if ($VMS_STATUS_SUCCESS(status)) {
13976        val_str[0] = _toupper(val_str[0]);
13977        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13978          vms_debug_on_exception = 1;
13979        else
13980          vms_debug_on_exception = 0;
13981     }
13982
13983     /* Debug unix/vms file translation routines */
13984     vms_debug_fileify = 0;
13985     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13986     if ($VMS_STATUS_SUCCESS(status)) {
13987         val_str[0] = _toupper(val_str[0]);
13988         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13989             vms_debug_fileify = 1;
13990         else
13991             vms_debug_fileify = 0;
13992     }
13993
13994
13995     /* Historically PERL has been doing vmsify / stat differently than */
13996     /* the CRTL.  In particular, under some conditions the CRTL will   */
13997     /* remove some illegal characters like spaces from filenames       */
13998     /* resulting in some differences.  The stat()/lstat() wrapper has  */
13999     /* been reporting such file names as invalid and fails to stat them */
14000     /* fixing this bug so that stat()/lstat() accept these like the     */
14001     /* CRTL does will result in several tests failing.                  */
14002     /* This should really be fixed, but for now, set up a feature to    */
14003     /* enable it so that the impact can be studied.                     */
14004     vms_bug_stat_filename = 0;
14005     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14006     if ($VMS_STATUS_SUCCESS(status)) {
14007         val_str[0] = _toupper(val_str[0]);
14008         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14009             vms_bug_stat_filename = 1;
14010         else
14011             vms_bug_stat_filename = 0;
14012     }
14013
14014
14015     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14016     vms_vtf7_filenames = 0;
14017     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14018     if ($VMS_STATUS_SUCCESS(status)) {
14019        val_str[0] = _toupper(val_str[0]);
14020        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14021          vms_vtf7_filenames = 1;
14022        else
14023          vms_vtf7_filenames = 0;
14024     }
14025
14026     /* unlink all versions on unlink() or rename() */
14027     vms_unlink_all_versions = 0;
14028     status = simple_trnlnm
14029         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14030     if ($VMS_STATUS_SUCCESS(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_unlink_all_versions = 1;
14034        else
14035          vms_unlink_all_versions = 0;
14036     }
14037
14038 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14039     /* Detect running under GNV Bash or other UNIX like shell */
14040     gnv_unix_shell = 0;
14041     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14042     if ($VMS_STATUS_SUCCESS(status)) {
14043          gnv_unix_shell = 1;
14044          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14045          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14046          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14047          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14048          vms_unlink_all_versions = 1;
14049          vms_posix_exit = 1;
14050     }
14051     /* Some reasonable defaults that are not CRTL defaults */
14052     set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14053     set_feature_default("DECC$ARGV_PARSE_STYLE", 1);     /* Requires extended parse. */
14054     set_feature_default("DECC$EFS_CHARSET", 1);
14055 #endif
14056
14057     /* hacks to see if known bugs are still present for testing */
14058
14059     /* PCP mode requires creating /dev/null special device file */
14060     decc_bug_devnull = 0;
14061     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14062     if ($VMS_STATUS_SUCCESS(status)) {
14063        val_str[0] = _toupper(val_str[0]);
14064        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14065           decc_bug_devnull = 1;
14066        else
14067           decc_bug_devnull = 0;
14068     }
14069
14070 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14071     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14072     if (s >= 0) {
14073         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14074         if (decc_disable_to_vms_logname_translation < 0)
14075             decc_disable_to_vms_logname_translation = 0;
14076     }
14077
14078     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14079     if (s >= 0) {
14080         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14081         if (decc_efs_case_preserve < 0)
14082             decc_efs_case_preserve = 0;
14083     }
14084
14085     s = decc$feature_get_index("DECC$EFS_CHARSET");
14086     decc_efs_charset_index = s;
14087     if (s >= 0) {
14088         decc_efs_charset = decc$feature_get_value(s, 1);
14089         if (decc_efs_charset < 0)
14090             decc_efs_charset = 0;
14091     }
14092
14093     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14094     if (s >= 0) {
14095         decc_filename_unix_report = decc$feature_get_value(s, 1);
14096         if (decc_filename_unix_report > 0) {
14097             decc_filename_unix_report = 1;
14098             vms_posix_exit = 1;
14099         }
14100         else
14101             decc_filename_unix_report = 0;
14102     }
14103
14104     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14105     if (s >= 0) {
14106         decc_filename_unix_only = decc$feature_get_value(s, 1);
14107         if (decc_filename_unix_only > 0) {
14108             decc_filename_unix_only = 1;
14109         }
14110         else {
14111             decc_filename_unix_only = 0;
14112         }
14113     }
14114
14115     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14116     if (s >= 0) {
14117         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14118         if (decc_filename_unix_no_version < 0)
14119             decc_filename_unix_no_version = 0;
14120     }
14121
14122     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14123     if (s >= 0) {
14124         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14125         if (decc_readdir_dropdotnotype < 0)
14126             decc_readdir_dropdotnotype = 0;
14127     }
14128
14129 #if __CRTL_VER >= 80200000
14130     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14131     if (s >= 0) {
14132         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14133         if (decc_posix_compliant_pathnames < 0)
14134             decc_posix_compliant_pathnames = 0;
14135         if (decc_posix_compliant_pathnames > 4)
14136             decc_posix_compliant_pathnames = 0;
14137     }
14138
14139 #endif
14140 #else
14141     status = simple_trnlnm
14142         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14143     if ($VMS_STATUS_SUCCESS(status)) {
14144         val_str[0] = _toupper(val_str[0]);
14145         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14146            decc_disable_to_vms_logname_translation = 1;
14147         }
14148     }
14149
14150 #ifndef __VAX
14151     status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14152     if ($VMS_STATUS_SUCCESS(status)) {
14153         val_str[0] = _toupper(val_str[0]);
14154         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14155            decc_efs_case_preserve = 1;
14156         }
14157     }
14158 #endif
14159
14160     status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14161     if ($VMS_STATUS_SUCCESS(status)) {
14162         val_str[0] = _toupper(val_str[0]);
14163         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14164            decc_filename_unix_report = 1;
14165         }
14166     }
14167     status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14168     if ($VMS_STATUS_SUCCESS(status)) {
14169         val_str[0] = _toupper(val_str[0]);
14170         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14171            decc_filename_unix_only = 1;
14172            decc_filename_unix_report = 1;
14173         }
14174     }
14175     status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14176     if ($VMS_STATUS_SUCCESS(status)) {
14177         val_str[0] = _toupper(val_str[0]);
14178         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14179            decc_filename_unix_no_version = 1;
14180         }
14181     }
14182     status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14183     if ($VMS_STATUS_SUCCESS(status)) {
14184         val_str[0] = _toupper(val_str[0]);
14185         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14186            decc_readdir_dropdotnotype = 1;
14187         }
14188     }
14189 #endif
14190
14191 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14192
14193      /* Report true case tolerance */
14194     /*----------------------------*/
14195     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14196     if (!$VMS_STATUS_SUCCESS(status))
14197         case_perm = PPROP$K_CASE_BLIND;
14198     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14199     if (!$VMS_STATUS_SUCCESS(status))
14200         case_image = PPROP$K_CASE_BLIND;
14201     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14202         (case_image == PPROP$K_CASE_SENSITIVE))
14203         vms_process_case_tolerant = 0;
14204
14205 #endif
14206
14207     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14208     /* for strict backward compatibility */
14209     status = simple_trnlnm
14210         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14211     if ($VMS_STATUS_SUCCESS(status)) {
14212        val_str[0] = _toupper(val_str[0]);
14213        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14214          vms_posix_exit = 1;
14215        else
14216          vms_posix_exit = 0;
14217     }
14218 }
14219
14220 /* Use 32-bit pointers because that's what the image activator
14221  * assumes for the LIB$INITIALZE psect.
14222  */
14223 #if __INITIAL_POINTER_SIZE
14224 #pragma pointer_size save
14225 #pragma pointer_size 32
14226 #endif
14227
14228 /* Create a reference to the LIB$INITIALIZE function. */
14229 extern void LIB$INITIALIZE(void);
14230 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14231
14232 /* Create an array of pointers to the init functions in the special
14233  * LIB$INITIALIZE section. In our case, the array only has one entry.
14234  */
14235 #pragma extern_model save
14236 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
14237 extern void (* const vmsperl_unused_global_2[])() =
14238 {
14239    vmsperl_set_features,
14240 };
14241 #pragma extern_model restore
14242
14243 #if __INITIAL_POINTER_SIZE
14244 #pragma pointer_size restore
14245 #endif
14246
14247 #ifdef __cplusplus
14248 }
14249 #endif
14250
14251 #endif /* defined(__DECC) || defined(__DECCXX) */
14252 /*  End of vms.c */