vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
   6  *    2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
   7  *
   8  *    You may distribute under the terms of either the GNU General Public
   9  *    License or the Artistic License, as specified in the README file.
  10  *
  11  *    Please see Changes*.* or the Perl Repository Browser for revision history.
  12  */
  13
  14 /*
  15  *   Yet small as was their hunted band
  16  *   still fell and fearless was each hand,
  17  *   and strong deeds they wrought yet oft,
  18  *   and loved the woods, whose ways more soft
  19  *   them seemed than thralls of that black throne
  20  *   to live and languish in halls of stone.
  21  *        "The Lay of Leithian", Canto II, lines 135-40
  22  *
  23  *     [p.162 of _The Lays of Beleriand_]
  24  */
  25
  26 #include <acedef.h>
  27 #include <acldef.h>
  28 #include <armdef.h>
  29 #if __CRTL_VER < 70300000
  30 /* needed for home-rolled utime() */
  31 #include <atrdef.h>
  32 #include <fibdef.h>
  33 #endif
  34 #include <chpdef.h>
  35 #include <clidef.h>
  36 #include <climsgdef.h>
  37 #include <dcdef.h>
  38 #include <descrip.h>
  39 #include <devdef.h>
  40 #include <dvidef.h>
  41 #include <float.h>
  42 #include <fscndef.h>
  43 #include <iodef.h>
  44 #include <jpidef.h>
  45 #include <kgbdef.h>
  46 #include <libclidef.h>
  47 #include <libdef.h>
  48 #include <lib$routines.h>
  49 #include <lnmdef.h>
  50 #include <ossdef.h>
  51 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  52 #include <ppropdef.h>
  53 #endif
  54 #include <prvdef.h>
  55 #include <psldef.h>
  56 #include <rms.h>
  57 #include <shrdef.h>
  58 #include <ssdef.h>
  59 #include <starlet.h>
  60 #include <strdef.h>
  61 #include <str$routines.h>
  62 #include <syidef.h>
  63 #include <uaidef.h>
  64 #include <uicdef.h>
  65 #include <stsdef.h>
  66 #include <efndef.h>
  67 #define NO_EFN EFN$C_ENF
  68
  69 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  70 int   decc$feature_get_index(const char *name);
  71 char* decc$feature_get_name(int index);
  72 int   decc$feature_get_value(int index, int mode);
  73 int   decc$feature_set_value(int index, int mode, int value);
  74 #else
  75 #include <unixlib.h>
  76 #endif
  77
  78 #pragma member_alignment save
  79 #pragma nomember_alignment longword
  80 struct item_list_3 {
  81         unsigned short len;
  82         unsigned short code;
  83         void * bufadr;
  84         unsigned short * retadr;
  85 };
  86 #pragma member_alignment restore
  87
  88 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  89
  90 static int set_feature_default(const char *name, int value)
  91 {
  92     int status;
  93     int index;
  94
  95     index = decc$feature_get_index(name);
  96
  97     status = decc$feature_set_value(index, 1, value);
  98     if (index == -1 || (status == -1)) {
  99       return -1;
 100     }
 101
 102     status = decc$feature_get_value(index, 1);
 103     if (status != value) {
 104       return -1;
 105     }
 106
 107 return 0;
 108 }
 109 #endif
 110
 111 /* Older versions of ssdef.h don't have these */
 112 #ifndef SS$_INVFILFOROP
 113 #  define SS$_INVFILFOROP 3930
 114 #endif
 115 #ifndef SS$_NOSUCHOBJECT
 116 #  define SS$_NOSUCHOBJECT 2696
 117 #endif
 118
 119 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 120 #define PERLIO_NOT_STDIO 0
 121
 122 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 123  * code below needs to get to the underlying CRTL routines. */
 124 #define DONT_MASK_RTL_CALLS
 125 #include "EXTERN.h"
 126 #include "perl.h"
 127 #include "XSUB.h"
 128 /* Anticipating future expansion in lexical warnings . . . */
 129 #ifndef WARN_INTERNAL
 130 #  define WARN_INTERNAL WARN_MISC
 131 #endif
 132
 133 #ifdef VMS_LONGNAME_SUPPORT
 134 #include <libfildef.h>
 135 #endif
 136
 137 #if !defined(__VAX) && __CRTL_VER >= 80200000
 138 #ifdef lstat
 139 #undef lstat
 140 #endif
 141 #else
 142 #ifdef lstat
 143 #undef lstat
 144 #endif
 145 #define lstat(_x, _y) stat(_x, _y)
 146 #endif
 147
 148 /* Routine to create a decterm for use with the Perl debugger */
 149 /* No headers, this information was found in the Programming Concepts Manual */
 150
 151 static int (*decw_term_port)
 152    (const struct dsc$descriptor_s * display,
 153     const struct dsc$descriptor_s * setup_file,
 154     const struct dsc$descriptor_s * customization,
 155     struct dsc$descriptor_s * result_device_name,
 156     unsigned short * result_device_name_length,
 157     void * controller,
 158     void * char_buffer,
 159     void * char_change_buffer) = 0;
 160
 161 /* gcc's header files don't #define direct access macros
 162  * corresponding to VAXC's variant structs */
 163 #ifdef __GNUC__
 164 #  define uic$v_format uic$r_uic_form.uic$v_format
 165 #  define uic$v_group uic$r_uic_form.uic$v_group
 166 #  define uic$v_member uic$r_uic_form.uic$v_member
 167 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 168 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 169 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 170 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 171 #endif
 172
 173 #if defined(NEED_AN_H_ERRNO)
 174 dEXT int h_errno;
 175 #endif
 176
 177 #ifdef __DECC
 178 #pragma message disable pragma
 179 #pragma member_alignment save
 180 #pragma nomember_alignment longword
 181 #pragma message save
 182 #pragma message disable misalgndmem
 183 #endif
 184 struct itmlst_3 {
 185   unsigned short int buflen;
 186   unsigned short int itmcode;
 187   void *bufadr;
 188   unsigned short int *retlen;
 189 };
 190
 191 struct filescan_itmlst_2 {
 192     unsigned short length;
 193     unsigned short itmcode;
 194     char * component;
 195 };
 196
 197 struct vs_str_st {
 198     unsigned short length;
 199     char str[65536];
 200 };
 201
 202 #ifdef __DECC
 203 #pragma message restore
 204 #pragma member_alignment restore
 205 #endif
 206
 207 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 208 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 209 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 210 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 211 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 212 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 213 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 214 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 215 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 216 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 217 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 218 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 219
 220 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 221 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 222 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 223 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 224
 225 static char *  int_rmsexpand_vms(
 226     const char * filespec, char * outbuf, unsigned opts);
 227 static char * int_rmsexpand_tovms(
 228     const char * filespec, char * outbuf, unsigned opts);
 229 static char *int_tovmsspec
 230    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 231 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 232 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 233 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 234
 235 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 236 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 237
 238 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 239  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 240  * the Perl facility.
 241  */
 242 #define PERL_LNM_MAX_ITER 10
 243
 244   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 245 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 246 #define MAX_DCL_SYMBOL          (8192)
 247 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 248 #else
 249 #define MAX_DCL_SYMBOL          (1024)
 250 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 251 #endif
 252
 253 static char *__mystrtolower(char *str)
 254 {
 255   if (str) for (; *str; ++str) *str= tolower(*str);
 256   return str;
 257 }
 258
 259 static struct dsc$descriptor_s fildevdsc =
 260   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 261 static struct dsc$descriptor_s crtlenvdsc =
 262   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 263 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 264 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 265 static struct dsc$descriptor_s **env_tables = defenv;
 266 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 267
 268 /* True if we shouldn't treat barewords as logicals during directory */
 269 /* munching */
 270 static int no_translate_barewords;
 271
 272 /* DECC Features that may need to affect how Perl interprets
 273  * displays filename information
 274  */
 275 static int decc_disable_to_vms_logname_translation = 1;
 276 static int decc_disable_posix_root = 1;
 277 int decc_efs_case_preserve = 0;
 278 static int decc_efs_charset = 0;
 279 static int decc_efs_charset_index = -1;
 280 static int decc_filename_unix_no_version = 0;
 281 static int decc_filename_unix_only = 0;
 282 int decc_filename_unix_report = 0;
 283 int decc_posix_compliant_pathnames = 0;
 284 int decc_readdir_dropdotnotype = 0;
 285 static int vms_process_case_tolerant = 1;
 286 int vms_vtf7_filenames = 0;
 287 int gnv_unix_shell = 0;
 288 static int vms_unlink_all_versions = 0;
 289 static int vms_posix_exit = 0;
 290
 291 /* bug workarounds if needed */
 292 int decc_bug_devnull = 1;
 293 int decc_dir_barename = 0;
 294 int vms_bug_stat_filename = 0;
 295
 296 static int vms_debug_on_exception = 0;
 297 static int vms_debug_fileify = 0;
 298
 299 /* Simple logical name translation */
 300 static int simple_trnlnm
 301    (const char * logname,
 302     char * value,
 303     int value_len)
 304 {
 305     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 306     const unsigned long attr = LNM$M_CASE_BLIND;
 307     struct dsc$descriptor_s name_dsc;
 308     int status;
 309     unsigned short result;
 310     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 311                                 {0, 0, 0, 0}};
 312
 313     name_dsc.dsc$w_length = strlen(logname);
 314     name_dsc.dsc$a_pointer = (char *)logname;
 315     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 316     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 317
 318     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 319
 320     if ($VMS_STATUS_SUCCESS(status)) {
 321
 322          /* Null terminate and return the string */
 323         /*--------------------------------------*/
 324         value[result] = 0;
 325         return result;
 326     }
 327
 328     return 0;
 329 }
 330
 331
 332 /* Is this a UNIX file specification?
 333  *   No longer a simple check with EFS file specs
 334  *   For now, not a full check, but need to
 335  *   handle POSIX ^UP^ specifications
 336  *   Fixing to handle ^/ cases would require
 337  *   changes to many other conversion routines.
 338  */
 339
 340 static int is_unix_filespec(const char *path)
 341 {
 342 int ret_val;
 343 const char * pch1;
 344
 345     ret_val = 0;
 346     if (strncmp(path,"\"^UP^",5) != 0) {
 347         pch1 = strchr(path, '/');
 348         if (pch1 != NULL)
 349             ret_val = 1;
 350         else {
 351
 352             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 353             if (decc_filename_unix_report || decc_filename_unix_only) {
 354             if (strcmp(path,".") == 0)
 355                 ret_val = 1;
 356             }
 357         }
 358     }
 359     return ret_val;
 360 }
 361
 362 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 363  */
 364
 365 static void ucs2_to_vtf7
 366    (char *outspec,
 367     unsigned long ucs2_char,
 368     int * output_cnt)
 369 {
 370 unsigned char * ucs_ptr;
 371 int hex;
 372
 373     ucs_ptr = (unsigned char *)&ucs2_char;
 374
 375     outspec[0] = '^';
 376     outspec[1] = 'U';
 377     hex = (ucs_ptr[1] >> 4) & 0xf;
 378     if (hex < 0xA)
 379         outspec[2] = hex + '0';
 380     else
 381         outspec[2] = (hex - 9) + 'A';
 382     hex = ucs_ptr[1] & 0xF;
 383     if (hex < 0xA)
 384         outspec[3] = hex + '0';
 385     else {
 386         outspec[3] = (hex - 9) + 'A';
 387     }
 388     hex = (ucs_ptr[0] >> 4) & 0xf;
 389     if (hex < 0xA)
 390         outspec[4] = hex + '0';
 391     else
 392         outspec[4] = (hex - 9) + 'A';
 393     hex = ucs_ptr[1] & 0xF;
 394     if (hex < 0xA)
 395         outspec[5] = hex + '0';
 396     else {
 397         outspec[5] = (hex - 9) + 'A';
 398     }
 399     *output_cnt = 6;
 400 }
 401
 402
 403 /* This handles the conversion of a UNIX extended character set to a ^
 404  * escaped VMS character.
 405  * in a UNIX file specification.
 406  *
 407  * The output count variable contains the number of characters added
 408  * to the output string.
 409  *
 410  * The return value is the number of characters read from the input string
 411  */
 412 static int copy_expand_unix_filename_escape
 413   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 414 {
 415 int count;
 416 int utf8_flag;
 417
 418     utf8_flag = 0;
 419     if (utf8_fl)
 420       utf8_flag = *utf8_fl;
 421
 422     count = 0;
 423     *output_cnt = 0;
 424     if (*inspec >= 0x80) {
 425         if (utf8_fl && vms_vtf7_filenames) {
 426         unsigned long ucs_char;
 427
 428             ucs_char = 0;
 429
 430             if ((*inspec & 0xE0) == 0xC0) {
 431                 /* 2 byte Unicode */
 432                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 433                 if (ucs_char >= 0x80) {
 434                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 435                     return 2;
 436                 }
 437             } else if ((*inspec & 0xF0) == 0xE0) {
 438                 /* 3 byte Unicode */
 439                 ucs_char = ((inspec[0] & 0xF) << 12) +
 440                    ((inspec[1] & 0x3f) << 6) +
 441                    (inspec[2] & 0x3f);
 442                 if (ucs_char >= 0x800) {
 443                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 444                     return 3;
 445                 }
 446
 447 #if 0 /* I do not see longer sequences supported by OpenVMS */
 448       /* Maybe some one can fix this later */
 449             } else if ((*inspec & 0xF8) == 0xF0) {
 450                 /* 4 byte Unicode */
 451                 /* UCS-4 to UCS-2 */
 452             } else if ((*inspec & 0xFC) == 0xF8) {
 453                 /* 5 byte Unicode */
 454                 /* UCS-4 to UCS-2 */
 455             } else if ((*inspec & 0xFE) == 0xFC) {
 456                 /* 6 byte Unicode */
 457                 /* UCS-4 to UCS-2 */
 458 #endif
 459             }
 460         }
 461
 462         /* High bit set, but not a Unicode character! */
 463
 464         /* Non printing DECMCS or ISO Latin-1 character? */
 465         if ((unsigned char)*inspec <= 0x9F) {
 466             int hex;
 467             outspec[0] = '^';
 468             outspec++;
 469             hex = (*inspec >> 4) & 0xF;
 470             if (hex < 0xA)
 471                 outspec[1] = hex + '0';
 472             else {
 473                 outspec[1] = (hex - 9) + 'A';
 474             }
 475             hex = *inspec & 0xF;
 476             if (hex < 0xA)
 477                 outspec[2] = hex + '0';
 478             else {
 479                 outspec[2] = (hex - 9) + 'A';
 480             }
 481             *output_cnt = 3;
 482             return 1;
 483         } else if ((unsigned char)*inspec == 0xA0) {
 484             outspec[0] = '^';
 485             outspec[1] = 'A';
 486             outspec[2] = '0';
 487             *output_cnt = 3;
 488             return 1;
 489         } else if ((unsigned char)*inspec == 0xFF) {
 490             outspec[0] = '^';
 491             outspec[1] = 'F';
 492             outspec[2] = 'F';
 493             *output_cnt = 3;
 494             return 1;
 495         }
 496         *outspec = *inspec;
 497         *output_cnt = 1;
 498         return 1;
 499     }
 500
 501     /* Is this a macro that needs to be passed through?
 502      * Macros start with $( and an alpha character, followed
 503      * by a string of alpha numeric characters ending with a )
 504      * If this does not match, then encode it as ODS-5.
 505      */
 506     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 507     int tcnt;
 508
 509         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 510             tcnt = 3;
 511             outspec[0] = inspec[0];
 512             outspec[1] = inspec[1];
 513             outspec[2] = inspec[2];
 514
 515             while(isalnum(inspec[tcnt]) ||
 516                   (inspec[2] == '.') || (inspec[2] == '_')) {
 517                 outspec[tcnt] = inspec[tcnt];
 518                 tcnt++;
 519             }
 520             if (inspec[tcnt] == ')') {
 521                 outspec[tcnt] = inspec[tcnt];
 522                 tcnt++;
 523                 *output_cnt = tcnt;
 524                 return tcnt;
 525             }
 526         }
 527     }
 528
 529     switch (*inspec) {
 530     case 0x7f:
 531         outspec[0] = '^';
 532         outspec[1] = '7';
 533         outspec[2] = 'F';
 534         *output_cnt = 3;
 535         return 1;
 536         break;
 537     case '?':
 538         if (decc_efs_charset == 0)
 539           outspec[0] = '%';
 540         else
 541           outspec[0] = '?';
 542         *output_cnt = 1;
 543         return 1;
 544         break;
 545     case '.':
 546     case '~':
 547     case '!':
 548     case '#':
 549     case '&':
 550     case '\'':
 551     case '`':
 552     case '(':
 553     case ')':
 554     case '+':
 555     case '@':
 556     case '{':
 557     case '}':
 558     case ',':
 559     case ';':
 560     case '[':
 561     case ']':
 562     case '%':
 563     case '^':
 564     case '\\':
 565         /* Don't escape again if following character is
 566          * already something we escape.
 567          */
 568         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 569             *outspec = *inspec;
 570             *output_cnt = 1;
 571             return 1;
 572             break;
 573         }
 574         /* But otherwise fall through and escape it. */
 575     case '=':
 576         /* Assume that this is to be escaped */
 577         outspec[0] = '^';
 578         outspec[1] = *inspec;
 579         *output_cnt = 2;
 580         return 1;
 581         break;
 582     case ' ': /* space */
 583         /* Assume that this is to be escaped */
 584         outspec[0] = '^';
 585         outspec[1] = '_';
 586         *output_cnt = 2;
 587         return 1;
 588         break;
 589     default:
 590         *outspec = *inspec;
 591         *output_cnt = 1;
 592         return 1;
 593         break;
 594     }
 595 }
 596
 597
 598 /* This handles the expansion of a '^' prefix to the proper character
 599  * in a UNIX file specification.
 600  *
 601  * The output count variable contains the number of characters added
 602  * to the output string.
 603  *
 604  * The return value is the number of characters read from the input
 605  * string
 606  */
 607 static int copy_expand_vms_filename_escape
 608   (char *outspec, const char *inspec, int *output_cnt)
 609 {
 610 int count;
 611 int scnt;
 612
 613     count = 0;
 614     *output_cnt = 0;
 615     if (*inspec == '^') {
 616         inspec++;
 617         switch (*inspec) {
 618         /* Spaces and non-trailing dots should just be passed through,
 619          * but eat the escape character.
 620          */
 621         case '.':
 622             *outspec = *inspec;
 623             count += 2;
 624             (*output_cnt)++;
 625             break;
 626         case '_': /* space */
 627             *outspec = ' ';
 628             count += 2;
 629             (*output_cnt)++;
 630             break;
 631         case '^':
 632             /* Hmm.  Better leave the escape escaped. */
 633             outspec[0] = '^';
 634             outspec[1] = '^';
 635             count += 2;
 636             (*output_cnt) += 2;
 637             break;
 638         case 'U': /* Unicode - FIX-ME this is wrong. */
 639             inspec++;
 640             count++;
 641             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 642             if (scnt == 4) {
 643                 unsigned int c1, c2;
 644                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 645                 outspec[0] = c1 & 0xff;
 646                 outspec[1] = c2 & 0xff;
 647                 if (scnt > 1) {
 648                     (*output_cnt) += 2;
 649                     count += 4;
 650                 }
 651             }
 652             else {
 653                 /* Error - do best we can to continue */
 654                 *outspec = 'U';
 655                 outspec++;
 656                 (*output_cnt++);
 657                 *outspec = *inspec;
 658                 count++;
 659                 (*output_cnt++);
 660             }
 661             break;
 662         default:
 663             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 664             if (scnt == 2) {
 665                 /* Hex encoded */
 666                 unsigned int c1;
 667                 scnt = sscanf(inspec, "%2x", &c1);
 668                 outspec[0] = c1 & 0xff;
 669                 if (scnt > 0) {
 670                     (*output_cnt++);
 671                     count += 2;
 672                 }
 673             }
 674             else {
 675                 *outspec = *inspec;
 676                 count++;
 677                 (*output_cnt++);
 678             }
 679         }
 680     }
 681     else {
 682         *outspec = *inspec;
 683         count++;
 684         (*output_cnt)++;
 685     }
 686     return count;
 687 }
 688
 689 /* vms_split_path - Verify that the input file specification is a
 690  * VMS format file specification, and provide pointers to the components of
 691  * it.  With EFS format filenames, this is virtually the only way to
 692  * parse a VMS path specification into components.
 693  *
 694  * If the sum of the components do not add up to the length of the
 695  * string, then the passed file specification is probably a UNIX style
 696  * path.
 697  */
 698 static int vms_split_path
 699    (const char * path,
 700     char * * volume,
 701     int * vol_len,
 702     char * * root,
 703     int * root_len,
 704     char * * dir,
 705     int * dir_len,
 706     char * * name,
 707     int * name_len,
 708     char * * ext,
 709     int * ext_len,
 710     char * * version,
 711     int * ver_len)
 712 {
 713 struct dsc$descriptor path_desc;
 714 int status;
 715 unsigned long flags;
 716 int ret_stat;
 717 struct filescan_itmlst_2 item_list[9];
 718 const int filespec = 0;
 719 const int nodespec = 1;
 720 const int devspec = 2;
 721 const int rootspec = 3;
 722 const int dirspec = 4;
 723 const int namespec = 5;
 724 const int typespec = 6;
 725 const int verspec = 7;
 726
 727     /* Assume the worst for an easy exit */
 728     ret_stat = -1;
 729     *volume = NULL;
 730     *vol_len = 0;
 731     *root = NULL;
 732     *root_len = 0;
 733     *dir = NULL;
 734     *name = NULL;
 735     *name_len = 0;
 736     *ext = NULL;
 737     *ext_len = 0;
 738     *version = NULL;
 739     *ver_len = 0;
 740
 741     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 742     path_desc.dsc$w_length = strlen(path);
 743     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 744     path_desc.dsc$b_class = DSC$K_CLASS_S;
 745
 746     /* Get the total length, if it is shorter than the string passed
 747      * then this was probably not a VMS formatted file specification
 748      */
 749     item_list[filespec].itmcode = FSCN$_FILESPEC;
 750     item_list[filespec].length = 0;
 751     item_list[filespec].component = NULL;
 752
 753     /* If the node is present, then it gets considered as part of the
 754      * volume name to hopefully make things simple.
 755      */
 756     item_list[nodespec].itmcode = FSCN$_NODE;
 757     item_list[nodespec].length = 0;
 758     item_list[nodespec].component = NULL;
 759
 760     item_list[devspec].itmcode = FSCN$_DEVICE;
 761     item_list[devspec].length = 0;
 762     item_list[devspec].component = NULL;
 763
 764     /* root is a special case,  adding it to either the directory or
 765      * the device components will probably complicate things for the
 766      * callers of this routine, so leave it separate.
 767      */
 768     item_list[rootspec].itmcode = FSCN$_ROOT;
 769     item_list[rootspec].length = 0;
 770     item_list[rootspec].component = NULL;
 771
 772     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 773     item_list[dirspec].length = 0;
 774     item_list[dirspec].component = NULL;
 775
 776     item_list[namespec].itmcode = FSCN$_NAME;
 777     item_list[namespec].length = 0;
 778     item_list[namespec].component = NULL;
 779
 780     item_list[typespec].itmcode = FSCN$_TYPE;
 781     item_list[typespec].length = 0;
 782     item_list[typespec].component = NULL;
 783
 784     item_list[verspec].itmcode = FSCN$_VERSION;
 785     item_list[verspec].length = 0;
 786     item_list[verspec].component = NULL;
 787
 788     item_list[8].itmcode = 0;
 789     item_list[8].length = 0;
 790     item_list[8].component = NULL;
 791
 792     status = sys$filescan
 793        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 794         &flags, NULL, NULL);
 795     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 796
 797     /* If we parsed it successfully these two lengths should be the same */
 798     if (path_desc.dsc$w_length != item_list[filespec].length)
 799         return ret_stat;
 800
 801     /* If we got here, then it is a VMS file specification */
 802     ret_stat = 0;
 803
 804     /* set the volume name */
 805     if (item_list[nodespec].length > 0) {
 806         *volume = item_list[nodespec].component;
 807         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 808     }
 809     else {
 810         *volume = item_list[devspec].component;
 811         *vol_len = item_list[devspec].length;
 812     }
 813
 814     *root = item_list[rootspec].component;
 815     *root_len = item_list[rootspec].length;
 816
 817     *dir = item_list[dirspec].component;
 818     *dir_len = item_list[dirspec].length;
 819
 820     /* Now fun with versions and EFS file specifications
 821      * The parser can not tell the difference when a "." is a version
 822      * delimiter or a part of the file specification.
 823      */
 824     if ((decc_efs_charset) &&
 825         (item_list[verspec].length > 0) &&
 826         (item_list[verspec].component[0] == '.')) {
 827         *name = item_list[namespec].component;
 828         *name_len = item_list[namespec].length + item_list[typespec].length;
 829         *ext = item_list[verspec].component;
 830         *ext_len = item_list[verspec].length;
 831         *version = NULL;
 832         *ver_len = 0;
 833     }
 834     else {
 835         *name = item_list[namespec].component;
 836         *name_len = item_list[namespec].length;
 837         *ext = item_list[typespec].component;
 838         *ext_len = item_list[typespec].length;
 839         *version = item_list[verspec].component;
 840         *ver_len = item_list[verspec].length;
 841     }
 842     return ret_stat;
 843 }
 844
 845 /* Routine to determine if the file specification ends with .dir */
 846 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 847
 848     /* e_len must be 4, and version must be <= 2 characters */
 849     if (e_len != 4 || vs_len > 2)
 850         return 0;
 851
 852     /* If a version number is present, it needs to be one */
 853     if ((vs_len == 2) && (vs_spec[1] != '1'))
 854         return 0;
 855
 856     /* Look for the DIR on the extension */
 857     if (vms_process_case_tolerant) {
 858         if ((toupper(e_spec[1]) == 'D') &&
 859             (toupper(e_spec[2]) == 'I') &&
 860             (toupper(e_spec[3]) == 'R')) {
 861             return 1;
 862         }
 863     } else {
 864         /* Directory extensions are supposed to be in upper case only */
 865         /* I would not be surprised if this rule can not be enforced */
 866         /* if and when someone fully debugs the case sensitive mode */
 867         if ((e_spec[1] == 'D') &&
 868             (e_spec[2] == 'I') &&
 869             (e_spec[3] == 'R')) {
 870             return 1;
 871         }
 872     }
 873     return 0;
 874 }
 875
 876
 877 /* my_maxidx
 878  * Routine to retrieve the maximum equivalence index for an input
 879  * logical name.  Some calls to this routine have no knowledge if
 880  * the variable is a logical or not.  So on error we return a max
 881  * index of zero.
 882  */
 883 /*{{{int my_maxidx(const char *lnm) */
 884 static int
 885 my_maxidx(const char *lnm)
 886 {
 887     int status;
 888     int midx;
 889     int attr = LNM$M_CASE_BLIND;
 890     struct dsc$descriptor lnmdsc;
 891     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 892                                 {0, 0, 0, 0}};
 893
 894     lnmdsc.dsc$w_length = strlen(lnm);
 895     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 896     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 897     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 898
 899     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 900     if ((status & 1) == 0)
 901        midx = 0;
 902
 903     return (midx);
 904 }
 905 /*}}}*/
 906
 907 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 908 int
 909 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 910   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 911 {
 912     const char *cp1;
 913     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 914     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 915     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 916     int midx;
 917     unsigned char acmode;
 918     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 919                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 920     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 921                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 922                                  {0, 0, 0, 0}};
 923     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 924 #if defined(PERL_IMPLICIT_CONTEXT)
 925     pTHX = NULL;
 926     if (PL_curinterp) {
 927       aTHX = PERL_GET_INTERP;
 928     } else {
 929       aTHX = NULL;
 930     }
 931 #endif
 932
 933     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 934       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 935     }
 936     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 937       *cp2 = _toupper(*cp1);
 938       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 939         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 940         return 0;
 941       }
 942     }
 943     lnmdsc.dsc$w_length = cp1 - lnm;
 944     lnmdsc.dsc$a_pointer = uplnm;
 945     uplnm[lnmdsc.dsc$w_length] = '\0';
 946     secure = flags & PERL__TRNENV_SECURE;
 947     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 948     if (!tabvec || !*tabvec) tabvec = env_tables;
 949
 950     for (curtab = 0; tabvec[curtab]; curtab++) {
 951       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 952         if (!ivenv && !secure) {
 953           char *eq;
 954           int i;
 955           if (!environ) {
 956             ivenv = 1;
 957 #if defined(PERL_IMPLICIT_CONTEXT)
 958             if (aTHX == NULL) {
 959                 fprintf(stderr,
 960                     "Can't read CRTL environ\n");
 961             } else
 962 #endif
 963                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 964             continue;
 965           }
 966           retsts = SS$_NOLOGNAM;
 967           for (i = 0; environ[i]; i++) {
 968             if ((eq = strchr(environ[i],'=')) &&
 969                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 970                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 971               eq++;
 972               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 973               if (!eqvlen) continue;
 974               retsts = SS$_NORMAL;
 975               break;
 976             }
 977           }
 978           if (retsts != SS$_NOLOGNAM) break;
 979         }
 980       }
 981       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 982                !str$case_blind_compare(&tmpdsc,&clisym)) {
 983         if (!ivsym && !secure) {
 984           unsigned short int deflen = LNM$C_NAMLENGTH;
 985           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 986           /* dynamic dsc to accommodate possible long value */
 987           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 988           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 989           if (retsts & 1) {
 990             if (eqvlen > MAX_DCL_SYMBOL) {
 991               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 992               eqvlen = MAX_DCL_SYMBOL;
 993               /* Special hack--we might be called before the interpreter's */
 994               /* fully initialized, in which case either thr or PL_curcop */
 995               /* might be bogus. We have to check, since ckWARN needs them */
 996               /* both to be valid if running threaded */
 997 #if defined(PERL_IMPLICIT_CONTEXT)
 998               if (aTHX == NULL) {
 999                   fprintf(stderr,
1000                      "Value of CLI symbol \"%s\" too long",lnm);
1001               } else
1002 #endif
1003                 if (ckWARN(WARN_MISC)) {
1004                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1005                 }
1006             }
1007             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1008           }
1009           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1010           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1011           if (retsts == LIB$_NOSUCHSYM) continue;
1012           break;
1013         }
1014       }
1015       else if (!ivlnm) {
1016         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1017           midx = my_maxidx(lnm);
1018           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1019             lnmlst[1].bufadr = cp2;
1020             eqvlen = 0;
1021             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1022             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1023             if (retsts == SS$_NOLOGNAM) break;
1024             /* PPFs have a prefix */
1025             if (
1026 #if INTSIZE == 4
1027                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1028 #endif
1029                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1030                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1031                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1032                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1033                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1034               memmove(eqv,eqv+4,eqvlen-4);
1035               eqvlen -= 4;
1036             }
1037             cp2 += eqvlen;
1038             *cp2 = '\0';
1039           }
1040           if ((retsts == SS$_IVLOGNAM) ||
1041               (retsts == SS$_NOLOGNAM)) { continue; }
1042         }
1043         else {
1044           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1045           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1046           if (retsts == SS$_NOLOGNAM) continue;
1047           eqv[eqvlen] = '\0';
1048         }
1049         eqvlen = strlen(eqv);
1050         break;
1051       }
1052     }
1053     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1054     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1055              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1056              retsts == SS$_NOLOGNAM) {
1057       set_errno(EINVAL);  set_vaxc_errno(retsts);
1058     }
1059     else _ckvmssts_noperl(retsts);
1060     return 0;
1061 }  /* end of vmstrnenv */
1062 /*}}}*/
1063
1064 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1065 /* Define as a function so we can access statics. */
1066 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1067 {
1068     int flags = 0;
1069
1070 #if defined(PERL_IMPLICIT_CONTEXT)
1071     if (aTHX != NULL)
1072 #endif
1073 #ifdef SECURE_INTERNAL_GETENV
1074         flags = (PL_curinterp ? PL_tainting : will_taint) ?
1075                  PERL__TRNENV_SECURE : 0;
1076 #endif
1077
1078     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1079 }
1080 /*}}}*/
1081
1082 /* my_getenv
1083  * Note: Uses Perl temp to store result so char * can be returned to
1084  * caller; this pointer will be invalidated at next Perl statement
1085  * transition.
1086  * We define this as a function rather than a macro in terms of my_getenv_len()
1087  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1088  * allocate SVs).
1089  */
1090 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1091 char *
1092 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1093 {
1094     const char *cp1;
1095     static char *__my_getenv_eqv = NULL;
1096     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1097     unsigned long int idx = 0;
1098     int success, secure, saverr, savvmserr;
1099     int midx, flags;
1100     SV *tmpsv;
1101
1102     midx = my_maxidx(lnm) + 1;
1103
1104     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1105       /* Set up a temporary buffer for the return value; Perl will
1106        * clean it up at the next statement transition */
1107       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1108       if (!tmpsv) return NULL;
1109       eqv = SvPVX(tmpsv);
1110     }
1111     else {
1112       /* Assume no interpreter ==> single thread */
1113       if (__my_getenv_eqv != NULL) {
1114         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1115       }
1116       else {
1117         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1118       }
1119       eqv = __my_getenv_eqv;
1120     }
1121
1122     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1123     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1124       int len;
1125       getcwd(eqv,LNM$C_NAMLENGTH);
1126
1127       len = strlen(eqv);
1128
1129       /* Get rid of "000000/ in rooted filespecs */
1130       if (len > 7) {
1131         char * zeros;
1132         zeros = strstr(eqv, "/000000/");
1133         if (zeros != NULL) {
1134           int mlen;
1135           mlen = len - (zeros - eqv) - 7;
1136           memmove(zeros, &zeros[7], mlen);
1137           len = len - 7;
1138           eqv[len] = '\0';
1139         }
1140       }
1141       return eqv;
1142     }
1143     else {
1144       /* Impose security constraints only if tainting */
1145       if (sys) {
1146         /* Impose security constraints only if tainting */
1147         secure = PL_curinterp ? PL_tainting : will_taint;
1148         saverr = errno;  savvmserr = vaxc$errno;
1149       }
1150       else {
1151         secure = 0;
1152       }
1153
1154       flags =
1155 #ifdef SECURE_INTERNAL_GETENV
1156               secure ? PERL__TRNENV_SECURE : 0
1157 #else
1158               0
1159 #endif
1160       ;
1161
1162       /* For the getenv interface we combine all the equivalence names
1163        * of a search list logical into one value to acquire a maximum
1164        * value length of 255*128 (assuming %ENV is using logicals).
1165        */
1166       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1167
1168       /* If the name contains a semicolon-delimited index, parse it
1169        * off and make sure we only retrieve the equivalence name for
1170        * that index.  */
1171       if ((cp2 = strchr(lnm,';')) != NULL) {
1172         my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1173         idx = strtoul(cp2+1,NULL,0);
1174         lnm = uplnm;
1175         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1176       }
1177
1178       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1179
1180       /* Discard NOLOGNAM on internal calls since we're often looking
1181        * for an optional name, and this "error" often shows up as the
1182        * (bogus) exit status for a die() call later on.  */
1183       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1184       return success ? eqv : NULL;
1185     }
1186
1187 }  /* end of my_getenv() */
1188 /*}}}*/
1189
1190
1191 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1192 char *
1193 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1194 {
1195     const char *cp1;
1196     char *buf, *cp2;
1197     unsigned long idx = 0;
1198     int midx, flags;
1199     static char *__my_getenv_len_eqv = NULL;
1200     int secure, saverr, savvmserr;
1201     SV *tmpsv;
1202
1203     midx = my_maxidx(lnm) + 1;
1204
1205     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1206       /* Set up a temporary buffer for the return value; Perl will
1207        * clean it up at the next statement transition */
1208       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1209       if (!tmpsv) return NULL;
1210       buf = SvPVX(tmpsv);
1211     }
1212     else {
1213       /* Assume no interpreter ==> single thread */
1214       if (__my_getenv_len_eqv != NULL) {
1215         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1216       }
1217       else {
1218         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1219       }
1220       buf = __my_getenv_len_eqv;
1221     }
1222
1223     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1224     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1225     char * zeros;
1226
1227       getcwd(buf,LNM$C_NAMLENGTH);
1228       *len = strlen(buf);
1229
1230       /* Get rid of "000000/ in rooted filespecs */
1231       if (*len > 7) {
1232       zeros = strstr(buf, "/000000/");
1233       if (zeros != NULL) {
1234         int mlen;
1235         mlen = *len - (zeros - buf) - 7;
1236         memmove(zeros, &zeros[7], mlen);
1237         *len = *len - 7;
1238         buf[*len] = '\0';
1239         }
1240       }
1241       return buf;
1242     }
1243     else {
1244       if (sys) {
1245         /* Impose security constraints only if tainting */
1246         secure = PL_curinterp ? PL_tainting : will_taint;
1247         saverr = errno;  savvmserr = vaxc$errno;
1248       }
1249       else {
1250         secure = 0;
1251       }
1252
1253       flags =
1254 #ifdef SECURE_INTERNAL_GETENV
1255               secure ? PERL__TRNENV_SECURE : 0
1256 #else
1257               0
1258 #endif
1259       ;
1260
1261       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1262
1263       if ((cp2 = strchr(lnm,';')) != NULL) {
1264         my_strlcpy(buf, lnm, cp2 - lnm + 1);
1265         idx = strtoul(cp2+1,NULL,0);
1266         lnm = buf;
1267         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1268       }
1269
1270       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1271
1272       /* Get rid of "000000/ in rooted filespecs */
1273       if (*len > 7) {
1274       char * zeros;
1275         zeros = strstr(buf, "/000000/");
1276         if (zeros != NULL) {
1277           int mlen;
1278           mlen = *len - (zeros - buf) - 7;
1279           memmove(zeros, &zeros[7], mlen);
1280           *len = *len - 7;
1281           buf[*len] = '\0';
1282         }
1283       }
1284
1285       /* Discard NOLOGNAM on internal calls since we're often looking
1286        * for an optional name, and this "error" often shows up as the
1287        * (bogus) exit status for a die() call later on.  */
1288       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1289       return *len ? buf : NULL;
1290     }
1291
1292 }  /* end of my_getenv_len() */
1293 /*}}}*/
1294
1295 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1296
1297 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1298
1299 /*{{{ void prime_env_iter() */
1300 void
1301 prime_env_iter(void)
1302 /* Fill the %ENV associative array with all logical names we can
1303  * find, in preparation for iterating over it.
1304  */
1305 {
1306   static int primed = 0;
1307   HV *seenhv = NULL, *envhv;
1308   SV *sv = NULL;
1309   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1310   unsigned short int chan;
1311 #ifndef CLI$M_TRUSTED
1312 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1313 #endif
1314   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1315   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1316   long int i;
1317   bool have_sym = FALSE, have_lnm = FALSE;
1318   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1319   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1320   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1321   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1322   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1323 #if defined(PERL_IMPLICIT_CONTEXT)
1324   pTHX;
1325 #endif
1326 #if defined(USE_ITHREADS)
1327   static perl_mutex primenv_mutex;
1328   MUTEX_INIT(&primenv_mutex);
1329 #endif
1330
1331 #if defined(PERL_IMPLICIT_CONTEXT)
1332     /* We jump through these hoops because we can be called at */
1333     /* platform-specific initialization time, which is before anything is */
1334     /* set up--we can't even do a plain dTHX since that relies on the */
1335     /* interpreter structure to be initialized */
1336     if (PL_curinterp) {
1337       aTHX = PERL_GET_INTERP;
1338     } else {
1339       /* we never get here because the NULL pointer will cause the */
1340       /* several of the routines called by this routine to access violate */
1341
1342       /* This routine is only called by hv.c/hv_iterinit which has a */
1343       /* context, so the real fix may be to pass it through instead of */
1344       /* the hoops above */
1345       aTHX = NULL;
1346     }
1347 #endif
1348
1349   if (primed || !PL_envgv) return;
1350   MUTEX_LOCK(&primenv_mutex);
1351   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1352   envhv = GvHVn(PL_envgv);
1353   /* Perform a dummy fetch as an lval to insure that the hash table is
1354    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1355   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1356
1357   for (i = 0; env_tables[i]; i++) {
1358      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1359          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1360      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1361   }
1362   if (have_sym || have_lnm) {
1363     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1364     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1365     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1366     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1367   }
1368
1369   for (i--; i >= 0; i--) {
1370     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1371       char *start;
1372       int j;
1373       for (j = 0; environ[j]; j++) {
1374         if (!(start = strchr(environ[j],'='))) {
1375           if (ckWARN(WARN_INTERNAL))
1376             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1377         }
1378         else {
1379           start++;
1380           sv = newSVpv(start,0);
1381           SvTAINTED_on(sv);
1382           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1383         }
1384       }
1385       continue;
1386     }
1387     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1388              !str$case_blind_compare(&tmpdsc,&clisym)) {
1389       my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1390       cmddsc.dsc$w_length = 20;
1391       if (env_tables[i]->dsc$w_length == 12 &&
1392           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1393           !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local  *", sizeof(cmd)-12);
1394       flags = defflags | CLI$M_NOLOGNAM;
1395     }
1396     else {
1397       my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1398       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1399         my_strlcat(cmd," /Table=", sizeof(cmd));
1400         cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, env_tables[i]->dsc$w_length + 1);
1401       }
1402       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1403       flags = defflags | CLI$M_NOCLISYM;
1404     }
1405
1406     /* Create a new subprocess to execute each command, to exclude the
1407      * remote possibility that someone could subvert a mbx or file used
1408      * to write multiple commands to a single subprocess.
1409      */
1410     do {
1411       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1412                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1413       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1414       defflags &= ~CLI$M_TRUSTED;
1415     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1416     _ckvmssts(retsts);
1417     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1418     if (seenhv) SvREFCNT_dec(seenhv);
1419     seenhv = newHV();
1420     while (1) {
1421       char *cp1, *cp2, *key;
1422       unsigned long int sts, iosb[2], retlen, keylen;
1423       register U32 hash;
1424
1425       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1426       if (sts & 1) sts = iosb[0] & 0xffff;
1427       if (sts == SS$_ENDOFFILE) {
1428         int wakect = 0;
1429         while (substs == 0) { sys$hiber(); wakect++;}
1430         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1431         _ckvmssts(substs);
1432         break;
1433       }
1434       _ckvmssts(sts);
1435       retlen = iosb[0] >> 16;
1436       if (!retlen) continue;  /* blank line */
1437       buf[retlen] = '\0';
1438       if (iosb[1] != subpid) {
1439         if (iosb[1]) {
1440           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1441         }
1442         continue;
1443       }
1444       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1445         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1446
1447       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1448       if (*cp1 == '(' || /* Logical name table name */
1449           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1450       if (*cp1 == '"') cp1++;
1451       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1452       key = cp1;  keylen = cp2 - cp1;
1453       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1454       while (*cp2 && *cp2 != '=') cp2++;
1455       while (*cp2 && *cp2 == '=') cp2++;
1456       while (*cp2 && *cp2 == ' ') cp2++;
1457       if (*cp2 == '"') {  /* String translation; may embed "" */
1458         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1459         cp2++;  cp1--; /* Skip "" surrounding translation */
1460       }
1461       else {  /* Numeric translation */
1462         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1463         cp1--;  /* stop on last non-space char */
1464       }
1465       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1466         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1467         continue;
1468       }
1469       PERL_HASH(hash,key,keylen);
1470
1471       if (cp1 == cp2 && *cp2 == '.') {
1472         /* A single dot usually means an unprintable character, such as a null
1473          * to indicate a zero-length value.  Get the actual value to make sure.
1474          */
1475         char lnm[LNM$C_NAMLENGTH+1];
1476         char eqv[MAX_DCL_SYMBOL+1];
1477         int trnlen;
1478         strncpy(lnm, key, keylen);
1479         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1480         sv = newSVpvn(eqv, strlen(eqv));
1481       }
1482       else {
1483         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1484       }
1485
1486       SvTAINTED_on(sv);
1487       hv_store(envhv,key,keylen,sv,hash);
1488       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1489     }
1490     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1491       /* get the PPFs for this process, not the subprocess */
1492       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1493       char eqv[LNM$C_NAMLENGTH+1];
1494       int trnlen, i;
1495       for (i = 0; ppfs[i]; i++) {
1496         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1497         sv = newSVpv(eqv,trnlen);
1498         SvTAINTED_on(sv);
1499         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1500       }
1501     }
1502   }
1503   primed = 1;
1504   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1505   if (buf) Safefree(buf);
1506   if (seenhv) SvREFCNT_dec(seenhv);
1507   MUTEX_UNLOCK(&primenv_mutex);
1508   return;
1509
1510 }  /* end of prime_env_iter */
1511 /*}}}*/
1512
1513
1514 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1515 /* Define or delete an element in the same "environment" as
1516  * vmstrnenv().  If an element is to be deleted, it's removed from
1517  * the first place it's found.  If it's to be set, it's set in the
1518  * place designated by the first element of the table vector.
1519  * Like setenv() returns 0 for success, non-zero on error.
1520  */
1521 int
1522 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1523 {
1524     const char *cp1;
1525     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1526     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1527     int nseg = 0, j;
1528     unsigned long int retsts, usermode = PSL$C_USER;
1529     struct itmlst_3 *ile, *ilist;
1530     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1531                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1532                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1533     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1534     $DESCRIPTOR(local,"_LOCAL");
1535
1536     if (!lnm) {
1537         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1538         return SS$_IVLOGNAM;
1539     }
1540
1541     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1542       *cp2 = _toupper(*cp1);
1543       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1544         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1545         return SS$_IVLOGNAM;
1546       }
1547     }
1548     lnmdsc.dsc$w_length = cp1 - lnm;
1549     if (!tabvec || !*tabvec) tabvec = env_tables;
1550
1551     if (!eqv) {  /* we're deleting n element */
1552       for (curtab = 0; tabvec[curtab]; curtab++) {
1553         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1554         int i;
1555           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1556             if ((cp1 = strchr(environ[i],'=')) &&
1557                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1558                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1559 #ifdef HAS_SETENV
1560               return setenv(lnm,"",1) ? vaxc$errno : 0;
1561             }
1562           }
1563           ivenv = 1; retsts = SS$_NOLOGNAM;
1564 #else
1565               if (ckWARN(WARN_INTERNAL))
1566                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1567               ivenv = 1; retsts = SS$_NOSUCHPGM;
1568               break;
1569             }
1570           }
1571 #endif
1572         }
1573         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1574                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1575           unsigned int symtype;
1576           if (tabvec[curtab]->dsc$w_length == 12 &&
1577               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1578               !str$case_blind_compare(&tmpdsc,&local))
1579             symtype = LIB$K_CLI_LOCAL_SYM;
1580           else symtype = LIB$K_CLI_GLOBAL_SYM;
1581           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1582           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1583           if (retsts == LIB$_NOSUCHSYM) continue;
1584           break;
1585         }
1586         else if (!ivlnm) {
1587           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1588           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1589           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1590           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1591           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1592         }
1593       }
1594     }
1595     else {  /* we're defining a value */
1596       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1597 #ifdef HAS_SETENV
1598         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1599 #else
1600         if (ckWARN(WARN_INTERNAL))
1601           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1602         retsts = SS$_NOSUCHPGM;
1603 #endif
1604       }
1605       else {
1606         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1607         eqvdsc.dsc$w_length  = strlen(eqv);
1608         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1609             !str$case_blind_compare(&tmpdsc,&clisym)) {
1610           unsigned int symtype;
1611           if (tabvec[0]->dsc$w_length == 12 &&
1612               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1613                !str$case_blind_compare(&tmpdsc,&local))
1614             symtype = LIB$K_CLI_LOCAL_SYM;
1615           else symtype = LIB$K_CLI_GLOBAL_SYM;
1616           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1617         }
1618         else {
1619           if (!*eqv) eqvdsc.dsc$w_length = 1;
1620           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1621
1622             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1623             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1624               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1625                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1626               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1627               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1628             }
1629
1630             Newx(ilist,nseg+1,struct itmlst_3);
1631             ile = ilist;
1632             if (!ile) {
1633               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1634               return SS$_INSFMEM;
1635             }
1636             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1637
1638             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1639               ile->itmcode = LNM$_STRING;
1640               ile->bufadr = c;
1641               if ((j+1) == nseg) {
1642                 ile->buflen = strlen(c);
1643                 /* in case we are truncating one that's too long */
1644                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1645               }
1646               else {
1647                 ile->buflen = LNM$C_NAMLENGTH;
1648               }
1649             }
1650
1651             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1652             Safefree (ilist);
1653           }
1654           else {
1655             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1656           }
1657         }
1658       }
1659     }
1660     if (!(retsts & 1)) {
1661       switch (retsts) {
1662         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1663         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1664           set_errno(EVMSERR); break;
1665         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1666         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1667           set_errno(EINVAL); break;
1668         case SS$_NOPRIV:
1669           set_errno(EACCES); break;
1670         default:
1671           _ckvmssts(retsts);
1672           set_errno(EVMSERR);
1673        }
1674        set_vaxc_errno(retsts);
1675        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1676     }
1677     else {
1678       /* We reset error values on success because Perl does an hv_fetch()
1679        * before each hv_store(), and if the thing we're setting didn't
1680        * previously exist, we've got a leftover error message.  (Of course,
1681        * this fails in the face of
1682        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1683        * in that the error reported in $! isn't spurious,
1684        * but it's right more often than not.)
1685        */
1686       set_errno(0); set_vaxc_errno(retsts);
1687       return 0;
1688     }
1689
1690 }  /* end of vmssetenv() */
1691 /*}}}*/
1692
1693 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1694 /* This has to be a function since there's a prototype for it in proto.h */
1695 void
1696 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1697 {
1698     if (lnm && *lnm) {
1699       int len = strlen(lnm);
1700       if  (len == 7) {
1701         char uplnm[8];
1702         int i;
1703         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1704         if (!strcmp(uplnm,"DEFAULT")) {
1705           if (eqv && *eqv) my_chdir(eqv);
1706           return;
1707         }
1708     }
1709   }
1710   (void) vmssetenv(lnm,eqv,NULL);
1711 }
1712 /*}}}*/
1713
1714 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1715 /*  vmssetuserlnm
1716  *  sets a user-mode logical in the process logical name table
1717  *  used for redirection of sys$error
1718  *
1719  *  Fix-me: The pTHX is not needed for this routine, however doio.c
1720  *          is calling it with one instead of using a macro.
1721  *          A macro needs to be added to vmsish.h and doio.c updated to use it.
1722  *
1723  */
1724 void
1725 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1726 {
1727     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1728     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1729     unsigned long int iss, attr = LNM$M_CONFINE;
1730     unsigned char acmode = PSL$C_USER;
1731     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1732                                  {0, 0, 0, 0}};
1733     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1734     d_name.dsc$w_length = strlen(name);
1735
1736     lnmlst[0].buflen = strlen(eqv);
1737     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1738
1739     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1740     if (!(iss&1)) lib$signal(iss);
1741 }
1742 /*}}}*/
1743
1744
1745 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1746 /* my_crypt - VMS password hashing
1747  * my_crypt() provides an interface compatible with the Unix crypt()
1748  * C library function, and uses sys$hash_password() to perform VMS
1749  * password hashing.  The quadword hashed password value is returned
1750  * as a NUL-terminated 8 character string.  my_crypt() does not change
1751  * the case of its string arguments; in order to match the behavior
1752  * of LOGINOUT et al., alphabetic characters in both arguments must
1753  *  be upcased by the caller.
1754  *
1755  * - fix me to call ACM services when available
1756  */
1757 char *
1758 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1759 {
1760 #   ifndef UAI$C_PREFERRED_ALGORITHM
1761 #     define UAI$C_PREFERRED_ALGORITHM 127
1762 #   endif
1763     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1764     unsigned short int salt = 0;
1765     unsigned long int sts;
1766     struct const_dsc {
1767         unsigned short int dsc$w_length;
1768         unsigned char      dsc$b_type;
1769         unsigned char      dsc$b_class;
1770         const char *       dsc$a_pointer;
1771     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1772        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1773     struct itmlst_3 uailst[3] = {
1774         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1775         { sizeof salt, UAI$_SALT,    &salt, 0},
1776         { 0,           0,            NULL,  NULL}};
1777     static char hash[9];
1778
1779     usrdsc.dsc$w_length = strlen(usrname);
1780     usrdsc.dsc$a_pointer = usrname;
1781     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1782       switch (sts) {
1783         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1784           set_errno(EACCES);
1785           break;
1786         case RMS$_RNF:
1787           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1788           break;
1789         default:
1790           set_errno(EVMSERR);
1791       }
1792       set_vaxc_errno(sts);
1793       if (sts != RMS$_RNF) return NULL;
1794     }
1795
1796     txtdsc.dsc$w_length = strlen(textpasswd);
1797     txtdsc.dsc$a_pointer = textpasswd;
1798     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1799       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1800     }
1801
1802     return (char *) hash;
1803
1804 }  /* end of my_crypt() */
1805 /*}}}*/
1806
1807
1808 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1809 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1810 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1811
1812 /* fixup barenames that are directories for internal use.
1813  * There have been problems with the consistent handling of UNIX
1814  * style directory names when routines are presented with a name that
1815  * has no directory delimiters at all.  So this routine will eventually
1816  * fix the issue.
1817  */
1818 static char * fixup_bare_dirnames(const char * name)
1819 {
1820   if (decc_disable_to_vms_logname_translation) {
1821 /* fix me */
1822   }
1823   return NULL;
1824 }
1825
1826 /* 8.3, remove() is now broken on symbolic links */
1827 static int rms_erase(const char * vmsname);
1828
1829
1830 /* mp_do_kill_file
1831  * A little hack to get around a bug in some implementation of remove()
1832  * that do not know how to delete a directory
1833  *
1834  * Delete any file to which user has control access, regardless of whether
1835  * delete access is explicitly allowed.
1836  * Limitations: User must have write access to parent directory.
1837  *              Does not block signals or ASTs; if interrupted in midstream
1838  *              may leave file with an altered ACL.
1839  * HANDLE WITH CARE!
1840  */
1841 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1842 static int
1843 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1844 {
1845     char *vmsname;
1846     char *rslt;
1847     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1848     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1849     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1850     struct myacedef {
1851       unsigned char myace$b_length;
1852       unsigned char myace$b_type;
1853       unsigned short int myace$w_flags;
1854       unsigned long int myace$l_access;
1855       unsigned long int myace$l_ident;
1856     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1857                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1858       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1859      struct itmlst_3
1860        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1861                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1862        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1863        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1864        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1865        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1866
1867     /* Expand the input spec using RMS, since the CRTL remove() and
1868      * system services won't do this by themselves, so we may miss
1869      * a file "hiding" behind a logical name or search list. */
1870     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1871     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1872
1873     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1874     if (rslt == NULL) {
1875         PerlMem_free(vmsname);
1876         return -1;
1877       }
1878
1879     /* Erase the file */
1880     rmsts = rms_erase(vmsname);
1881
1882     /* Did it succeed */
1883     if ($VMS_STATUS_SUCCESS(rmsts)) {
1884         PerlMem_free(vmsname);
1885         return 0;
1886       }
1887
1888     /* If not, can changing protections help? */
1889     if (rmsts != RMS$_PRV) {
1890       set_vaxc_errno(rmsts);
1891       PerlMem_free(vmsname);
1892       return -1;
1893     }
1894
1895     /* No, so we get our own UIC to use as a rights identifier,
1896      * and the insert an ACE at the head of the ACL which allows us
1897      * to delete the file.
1898      */
1899     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1900     fildsc.dsc$w_length = strlen(vmsname);
1901     fildsc.dsc$a_pointer = vmsname;
1902     cxt = 0;
1903     newace.myace$l_ident = oldace.myace$l_ident;
1904     rmsts = -1;
1905     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1906       switch (aclsts) {
1907         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1908           set_errno(ENOENT); break;
1909         case RMS$_DIR:
1910           set_errno(ENOTDIR); break;
1911         case RMS$_DEV:
1912           set_errno(ENODEV); break;
1913         case RMS$_SYN: case SS$_INVFILFOROP:
1914           set_errno(EINVAL); break;
1915         case RMS$_PRV:
1916           set_errno(EACCES); break;
1917         default:
1918           _ckvmssts_noperl(aclsts);
1919       }
1920       set_vaxc_errno(aclsts);
1921       PerlMem_free(vmsname);
1922       return -1;
1923     }
1924     /* Grab any existing ACEs with this identifier in case we fail */
1925     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1926     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1927                     || fndsts == SS$_NOMOREACE ) {
1928       /* Add the new ACE . . . */
1929       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1930         goto yourroom;
1931
1932       rmsts = rms_erase(vmsname);
1933       if ($VMS_STATUS_SUCCESS(rmsts)) {
1934         rmsts = 0;
1935         }
1936         else {
1937         rmsts = -1;
1938         /* We blew it - dir with files in it, no write priv for
1939          * parent directory, etc.  Put things back the way they were. */
1940         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1941           goto yourroom;
1942         if (fndsts & 1) {
1943           addlst[0].bufadr = &oldace;
1944           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1945             goto yourroom;
1946         }
1947       }
1948     }
1949
1950     yourroom:
1951     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1952     /* We just deleted it, so of course it's not there.  Some versions of
1953      * VMS seem to return success on the unlock operation anyhow (after all
1954      * the unlock is successful), but others don't.
1955      */
1956     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1957     if (aclsts & 1) aclsts = fndsts;
1958     if (!(aclsts & 1)) {
1959       set_errno(EVMSERR);
1960       set_vaxc_errno(aclsts);
1961     }
1962
1963     PerlMem_free(vmsname);
1964     return rmsts;
1965
1966 }  /* end of kill_file() */
1967 /*}}}*/
1968
1969
1970 /*{{{int do_rmdir(char *name)*/
1971 int
1972 Perl_do_rmdir(pTHX_ const char *name)
1973 {
1974     char * dirfile;
1975     int retval;
1976     Stat_t st;
1977
1978     /* lstat returns a VMS fileified specification of the name */
1979     /* that is looked up, and also lets verifies that this is a directory */
1980
1981     retval = flex_lstat(name, &st);
1982     if (retval != 0) {
1983         char * ret_spec;
1984
1985         /* Due to a historical feature, flex_stat/lstat can not see some */
1986         /* Unix format file names that the rest of the CRTL can see */
1987         /* Fixing that feature will cause some perl tests to fail */
1988         /* So try this one more time. */
1989
1990         retval = lstat(name, &st.crtl_stat);
1991         if (retval != 0)
1992             return -1;
1993
1994         /* force it to a file spec for the kill file to work. */
1995         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1996         if (ret_spec == NULL) {
1997             errno = EIO;
1998             return -1;
1999         }
2000     }
2001
2002     if (!S_ISDIR(st.st_mode)) {
2003         errno = ENOTDIR;
2004         retval = -1;
2005     }
2006     else {
2007         dirfile = st.st_devnam;
2008
2009         /* It may be possible for flex_stat to find a file and vmsify() to */
2010         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
2011         /* with that case, so fail it */
2012         if (dirfile[0] == 0) {
2013             errno = EIO;
2014             return -1;
2015         }
2016
2017         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2018     }
2019
2020     return retval;
2021
2022 }  /* end of do_rmdir */
2023 /*}}}*/
2024
2025 /* kill_file
2026  * Delete any file to which user has control access, regardless of whether
2027  * delete access is explicitly allowed.
2028  * Limitations: User must have write access to parent directory.
2029  *              Does not block signals or ASTs; if interrupted in midstream
2030  *              may leave file with an altered ACL.
2031  * HANDLE WITH CARE!
2032  */
2033 /*{{{int kill_file(char *name)*/
2034 int
2035 Perl_kill_file(pTHX_ const char *name)
2036 {
2037     char * vmsfile;
2038     Stat_t st;
2039     int rmsts;
2040
2041     /* Convert the filename to VMS format and see if it is a directory */
2042     /* flex_lstat returns a vmsified file specification */
2043     rmsts = flex_lstat(name, &st);
2044     if (rmsts != 0) {
2045
2046         /* Due to a historical feature, flex_stat/lstat can not see some */
2047         /* Unix format file names that the rest of the CRTL can see when */
2048         /* ODS-2 file specifications are in use. */
2049         /* Fixing that feature will cause some perl tests to fail */
2050         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2051         st.st_mode = 0;
2052         vmsfile = (char *) name; /* cast ok */
2053
2054     } else {
2055         vmsfile = st.st_devnam;
2056         if (vmsfile[0] == 0) {
2057             /* It may be possible for flex_stat to find a file and vmsify() */
2058             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2059             /* deal with that case, so fail it */
2060             errno = EIO;
2061             return -1;
2062         }
2063     }
2064
2065     /* Remove() is allowed to delete directories, according to the X/Open
2066      * specifications.
2067      * This may need special handling to work with the ACL hacks.
2068      */
2069     if (S_ISDIR(st.st_mode)) {
2070         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2071         return rmsts;
2072     }
2073
2074     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2075
2076     /* Need to delete all versions ? */
2077     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2078         int i = 0;
2079
2080         /* Just use lstat() here as do not need st_dev */
2081         /* and we know that the file is in VMS format or that */
2082         /* because of a historical bug, flex_stat can not see the file */
2083         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2084             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2085             if (rmsts != 0)
2086                 break;
2087             i++;
2088
2089             /* Make sure that we do not loop forever */
2090             if (i > 32767) {
2091                 errno = EIO;
2092                 rmsts = -1;
2093                 break;
2094             }
2095         }
2096     }
2097
2098     return rmsts;
2099
2100 }  /* end of kill_file() */
2101 /*}}}*/
2102
2103
2104 /*{{{int my_mkdir(char *,Mode_t)*/
2105 int
2106 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2107 {
2108   STRLEN dirlen = strlen(dir);
2109
2110   /* zero length string sometimes gives ACCVIO */
2111   if (dirlen == 0) return -1;
2112
2113   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2114    * null file name/type.  However, it's commonplace under Unix,
2115    * so we'll allow it for a gain in portability.
2116    */
2117   if (dir[dirlen-1] == '/') {
2118     char *newdir = savepvn(dir,dirlen-1);
2119     int ret = mkdir(newdir,mode);
2120     Safefree(newdir);
2121     return ret;
2122   }
2123   else return mkdir(dir,mode);
2124 }  /* end of my_mkdir */
2125 /*}}}*/
2126
2127 /*{{{int my_chdir(char *)*/
2128 int
2129 Perl_my_chdir(pTHX_ const char *dir)
2130 {
2131   STRLEN dirlen = strlen(dir);
2132
2133   /* zero length string sometimes gives ACCVIO */
2134   if (dirlen == 0) return -1;
2135   const char *dir1;
2136
2137   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2138    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2139    * so that existing scripts do not need to be changed.
2140    */
2141   dir1 = dir;
2142   while ((dirlen > 0) && (*dir1 == ' ')) {
2143     dir1++;
2144     dirlen--;
2145   }
2146
2147   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2148    * that implies
2149    * null file name/type.  However, it's commonplace under Unix,
2150    * so we'll allow it for a gain in portability.
2151    *
2152    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2153    */
2154   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2155       char *newdir;
2156       int ret;
2157       newdir = PerlMem_malloc(dirlen);
2158       if (newdir ==NULL)
2159           _ckvmssts_noperl(SS$_INSFMEM);
2160       memcpy(newdir, dir1, dirlen-1);
2161       newdir[dirlen-1] = '\0';
2162       ret = chdir(newdir);
2163       PerlMem_free(newdir);
2164       return ret;
2165   }
2166   else return chdir(dir1);
2167 }  /* end of my_chdir */
2168 /*}}}*/
2169
2170
2171 /*{{{int my_chmod(char *, mode_t)*/
2172 int
2173 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2174 {
2175   Stat_t st;
2176   int ret = -1;
2177   char * changefile;
2178   STRLEN speclen = strlen(file_spec);
2179
2180   /* zero length string sometimes gives ACCVIO */
2181   if (speclen == 0) return -1;
2182
2183   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2184    * that implies null file name/type.  However, it's commonplace under Unix,
2185    * so we'll allow it for a gain in portability.
2186    *
2187    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2188    * in VMS file.dir notation.
2189    */
2190   changefile = (char *) file_spec; /* cast ok */
2191   ret = flex_lstat(file_spec, &st);
2192   if (ret != 0) {
2193
2194         /* Due to a historical feature, flex_stat/lstat can not see some */
2195         /* Unix format file names that the rest of the CRTL can see when */
2196         /* ODS-2 file specifications are in use. */
2197         /* Fixing that feature will cause some perl tests to fail */
2198         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2199         st.st_mode = 0;
2200
2201   } else {
2202       /* It may be possible to get here with nothing in st_devname */
2203       /* chmod still may work though */
2204       if (st.st_devnam[0] != 0) {
2205           changefile = st.st_devnam;
2206       }
2207   }
2208   ret = chmod(changefile, mode);
2209   return ret;
2210 }  /* end of my_chmod */
2211 /*}}}*/
2212
2213
2214 /*{{{FILE *my_tmpfile()*/
2215 FILE *
2216 my_tmpfile(void)
2217 {
2218   FILE *fp;
2219   char *cp;
2220
2221   if ((fp = tmpfile())) return fp;
2222
2223   cp = PerlMem_malloc(L_tmpnam+24);
2224   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2225
2226   if (decc_filename_unix_only == 0)
2227     strcpy(cp,"Sys$Scratch:");
2228   else
2229     strcpy(cp,"/tmp/");
2230   tmpnam(cp+strlen(cp));
2231   strcat(cp,".Perltmp");
2232   fp = fopen(cp,"w+","fop=dlt");
2233   PerlMem_free(cp);
2234   return fp;
2235 }
2236 /*}}}*/
2237
2238
2239 /*
2240  * The C RTL's sigaction fails to check for invalid signal numbers so we
2241  * help it out a bit.  The docs are correct, but the actual routine doesn't
2242  * do what the docs say it will.
2243  */
2244 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2245 int
2246 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2247                    struct sigaction* oact)
2248 {
2249   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2250         SETERRNO(EINVAL, SS$_INVARG);
2251         return -1;
2252   }
2253   return sigaction(sig, act, oact);
2254 }
2255 /*}}}*/
2256
2257 #ifdef KILL_BY_SIGPRC
2258 #include <errnodef.h>
2259
2260 /* We implement our own kill() using the undocumented system service
2261    sys$sigprc for one of two reasons:
2262
2263    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2264    target process to do a sys$exit, which usually can't be handled
2265    gracefully...certainly not by Perl and the %SIG{} mechanism.
2266
2267    2.) If the kill() in the CRTL can't be called from a signal
2268    handler without disappearing into the ether, i.e., the signal
2269    it purportedly sends is never trapped. Still true as of VMS 7.3.
2270
2271    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2272    in the target process rather than calling sys$exit.
2273
2274    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2275    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2276    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2277    with condition codes C$_SIG0+nsig*8, catching the exception on the
2278    target process and resignaling with appropriate arguments.
2279
2280    But we don't have that VMS 7.0+ exception handler, so if you
2281    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2282
2283    Also note that SIGTERM is listed in the docs as being "unimplemented",
2284    yet always seems to be signaled with a VMS condition code of 4 (and
2285    correctly handled for that code).  So we hardwire it in.
2286
2287    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2288    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2289    than signalling with an unrecognized (and unhandled by CRTL) code.
2290 */
2291
2292 #define _MY_SIG_MAX 28
2293
2294 static unsigned int
2295 Perl_sig_to_vmscondition_int(int sig)
2296 {
2297     static unsigned int sig_code[_MY_SIG_MAX+1] =
2298     {
2299         0,                  /*  0 ZERO     */
2300         SS$_HANGUP,         /*  1 SIGHUP   */
2301         SS$_CONTROLC,       /*  2 SIGINT   */
2302         SS$_CONTROLY,       /*  3 SIGQUIT  */
2303         SS$_RADRMOD,        /*  4 SIGILL   */
2304         SS$_BREAK,          /*  5 SIGTRAP  */
2305         SS$_OPCCUS,         /*  6 SIGABRT  */
2306         SS$_COMPAT,         /*  7 SIGEMT   */
2307 #ifdef __VAX
2308         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2309 #else
2310         SS$_HPARITH,        /*  8 SIGFPE AXP */
2311 #endif
2312         SS$_ABORT,          /*  9 SIGKILL  */
2313         SS$_ACCVIO,         /* 10 SIGBUS   */
2314         SS$_ACCVIO,         /* 11 SIGSEGV  */
2315         SS$_BADPARAM,       /* 12 SIGSYS   */
2316         SS$_NOMBX,          /* 13 SIGPIPE  */
2317         SS$_ASTFLT,         /* 14 SIGALRM  */
2318         4,                  /* 15 SIGTERM  */
2319         0,                  /* 16 SIGUSR1  */
2320         0,                  /* 17 SIGUSR2  */
2321         0,                  /* 18 */
2322         0,                  /* 19 */
2323         0,                  /* 20 SIGCHLD  */
2324         0,                  /* 21 SIGCONT  */
2325         0,                  /* 22 SIGSTOP  */
2326         0,                  /* 23 SIGTSTP  */
2327         0,                  /* 24 SIGTTIN  */
2328         0,                  /* 25 SIGTTOU  */
2329         0,                  /* 26 */
2330         0,                  /* 27 */
2331         0                   /* 28 SIGWINCH  */
2332     };
2333
2334     static int initted = 0;
2335     if (!initted) {
2336         initted = 1;
2337         sig_code[16] = C$_SIGUSR1;
2338         sig_code[17] = C$_SIGUSR2;
2339         sig_code[20] = C$_SIGCHLD;
2340 #if __CRTL_VER >= 70300000
2341         sig_code[28] = C$_SIGWINCH;
2342 #endif
2343     }
2344
2345     if (sig < _SIG_MIN) return 0;
2346     if (sig > _MY_SIG_MAX) return 0;
2347     return sig_code[sig];
2348 }
2349
2350 unsigned int
2351 Perl_sig_to_vmscondition(int sig)
2352 {
2353 #ifdef SS$_DEBUG
2354     if (vms_debug_on_exception != 0)
2355         lib$signal(SS$_DEBUG);
2356 #endif
2357     return Perl_sig_to_vmscondition_int(sig);
2358 }
2359
2360
2361 int
2362 Perl_my_kill(int pid, int sig)
2363 {
2364     int iss;
2365     unsigned int code;
2366 #define sys$sigprc SYS$SIGPRC
2367     int sys$sigprc(unsigned int *pidadr,
2368                      struct dsc$descriptor_s *prcname,
2369                      unsigned int code);
2370
2371      /* sig 0 means validate the PID */
2372     /*------------------------------*/
2373     if (sig == 0) {
2374         const unsigned long int jpicode = JPI$_PID;
2375         pid_t ret_pid;
2376         int status;
2377         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2378         if ($VMS_STATUS_SUCCESS(status))
2379            return 0;
2380         switch (status) {
2381         case SS$_NOSUCHNODE:
2382         case SS$_UNREACHABLE:
2383         case SS$_NONEXPR:
2384            errno = ESRCH;
2385            break;
2386         case SS$_NOPRIV:
2387            errno = EPERM;
2388            break;
2389         default:
2390            errno = EVMSERR;
2391         }
2392         vaxc$errno=status;
2393         return -1;
2394     }
2395
2396     code = Perl_sig_to_vmscondition_int(sig);
2397
2398     if (!code) {
2399         SETERRNO(EINVAL, SS$_BADPARAM);
2400         return -1;
2401     }
2402
2403     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2404      * signals are to be sent to multiple processes.
2405      *  pid = 0 - all processes in group except ones that the system exempts
2406      *  pid = -1 - all processes except ones that the system exempts
2407      *  pid = -n - all processes in group (abs(n)) except ...
2408      * For now, just report as not supported.
2409      */
2410
2411     if (pid <= 0) {
2412         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2413         return -1;
2414     }
2415
2416     iss = sys$sigprc((unsigned int *)&pid,0,code);
2417     if (iss&1) return 0;
2418
2419     switch (iss) {
2420       case SS$_NOPRIV:
2421         set_errno(EPERM);  break;
2422       case SS$_NONEXPR:
2423       case SS$_NOSUCHNODE:
2424       case SS$_UNREACHABLE:
2425         set_errno(ESRCH);  break;
2426       case SS$_INSFMEM:
2427         set_errno(ENOMEM); break;
2428       default:
2429         _ckvmssts_noperl(iss);
2430         set_errno(EVMSERR);
2431     }
2432     set_vaxc_errno(iss);
2433
2434     return -1;
2435 }
2436 #endif
2437
2438 /* Routine to convert a VMS status code to a UNIX status code.
2439 ** More tricky than it appears because of conflicting conventions with
2440 ** existing code.
2441 **
2442 ** VMS status codes are a bit mask, with the least significant bit set for
2443 ** success.
2444 **
2445 ** Special UNIX status of EVMSERR indicates that no translation is currently
2446 ** available, and programs should check the VMS status code.
2447 **
2448 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2449 ** decoding.
2450 */
2451
2452 #ifndef C_FACILITY_NO
2453 #define C_FACILITY_NO 0x350000
2454 #endif
2455 #ifndef DCL_IVVERB
2456 #define DCL_IVVERB 0x38090
2457 #endif
2458
2459 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2460 {
2461 int facility;
2462 int fac_sp;
2463 int msg_no;
2464 int msg_status;
2465 int unix_status;
2466
2467   /* Assume the best or the worst */
2468   if (vms_status & STS$M_SUCCESS)
2469     unix_status = 0;
2470   else
2471     unix_status = EVMSERR;
2472
2473   msg_status = vms_status & ~STS$M_CONTROL;
2474
2475   facility = vms_status & STS$M_FAC_NO;
2476   fac_sp = vms_status & STS$M_FAC_SP;
2477   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2478
2479   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2480     switch(msg_no) {
2481     case SS$_NORMAL:
2482         unix_status = 0;
2483         break;
2484     case SS$_ACCVIO:
2485         unix_status = EFAULT;
2486         break;
2487     case SS$_DEVOFFLINE:
2488         unix_status = EBUSY;
2489         break;
2490     case SS$_CLEARED:
2491         unix_status = ENOTCONN;
2492         break;
2493     case SS$_IVCHAN:
2494     case SS$_IVLOGNAM:
2495     case SS$_BADPARAM:
2496     case SS$_IVLOGTAB:
2497     case SS$_NOLOGNAM:
2498     case SS$_NOLOGTAB:
2499     case SS$_INVFILFOROP:
2500     case SS$_INVARG:
2501     case SS$_NOSUCHID:
2502     case SS$_IVIDENT:
2503         unix_status = EINVAL;
2504         break;
2505     case SS$_UNSUPPORTED:
2506         unix_status = ENOTSUP;
2507         break;
2508     case SS$_FILACCERR:
2509     case SS$_NOGRPPRV:
2510     case SS$_NOSYSPRV:
2511         unix_status = EACCES;
2512         break;
2513     case SS$_DEVICEFULL:
2514         unix_status = ENOSPC;
2515         break;
2516     case SS$_NOSUCHDEV:
2517         unix_status = ENODEV;
2518         break;
2519     case SS$_NOSUCHFILE:
2520     case SS$_NOSUCHOBJECT:
2521         unix_status = ENOENT;
2522         break;
2523     case SS$_ABORT:                                 /* Fatal case */
2524     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2525     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2526         unix_status = EINTR;
2527         break;
2528     case SS$_BUFFEROVF:
2529         unix_status = E2BIG;
2530         break;
2531     case SS$_INSFMEM:
2532         unix_status = ENOMEM;
2533         break;
2534     case SS$_NOPRIV:
2535         unix_status = EPERM;
2536         break;
2537     case SS$_NOSUCHNODE:
2538     case SS$_UNREACHABLE:
2539         unix_status = ESRCH;
2540         break;
2541     case SS$_NONEXPR:
2542         unix_status = ECHILD;
2543         break;
2544     default:
2545         if ((facility == 0) && (msg_no < 8)) {
2546           /* These are not real VMS status codes so assume that they are
2547           ** already UNIX status codes
2548           */
2549           unix_status = msg_no;
2550           break;
2551         }
2552     }
2553   }
2554   else {
2555     /* Translate a POSIX exit code to a UNIX exit code */
2556     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2557         unix_status = (msg_no & 0x07F8) >> 3;
2558     }
2559     else {
2560
2561          /* Documented traditional behavior for handling VMS child exits */
2562         /*--------------------------------------------------------------*/
2563         if (child_flag != 0) {
2564
2565              /* Success / Informational return 0 */
2566             /*----------------------------------*/
2567             if (msg_no & STS$K_SUCCESS)
2568                 return 0;
2569
2570              /* Warning returns 1 */
2571             /*-------------------*/
2572             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2573                 return 1;
2574
2575              /* Everything else pass through the severity bits */
2576             /*------------------------------------------------*/
2577             return (msg_no & STS$M_SEVERITY);
2578         }
2579
2580          /* Normal VMS status to ERRNO mapping attempt */
2581         /*--------------------------------------------*/
2582         switch(msg_status) {
2583         /* case RMS$_EOF: */ /* End of File */
2584         case RMS$_FNF:  /* File Not Found */
2585         case RMS$_DNF:  /* Dir Not Found */
2586                 unix_status = ENOENT;
2587                 break;
2588         case RMS$_RNF:  /* Record Not Found */
2589                 unix_status = ESRCH;
2590                 break;
2591         case RMS$_DIR:
2592                 unix_status = ENOTDIR;
2593                 break;
2594         case RMS$_DEV:
2595                 unix_status = ENODEV;
2596                 break;
2597         case RMS$_IFI:
2598         case RMS$_FAC:
2599         case RMS$_ISI:
2600                 unix_status = EBADF;
2601                 break;
2602         case RMS$_FEX:
2603                 unix_status = EEXIST;
2604                 break;
2605         case RMS$_SYN:
2606         case RMS$_FNM:
2607         case LIB$_INVSTRDES:
2608         case LIB$_INVARG:
2609         case LIB$_NOSUCHSYM:
2610         case LIB$_INVSYMNAM:
2611         case DCL_IVVERB:
2612                 unix_status = EINVAL;
2613                 break;
2614         case CLI$_BUFOVF:
2615         case RMS$_RTB:
2616         case CLI$_TKNOVF:
2617         case CLI$_RSLOVF:
2618                 unix_status = E2BIG;
2619                 break;
2620         case RMS$_PRV:  /* No privilege */
2621         case RMS$_ACC:  /* ACP file access failed */
2622         case RMS$_WLK:  /* Device write locked */
2623                 unix_status = EACCES;
2624                 break;
2625         case RMS$_MKD:  /* Failed to mark for delete */
2626                 unix_status = EPERM;
2627                 break;
2628         /* case RMS$_NMF: */  /* No more files */
2629         }
2630     }
2631   }
2632
2633   return unix_status;
2634 }
2635
2636 /* Try to guess at what VMS error status should go with a UNIX errno
2637  * value.  This is hard to do as there could be many possible VMS
2638  * error statuses that caused the errno value to be set.
2639  */
2640
2641 int Perl_unix_status_to_vms(int unix_status)
2642 {
2643 int test_unix_status;
2644
2645      /* Trivial cases first */
2646     /*---------------------*/
2647     if (unix_status == EVMSERR)
2648         return vaxc$errno;
2649
2650      /* Is vaxc$errno sane? */
2651     /*---------------------*/
2652     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2653     if (test_unix_status == unix_status)
2654         return vaxc$errno;
2655
2656      /* If way out of range, must be VMS code already */
2657     /*-----------------------------------------------*/
2658     if (unix_status > EVMSERR)
2659         return unix_status;
2660
2661      /* If out of range, punt */
2662     /*-----------------------*/
2663     if (unix_status > __ERRNO_MAX)
2664         return SS$_ABORT;
2665
2666
2667      /* Ok, now we have to do it the hard way. */
2668     /*----------------------------------------*/
2669     switch(unix_status) {
2670     case 0:     return SS$_NORMAL;
2671     case EPERM: return SS$_NOPRIV;
2672     case ENOENT: return SS$_NOSUCHOBJECT;
2673     case ESRCH: return SS$_UNREACHABLE;
2674     case EINTR: return SS$_ABORT;
2675     /* case EIO: */
2676     /* case ENXIO:  */
2677     case E2BIG: return SS$_BUFFEROVF;
2678     /* case ENOEXEC */
2679     case EBADF: return RMS$_IFI;
2680     case ECHILD: return SS$_NONEXPR;
2681     /* case EAGAIN */
2682     case ENOMEM: return SS$_INSFMEM;
2683     case EACCES: return SS$_FILACCERR;
2684     case EFAULT: return SS$_ACCVIO;
2685     /* case ENOTBLK */
2686     case EBUSY: return SS$_DEVOFFLINE;
2687     case EEXIST: return RMS$_FEX;
2688     /* case EXDEV */
2689     case ENODEV: return SS$_NOSUCHDEV;
2690     case ENOTDIR: return RMS$_DIR;
2691     /* case EISDIR */
2692     case EINVAL: return SS$_INVARG;
2693     /* case ENFILE */
2694     /* case EMFILE */
2695     /* case ENOTTY */
2696     /* case ETXTBSY */
2697     /* case EFBIG */
2698     case ENOSPC: return SS$_DEVICEFULL;
2699     case ESPIPE: return LIB$_INVARG;
2700     /* case EROFS: */
2701     /* case EMLINK: */
2702     /* case EPIPE: */
2703     /* case EDOM */
2704     case ERANGE: return LIB$_INVARG;
2705     /* case EWOULDBLOCK */
2706     /* case EINPROGRESS */
2707     /* case EALREADY */
2708     /* case ENOTSOCK */
2709     /* case EDESTADDRREQ */
2710     /* case EMSGSIZE */
2711     /* case EPROTOTYPE */
2712     /* case ENOPROTOOPT */
2713     /* case EPROTONOSUPPORT */
2714     /* case ESOCKTNOSUPPORT */
2715     /* case EOPNOTSUPP */
2716     /* case EPFNOSUPPORT */
2717     /* case EAFNOSUPPORT */
2718     /* case EADDRINUSE */
2719     /* case EADDRNOTAVAIL */
2720     /* case ENETDOWN */
2721     /* case ENETUNREACH */
2722     /* case ENETRESET */
2723     /* case ECONNABORTED */
2724     /* case ECONNRESET */
2725     /* case ENOBUFS */
2726     /* case EISCONN */
2727     case ENOTCONN: return SS$_CLEARED;
2728     /* case ESHUTDOWN */
2729     /* case ETOOMANYREFS */
2730     /* case ETIMEDOUT */
2731     /* case ECONNREFUSED */
2732     /* case ELOOP */
2733     /* case ENAMETOOLONG */
2734     /* case EHOSTDOWN */
2735     /* case EHOSTUNREACH */
2736     /* case ENOTEMPTY */
2737     /* case EPROCLIM */
2738     /* case EUSERS  */
2739     /* case EDQUOT  */
2740     /* case ENOMSG  */
2741     /* case EIDRM */
2742     /* case EALIGN */
2743     /* case ESTALE */
2744     /* case EREMOTE */
2745     /* case ENOLCK */
2746     /* case ENOSYS */
2747     /* case EFTYPE */
2748     /* case ECANCELED */
2749     /* case EFAIL */
2750     /* case EINPROG */
2751     case ENOTSUP:
2752         return SS$_UNSUPPORTED;
2753     /* case EDEADLK */
2754     /* case ENWAIT */
2755     /* case EILSEQ */
2756     /* case EBADCAT */
2757     /* case EBADMSG */
2758     /* case EABANDONED */
2759     default:
2760         return SS$_ABORT; /* punt */
2761     }
2762 }
2763
2764
2765 /* default piping mailbox size */
2766 #ifdef __VAX
2767 #  define PERL_BUFSIZ        512
2768 #else
2769 #  define PERL_BUFSIZ        8192
2770 #endif
2771
2772
2773 static void
2774 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2775 {
2776   unsigned long int mbxbufsiz;
2777   static unsigned long int syssize = 0;
2778   unsigned long int dviitm = DVI$_DEVNAM;
2779   char csize[LNM$C_NAMLENGTH+1];
2780   int sts;
2781
2782   if (!syssize) {
2783     unsigned long syiitm = SYI$_MAXBUF;
2784     /*
2785      * Get the SYSGEN parameter MAXBUF
2786      *
2787      * If the logical 'PERL_MBX_SIZE' is defined
2788      * use the value of the logical instead of PERL_BUFSIZ, but
2789      * keep the size between 128 and MAXBUF.
2790      *
2791      */
2792     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2793   }
2794
2795   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2796       mbxbufsiz = atoi(csize);
2797   } else {
2798       mbxbufsiz = PERL_BUFSIZ;
2799   }
2800   if (mbxbufsiz < 128) mbxbufsiz = 128;
2801   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2802
2803   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2804
2805   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2806   _ckvmssts_noperl(sts);
2807   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2808
2809 }  /* end of create_mbx() */
2810
2811
2812 /*{{{  my_popen and my_pclose*/
2813
2814 typedef struct _iosb           IOSB;
2815 typedef struct _iosb*         pIOSB;
2816 typedef struct _pipe           Pipe;
2817 typedef struct _pipe*         pPipe;
2818 typedef struct pipe_details    Info;
2819 typedef struct pipe_details*  pInfo;
2820 typedef struct _srqp            RQE;
2821 typedef struct _srqp*          pRQE;
2822 typedef struct _tochildbuf      CBuf;
2823 typedef struct _tochildbuf*    pCBuf;
2824
2825 struct _iosb {
2826     unsigned short status;
2827     unsigned short count;
2828     unsigned long  dvispec;
2829 };
2830
2831 #pragma member_alignment save
2832 #pragma nomember_alignment quadword
2833 struct _srqp {          /* VMS self-relative queue entry */
2834     unsigned long qptr[2];
2835 };
2836 #pragma member_alignment restore
2837 static RQE  RQE_ZERO = {0,0};
2838
2839 struct _tochildbuf {
2840     RQE             q;
2841     int             eof;
2842     unsigned short  size;
2843     char            *buf;
2844 };
2845
2846 struct _pipe {
2847     RQE            free;
2848     RQE            wait;
2849     int            fd_out;
2850     unsigned short chan_in;
2851     unsigned short chan_out;
2852     char          *buf;
2853     unsigned int   bufsize;
2854     IOSB           iosb;
2855     IOSB           iosb2;
2856     int           *pipe_done;
2857     int            retry;
2858     int            type;
2859     int            shut_on_empty;
2860     int            need_wake;
2861     pPipe         *home;
2862     pInfo          info;
2863     pCBuf          curr;
2864     pCBuf          curr2;
2865 #if defined(PERL_IMPLICIT_CONTEXT)
2866     void            *thx;           /* Either a thread or an interpreter */
2867                                     /* pointer, depending on how we're built */
2868 #endif
2869 };
2870
2871
2872 struct pipe_details
2873 {
2874     pInfo           next;
2875     PerlIO *fp;  /* file pointer to pipe mailbox */
2876     int useFILE; /* using stdio, not perlio */
2877     int pid;   /* PID of subprocess */
2878     int mode;  /* == 'r' if pipe open for reading */
2879     int done;  /* subprocess has completed */
2880     int waiting; /* waiting for completion/closure */
2881     int             closing;        /* my_pclose is closing this pipe */
2882     unsigned long   completion;     /* termination status of subprocess */
2883     pPipe           in;             /* pipe in to sub */
2884     pPipe           out;            /* pipe out of sub */
2885     pPipe           err;            /* pipe of sub's sys$error */
2886     int             in_done;        /* true when in pipe finished */
2887     int             out_done;
2888     int             err_done;
2889     unsigned short  xchan;          /* channel to debug xterm */
2890     unsigned short  xchan_valid;    /* channel is assigned */
2891 };
2892
2893 struct exit_control_block
2894 {
2895     struct exit_control_block *flink;
2896     unsigned long int (*exit_routine)(void);
2897     unsigned long int arg_count;
2898     unsigned long int *status_address;
2899     unsigned long int exit_status;
2900 };
2901
2902 typedef struct _closed_pipes    Xpipe;
2903 typedef struct _closed_pipes*  pXpipe;
2904
2905 struct _closed_pipes {
2906     int             pid;            /* PID of subprocess */
2907     unsigned long   completion;     /* termination status of subprocess */
2908 };
2909 #define NKEEPCLOSED 50
2910 static Xpipe closed_list[NKEEPCLOSED];
2911 static int   closed_index = 0;
2912 static int   closed_num = 0;
2913
2914 #define RETRY_DELAY     "0 ::0.20"
2915 #define MAX_RETRY              50
2916
2917 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2918 static unsigned long mypid;
2919 static unsigned long delaytime[2];
2920
2921 static pInfo open_pipes = NULL;
2922 static $DESCRIPTOR(nl_desc, "NL:");
2923
2924 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2925
2926
2927
2928 static unsigned long int
2929 pipe_exit_routine(void)
2930 {
2931     pInfo info;
2932     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2933     int sts, did_stuff, j;
2934
2935    /*
2936     * Flush any pending i/o, but since we are in process run-down, be
2937     * careful about referencing PerlIO structures that may already have
2938     * been deallocated.  We may not even have an interpreter anymore.
2939     */
2940     info = open_pipes;
2941     while (info) {
2942         if (info->fp) {
2943 #if defined(PERL_IMPLICIT_CONTEXT)
2944            /* We need to use the Perl context of the thread that created */
2945            /* the pipe. */
2946            pTHX;
2947            if (info->err)
2948                aTHX = info->err->thx;
2949            else if (info->out)
2950                aTHX = info->out->thx;
2951            else if (info->in)
2952                aTHX = info->in->thx;
2953 #endif
2954            if (!info->useFILE
2955 #if defined(USE_ITHREADS)
2956              && my_perl
2957 #endif
2958 #ifdef USE_PERLIO
2959              && PL_perlio_fd_refcnt
2960 #endif
2961               )
2962                PerlIO_flush(info->fp);
2963            else
2964                fflush((FILE *)info->fp);
2965         }
2966         info = info->next;
2967     }
2968
2969     /*
2970      next we try sending an EOF...ignore if doesn't work, make sure we
2971      don't hang
2972     */
2973     did_stuff = 0;
2974     info = open_pipes;
2975
2976     while (info) {
2977       _ckvmssts_noperl(sys$setast(0));
2978       if (info->in && !info->in->shut_on_empty) {
2979         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2980                                  0, 0, 0, 0, 0, 0));
2981         info->waiting = 1;
2982         did_stuff = 1;
2983       }
2984       _ckvmssts_noperl(sys$setast(1));
2985       info = info->next;
2986     }
2987
2988     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2989
2990     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2991         int nwait = 0;
2992
2993         info = open_pipes;
2994         while (info) {
2995           _ckvmssts_noperl(sys$setast(0));
2996           if (info->waiting && info->done)
2997                 info->waiting = 0;
2998           nwait += info->waiting;
2999           _ckvmssts_noperl(sys$setast(1));
3000           info = info->next;
3001         }
3002         if (!nwait) break;
3003         sleep(1);
3004     }
3005
3006     did_stuff = 0;
3007     info = open_pipes;
3008     while (info) {
3009       _ckvmssts_noperl(sys$setast(0));
3010       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3011         sts = sys$forcex(&info->pid,0,&abort);
3012         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3013         did_stuff = 1;
3014       }
3015       _ckvmssts_noperl(sys$setast(1));
3016       info = info->next;
3017     }
3018
3019     /* again, wait for effect */
3020
3021     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3022         int nwait = 0;
3023
3024         info = open_pipes;
3025         while (info) {
3026           _ckvmssts_noperl(sys$setast(0));
3027           if (info->waiting && info->done)
3028                 info->waiting = 0;
3029           nwait += info->waiting;
3030           _ckvmssts_noperl(sys$setast(1));
3031           info = info->next;
3032         }
3033         if (!nwait) break;
3034         sleep(1);
3035     }
3036
3037     info = open_pipes;
3038     while (info) {
3039       _ckvmssts_noperl(sys$setast(0));
3040       if (!info->done) {  /* We tried to be nice . . . */
3041         sts = sys$delprc(&info->pid,0);
3042         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3043         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3044       }
3045       _ckvmssts_noperl(sys$setast(1));
3046       info = info->next;
3047     }
3048
3049     while(open_pipes) {
3050
3051 #if defined(PERL_IMPLICIT_CONTEXT)
3052       /* We need to use the Perl context of the thread that created */
3053       /* the pipe. */
3054       pTHX;
3055       if (open_pipes->err)
3056           aTHX = open_pipes->err->thx;
3057       else if (open_pipes->out)
3058           aTHX = open_pipes->out->thx;
3059       else if (open_pipes->in)
3060           aTHX = open_pipes->in->thx;
3061 #endif
3062       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3063       else if (!(sts & 1)) retsts = sts;
3064     }
3065     return retsts;
3066 }
3067
3068 static struct exit_control_block pipe_exitblock =
3069        {(struct exit_control_block *) 0,
3070         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3071
3072 static void pipe_mbxtofd_ast(pPipe p);
3073 static void pipe_tochild1_ast(pPipe p);
3074 static void pipe_tochild2_ast(pPipe p);
3075
3076 static void
3077 popen_completion_ast(pInfo info)
3078 {
3079   pInfo i = open_pipes;
3080   int iss;
3081
3082   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3083   closed_list[closed_index].pid = info->pid;
3084   closed_list[closed_index].completion = info->completion;
3085   closed_index++;
3086   if (closed_index == NKEEPCLOSED)
3087     closed_index = 0;
3088   closed_num++;
3089
3090   while (i) {
3091     if (i == info) break;
3092     i = i->next;
3093   }
3094   if (!i) return;       /* unlinked, probably freed too */
3095
3096   info->done = TRUE;
3097
3098 /*
3099     Writing to subprocess ...
3100             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3101
3102             chan_out may be waiting for "done" flag, or hung waiting
3103             for i/o completion to child...cancel the i/o.  This will
3104             put it into "snarf mode" (done but no EOF yet) that discards
3105             input.
3106
3107     Output from subprocess (stdout, stderr) needs to be flushed and
3108     shut down.   We try sending an EOF, but if the mbx is full the pipe
3109     routine should still catch the "shut_on_empty" flag, telling it to
3110     use immediate-style reads so that "mbx empty" -> EOF.
3111
3112
3113 */
3114   if (info->in && !info->in_done) {               /* only for mode=w */
3115         if (info->in->shut_on_empty && info->in->need_wake) {
3116             info->in->need_wake = FALSE;
3117             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3118         } else {
3119             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3120         }
3121   }
3122
3123   if (info->out && !info->out_done) {             /* were we also piping output? */
3124       info->out->shut_on_empty = TRUE;
3125       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3126       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3127       _ckvmssts_noperl(iss);
3128   }
3129
3130   if (info->err && !info->err_done) {        /* we were piping stderr */
3131         info->err->shut_on_empty = TRUE;
3132         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3133         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3134         _ckvmssts_noperl(iss);
3135   }
3136   _ckvmssts_noperl(sys$setef(pipe_ef));
3137
3138 }
3139
3140 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3141 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3142 static void pipe_infromchild_ast(pPipe p);
3143
3144 /*
3145     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3146     inside an AST routine without worrying about reentrancy and which Perl
3147     memory allocator is being used.
3148
3149     We read data and queue up the buffers, then spit them out one at a
3150     time to the output mailbox when the output mailbox is ready for one.
3151
3152 */
3153 #define INITIAL_TOCHILDQUEUE  2
3154
3155 static pPipe
3156 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3157 {
3158     pPipe p;
3159     pCBuf b;
3160     char mbx1[64], mbx2[64];
3161     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3162                                       DSC$K_CLASS_S, mbx1},
3163                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3164                                       DSC$K_CLASS_S, mbx2};
3165     unsigned int dviitm = DVI$_DEVBUFSIZ;
3166     int j, n;
3167
3168     n = sizeof(Pipe);
3169     _ckvmssts_noperl(lib$get_vm(&n, &p));
3170
3171     create_mbx(&p->chan_in , &d_mbx1);
3172     create_mbx(&p->chan_out, &d_mbx2);
3173     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3174
3175     p->buf           = 0;
3176     p->shut_on_empty = FALSE;
3177     p->need_wake     = FALSE;
3178     p->type          = 0;
3179     p->retry         = 0;
3180     p->iosb.status   = SS$_NORMAL;
3181     p->iosb2.status  = SS$_NORMAL;
3182     p->free          = RQE_ZERO;
3183     p->wait          = RQE_ZERO;
3184     p->curr          = 0;
3185     p->curr2         = 0;
3186     p->info          = 0;
3187 #ifdef PERL_IMPLICIT_CONTEXT
3188     p->thx           = aTHX;
3189 #endif
3190
3191     n = sizeof(CBuf) + p->bufsize;
3192
3193     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3194         _ckvmssts_noperl(lib$get_vm(&n, &b));
3195         b->buf = (char *) b + sizeof(CBuf);
3196         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3197     }
3198
3199     pipe_tochild2_ast(p);
3200     pipe_tochild1_ast(p);
3201     strcpy(wmbx, mbx1);
3202     strcpy(rmbx, mbx2);
3203     return p;
3204 }
3205
3206 /*  reads the MBX Perl is writing, and queues */
3207
3208 static void
3209 pipe_tochild1_ast(pPipe p)
3210 {
3211     pCBuf b = p->curr;
3212     int iss = p->iosb.status;
3213     int eof = (iss == SS$_ENDOFFILE);
3214     int sts;
3215 #ifdef PERL_IMPLICIT_CONTEXT
3216     pTHX = p->thx;
3217 #endif
3218
3219     if (p->retry) {
3220         if (eof) {
3221             p->shut_on_empty = TRUE;
3222             b->eof     = TRUE;
3223             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3224         } else  {
3225             _ckvmssts_noperl(iss);
3226         }
3227
3228         b->eof  = eof;
3229         b->size = p->iosb.count;
3230         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3231         if (p->need_wake) {
3232             p->need_wake = FALSE;
3233             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3234         }
3235     } else {
3236         p->retry = 1;   /* initial call */
3237     }
3238
3239     if (eof) {                  /* flush the free queue, return when done */
3240         int n = sizeof(CBuf) + p->bufsize;
3241         while (1) {
3242             iss = lib$remqti(&p->free, &b);
3243             if (iss == LIB$_QUEWASEMP) return;
3244             _ckvmssts_noperl(iss);
3245             _ckvmssts_noperl(lib$free_vm(&n, &b));
3246         }
3247     }
3248
3249     iss = lib$remqti(&p->free, &b);
3250     if (iss == LIB$_QUEWASEMP) {
3251         int n = sizeof(CBuf) + p->bufsize;
3252         _ckvmssts_noperl(lib$get_vm(&n, &b));
3253         b->buf = (char *) b + sizeof(CBuf);
3254     } else {
3255        _ckvmssts_noperl(iss);
3256     }
3257
3258     p->curr = b;
3259     iss = sys$qio(0,p->chan_in,
3260              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3261              &p->iosb,
3262              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3263     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3264     _ckvmssts_noperl(iss);
3265 }
3266
3267
3268 /* writes queued buffers to output, waits for each to complete before
3269    doing the next */
3270
3271 static void
3272 pipe_tochild2_ast(pPipe p)
3273 {
3274     pCBuf b = p->curr2;
3275     int iss = p->iosb2.status;
3276     int n = sizeof(CBuf) + p->bufsize;
3277     int done = (p->info && p->info->done) ||
3278               iss == SS$_CANCEL || iss == SS$_ABORT;
3279 #if defined(PERL_IMPLICIT_CONTEXT)
3280     pTHX = p->thx;
3281 #endif
3282
3283     do {
3284         if (p->type) {         /* type=1 has old buffer, dispose */
3285             if (p->shut_on_empty) {
3286                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3287             } else {
3288                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3289             }
3290             p->type = 0;
3291         }
3292
3293         iss = lib$remqti(&p->wait, &b);
3294         if (iss == LIB$_QUEWASEMP) {
3295             if (p->shut_on_empty) {
3296                 if (done) {
3297                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3298                     *p->pipe_done = TRUE;
3299                     _ckvmssts_noperl(sys$setef(pipe_ef));
3300                 } else {
3301                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3302                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3303                 }
3304                 return;
3305             }
3306             p->need_wake = TRUE;
3307             return;
3308         }
3309         _ckvmssts_noperl(iss);
3310         p->type = 1;
3311     } while (done);
3312
3313
3314     p->curr2 = b;
3315     if (b->eof) {
3316         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3317             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3318     } else {
3319         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3320             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3321     }
3322
3323     return;
3324
3325 }
3326
3327
3328 static pPipe
3329 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3330 {
3331     pPipe p;
3332     char mbx1[64], mbx2[64];
3333     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3334                                       DSC$K_CLASS_S, mbx1},
3335                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3336                                       DSC$K_CLASS_S, mbx2};
3337     unsigned int dviitm = DVI$_DEVBUFSIZ;
3338
3339     int n = sizeof(Pipe);
3340     _ckvmssts_noperl(lib$get_vm(&n, &p));
3341     create_mbx(&p->chan_in , &d_mbx1);
3342     create_mbx(&p->chan_out, &d_mbx2);
3343
3344     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3345     n = p->bufsize * sizeof(char);
3346     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3347     p->shut_on_empty = FALSE;
3348     p->info   = 0;
3349     p->type   = 0;
3350     p->iosb.status = SS$_NORMAL;
3351 #if defined(PERL_IMPLICIT_CONTEXT)
3352     p->thx = aTHX;
3353 #endif
3354     pipe_infromchild_ast(p);
3355
3356     strcpy(wmbx, mbx1);
3357     strcpy(rmbx, mbx2);
3358     return p;
3359 }
3360
3361 static void
3362 pipe_infromchild_ast(pPipe p)
3363 {
3364     int iss = p->iosb.status;
3365     int eof = (iss == SS$_ENDOFFILE);
3366     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3367     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3368 #if defined(PERL_IMPLICIT_CONTEXT)
3369     pTHX = p->thx;
3370 #endif
3371
3372     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3373         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3374         p->chan_out = 0;
3375     }
3376
3377     /* read completed:
3378             input shutdown if EOF from self (done or shut_on_empty)
3379             output shutdown if closing flag set (my_pclose)
3380             send data/eof from child or eof from self
3381             otherwise, re-read (snarf of data from child)
3382     */
3383
3384     if (p->type == 1) {
3385         p->type = 0;
3386         if (myeof && p->chan_in) {                  /* input shutdown */
3387             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3388             p->chan_in = 0;
3389         }
3390
3391         if (p->chan_out) {
3392             if (myeof || kideof) {      /* pass EOF to parent */
3393                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3394                                          pipe_infromchild_ast, p,
3395                                          0, 0, 0, 0, 0, 0));
3396                 return;
3397             } else if (eof) {       /* eat EOF --- fall through to read*/
3398
3399             } else {                /* transmit data */
3400                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3401                                          pipe_infromchild_ast,p,
3402                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3403                 return;
3404             }
3405         }
3406     }
3407
3408     /*  everything shut? flag as done */
3409
3410     if (!p->chan_in && !p->chan_out) {
3411         *p->pipe_done = TRUE;
3412         _ckvmssts_noperl(sys$setef(pipe_ef));
3413         return;
3414     }
3415
3416     /* write completed (or read, if snarfing from child)
3417             if still have input active,
3418                queue read...immediate mode if shut_on_empty so we get EOF if empty
3419             otherwise,
3420                check if Perl reading, generate EOFs as needed
3421     */
3422
3423     if (p->type == 0) {
3424         p->type = 1;
3425         if (p->chan_in) {
3426             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3427                           pipe_infromchild_ast,p,
3428                           p->buf, p->bufsize, 0, 0, 0, 0);
3429             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3430             _ckvmssts_noperl(iss);
3431         } else {           /* send EOFs for extra reads */
3432             p->iosb.status = SS$_ENDOFFILE;
3433             p->iosb.dvispec = 0;
3434             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3435                                      0, 0, 0,
3436                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3437         }
3438     }
3439 }
3440
3441 static pPipe
3442 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3443 {
3444     pPipe p;
3445     char mbx[64];
3446     unsigned long dviitm = DVI$_DEVBUFSIZ;
3447     struct stat s;
3448     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3449                                       DSC$K_CLASS_S, mbx};
3450     int n = sizeof(Pipe);
3451
3452     /* things like terminals and mbx's don't need this filter */
3453     if (fd && fstat(fd,&s) == 0) {
3454         unsigned long devchar;
3455         char device[65];
3456         unsigned short dev_len;
3457         struct dsc$descriptor_s d_dev;
3458         char * cptr;
3459         struct item_list_3 items[3];
3460         int status;
3461         unsigned short dvi_iosb[4];
3462
3463         cptr = getname(fd, out, 1);
3464         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3465         d_dev.dsc$a_pointer = out;
3466         d_dev.dsc$w_length = strlen(out);
3467         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3468         d_dev.dsc$b_class = DSC$K_CLASS_S;
3469
3470         items[0].len = 4;
3471         items[0].code = DVI$_DEVCHAR;
3472         items[0].bufadr = &devchar;
3473         items[0].retadr = NULL;
3474         items[1].len = 64;
3475         items[1].code = DVI$_FULLDEVNAM;
3476         items[1].bufadr = device;
3477         items[1].retadr = &dev_len;
3478         items[2].len = 0;
3479         items[2].code = 0;
3480
3481         status = sys$getdviw
3482                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3483         _ckvmssts_noperl(status);
3484         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3485             device[dev_len] = 0;
3486
3487             if (!(devchar & DEV$M_DIR)) {
3488                 strcpy(out, device);
3489                 return 0;
3490             }
3491         }
3492     }
3493
3494     _ckvmssts_noperl(lib$get_vm(&n, &p));
3495     p->fd_out = dup(fd);
3496     create_mbx(&p->chan_in, &d_mbx);
3497     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3498     n = (p->bufsize+1) * sizeof(char);
3499     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3500     p->shut_on_empty = FALSE;
3501     p->retry = 0;
3502     p->info  = 0;
3503     strcpy(out, mbx);
3504
3505     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3506                              pipe_mbxtofd_ast, p,
3507                              p->buf, p->bufsize, 0, 0, 0, 0));
3508
3509     return p;
3510 }
3511
3512 static void
3513 pipe_mbxtofd_ast(pPipe p)
3514 {
3515     int iss = p->iosb.status;
3516     int done = p->info->done;
3517     int iss2;
3518     int eof = (iss == SS$_ENDOFFILE);
3519     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3520     int err = !(iss&1) && !eof;
3521 #if defined(PERL_IMPLICIT_CONTEXT)
3522     pTHX = p->thx;
3523 #endif
3524
3525     if (done && myeof) {               /* end piping */
3526         close(p->fd_out);
3527         sys$dassgn(p->chan_in);
3528         *p->pipe_done = TRUE;
3529         _ckvmssts_noperl(sys$setef(pipe_ef));
3530         return;
3531     }
3532
3533     if (!err && !eof) {             /* good data to send to file */
3534         p->buf[p->iosb.count] = '\n';
3535         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3536         if (iss2 < 0) {
3537             p->retry++;
3538             if (p->retry < MAX_RETRY) {
3539                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3540                 return;
3541             }
3542         }
3543         p->retry = 0;
3544     } else if (err) {
3545         _ckvmssts_noperl(iss);
3546     }
3547
3548
3549     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3550           pipe_mbxtofd_ast, p,
3551           p->buf, p->bufsize, 0, 0, 0, 0);
3552     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3553     _ckvmssts_noperl(iss);
3554 }
3555
3556
3557 typedef struct _pipeloc     PLOC;
3558 typedef struct _pipeloc*   pPLOC;
3559
3560 struct _pipeloc {
3561     pPLOC   next;
3562     char    dir[NAM$C_MAXRSS+1];
3563 };
3564 static pPLOC  head_PLOC = 0;
3565
3566 void
3567 free_pipelocs(pTHX_ void *head)
3568 {
3569     pPLOC p, pnext;
3570     pPLOC *pHead = (pPLOC *)head;
3571
3572     p = *pHead;
3573     while (p) {
3574         pnext = p->next;
3575         PerlMem_free(p);
3576         p = pnext;
3577     }
3578     *pHead = 0;
3579 }
3580
3581 static void
3582 store_pipelocs(pTHX)
3583 {
3584     int    i;
3585     pPLOC  p;
3586     AV    *av = 0;
3587     SV    *dirsv;
3588     char  *dir, *x;
3589     char  *unixdir;
3590     char  temp[NAM$C_MAXRSS+1];
3591     STRLEN n_a;
3592
3593     if (head_PLOC)
3594         free_pipelocs(aTHX_ &head_PLOC);
3595
3596 /*  the . directory from @INC comes last */
3597
3598     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3599     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3600     p->next = head_PLOC;
3601     head_PLOC = p;
3602     strcpy(p->dir,"./");
3603
3604 /*  get the directory from $^X */
3605
3606     unixdir = PerlMem_malloc(VMS_MAXRSS);
3607     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3608
3609 #ifdef PERL_IMPLICIT_CONTEXT
3610     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3611 #else
3612     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3613 #endif
3614         my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3615         x = strrchr(temp,']');
3616         if (x == NULL) {
3617         x = strrchr(temp,'>');
3618           if (x == NULL) {
3619             /* It could be a UNIX path */
3620             x = strrchr(temp,'/');
3621           }
3622         }
3623         if (x)
3624           x[1] = '\0';
3625         else {
3626           /* Got a bare name, so use default directory */
3627           temp[0] = '.';
3628           temp[1] = '\0';
3629         }
3630
3631         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3632             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3633             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3634             p->next = head_PLOC;
3635             head_PLOC = p;
3636             my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3637         }
3638     }
3639
3640 /*  reverse order of @INC entries, skip "." since entered above */
3641
3642 #ifdef PERL_IMPLICIT_CONTEXT
3643     if (aTHX)
3644 #endif
3645     if (PL_incgv) av = GvAVn(PL_incgv);
3646
3647     for (i = 0; av && i <= AvFILL(av); i++) {
3648         dirsv = *av_fetch(av,i,TRUE);
3649
3650         if (SvROK(dirsv)) continue;
3651         dir = SvPVx(dirsv,n_a);
3652         if (strcmp(dir,".") == 0) continue;
3653         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3654             continue;
3655
3656         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3657         p->next = head_PLOC;
3658         head_PLOC = p;
3659         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3660     }
3661
3662 /* most likely spot (ARCHLIB) put first in the list */
3663
3664 #ifdef ARCHLIB_EXP
3665     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3666         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3667         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3668         p->next = head_PLOC;
3669         head_PLOC = p;
3670         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3671     }
3672 #endif
3673     PerlMem_free(unixdir);
3674 }
3675
3676 static I32
3677 Perl_cando_by_name_int
3678    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3679 #if !defined(PERL_IMPLICIT_CONTEXT)
3680 #define cando_by_name_int               Perl_cando_by_name_int
3681 #else
3682 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3683 #endif
3684
3685 static char *
3686 find_vmspipe(pTHX)
3687 {
3688     static int   vmspipe_file_status = 0;
3689     static char  vmspipe_file[NAM$C_MAXRSS+1];
3690
3691     /* already found? Check and use ... need read+execute permission */
3692
3693     if (vmspipe_file_status == 1) {
3694         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3695          && cando_by_name_int
3696            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3697             return vmspipe_file;
3698         }
3699         vmspipe_file_status = 0;
3700     }
3701
3702     /* scan through stored @INC, $^X */
3703
3704     if (vmspipe_file_status == 0) {
3705         char file[NAM$C_MAXRSS+1];
3706         pPLOC  p = head_PLOC;
3707
3708         while (p) {
3709             char * exp_res;
3710             int dirlen;
3711             dirlen = my_strlcpy(file, p->dir, sizeof(file));
3712             my_strlcat(file, "vmspipe.com", sizeof(file));
3713             p = p->next;
3714
3715             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3716             if (!exp_res) continue;
3717
3718             if (cando_by_name_int
3719                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3720              && cando_by_name_int
3721                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3722                 vmspipe_file_status = 1;
3723                 return vmspipe_file;
3724             }
3725         }
3726         vmspipe_file_status = -1;   /* failed, use tempfiles */
3727     }
3728
3729     return 0;
3730 }
3731
3732 static FILE *
3733 vmspipe_tempfile(pTHX)
3734 {
3735     char file[NAM$C_MAXRSS+1];
3736     FILE *fp;
3737     static int index = 0;
3738     Stat_t s0, s1;
3739     int cmp_result;
3740
3741     /* create a tempfile */
3742
3743     /* we can't go from   W, shr=get to  R, shr=get without
3744        an intermediate vulnerable state, so don't bother trying...
3745
3746        and lib$spawn doesn't shr=put, so have to close the write
3747
3748        So... match up the creation date/time and the FID to
3749        make sure we're dealing with the same file
3750
3751     */
3752
3753     index++;
3754     if (!decc_filename_unix_only) {
3755       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3756       fp = fopen(file,"w");
3757       if (!fp) {
3758         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3759         fp = fopen(file,"w");
3760         if (!fp) {
3761             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3762             fp = fopen(file,"w");
3763         }
3764       }
3765      }
3766      else {
3767       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3768       fp = fopen(file,"w");
3769       if (!fp) {
3770         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3771         fp = fopen(file,"w");
3772         if (!fp) {
3773           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3774           fp = fopen(file,"w");
3775         }
3776       }
3777     }
3778     if (!fp) return 0;  /* we're hosed */
3779
3780     fprintf(fp,"$! 'f$verify(0)'\n");
3781     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3782     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3783     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3784     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3785     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3786     fprintf(fp,"$ perl_del    = \"delete\"\n");
3787     fprintf(fp,"$ pif         = \"if\"\n");
3788     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3789     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3790     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3791     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3792     fprintf(fp,"$!  --- build command line to get max possible length\n");
3793     fprintf(fp,"$c=perl_popen_cmd0\n");
3794     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3795     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3796     fprintf(fp,"$x=perl_popen_cmd3\n");
3797     fprintf(fp,"$c=c+x\n");
3798     fprintf(fp,"$ perl_on\n");
3799     fprintf(fp,"$ 'c'\n");
3800     fprintf(fp,"$ perl_status = $STATUS\n");
3801     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3802     fprintf(fp,"$ perl_exit 'perl_status'\n");
3803     fsync(fileno(fp));
3804
3805     fgetname(fp, file, 1);
3806     fstat(fileno(fp), &s0.crtl_stat);
3807     fclose(fp);
3808
3809     if (decc_filename_unix_only)
3810         int_tounixspec(file, file, NULL);
3811     fp = fopen(file,"r","shr=get");
3812     if (!fp) return 0;
3813     fstat(fileno(fp), &s1.crtl_stat);
3814
3815     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3816     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3817         fclose(fp);
3818         return 0;
3819     }
3820
3821     return fp;
3822 }
3823
3824
3825 static int vms_is_syscommand_xterm(void)
3826 {
3827     const static struct dsc$descriptor_s syscommand_dsc =
3828       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3829
3830     const static struct dsc$descriptor_s decwdisplay_dsc =
3831       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3832
3833     struct item_list_3 items[2];
3834     unsigned short dvi_iosb[4];
3835     unsigned long devchar;
3836     unsigned long devclass;
3837     int status;
3838
3839     /* Very simple check to guess if sys$command is a decterm? */
3840     /* First see if the DECW$DISPLAY: device exists */
3841     items[0].len = 4;
3842     items[0].code = DVI$_DEVCHAR;
3843     items[0].bufadr = &devchar;
3844     items[0].retadr = NULL;
3845     items[1].len = 0;
3846     items[1].code = 0;
3847
3848     status = sys$getdviw
3849         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3850
3851     if ($VMS_STATUS_SUCCESS(status)) {
3852         status = dvi_iosb[0];
3853     }
3854
3855     if (!$VMS_STATUS_SUCCESS(status)) {
3856         SETERRNO(EVMSERR, status);
3857         return -1;
3858     }
3859
3860     /* If it does, then for now assume that we are on a workstation */
3861     /* Now verify that SYS$COMMAND is a terminal */
3862     /* for creating the debugger DECTerm */
3863
3864     items[0].len = 4;
3865     items[0].code = DVI$_DEVCLASS;
3866     items[0].bufadr = &devclass;
3867     items[0].retadr = NULL;
3868     items[1].len = 0;
3869     items[1].code = 0;
3870
3871     status = sys$getdviw
3872         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3873
3874     if ($VMS_STATUS_SUCCESS(status)) {
3875         status = dvi_iosb[0];
3876     }
3877
3878     if (!$VMS_STATUS_SUCCESS(status)) {
3879         SETERRNO(EVMSERR, status);
3880         return -1;
3881     }
3882     else {
3883         if (devclass == DC$_TERM) {
3884             return 0;
3885         }
3886     }
3887     return -1;
3888 }
3889
3890 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3891 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3892 {
3893     int status;
3894     int ret_stat;
3895     char * ret_char;
3896     char device_name[65];
3897     unsigned short device_name_len;
3898     struct dsc$descriptor_s customization_dsc;
3899     struct dsc$descriptor_s device_name_dsc;
3900     const char * cptr;
3901     char customization[200];
3902     char title[40];
3903     pInfo info = NULL;
3904     char mbx1[64];
3905     unsigned short p_chan;
3906     int n;
3907     unsigned short iosb[4];
3908     const char * cust_str =
3909         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3910     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3911                                           DSC$K_CLASS_S, mbx1};
3912
3913      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3914     /*---------------------------------------*/
3915     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3916
3917
3918     /* Make sure that this is from the Perl debugger */
3919     ret_char = strstr(cmd," xterm ");
3920     if (ret_char == NULL)
3921         return NULL;
3922     cptr = ret_char + 7;
3923     ret_char = strstr(cmd,"tty");
3924     if (ret_char == NULL)
3925         return NULL;
3926     ret_char = strstr(cmd,"sleep");
3927     if (ret_char == NULL)
3928         return NULL;
3929
3930     if (decw_term_port == 0) {
3931         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3932         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3933         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3934
3935        status = lib$find_image_symbol
3936                                (&filename1_dsc,
3937                                 &decw_term_port_dsc,
3938                                 (void *)&decw_term_port,
3939                                 NULL,
3940                                 0);
3941
3942         /* Try again with the other image name */
3943         if (!$VMS_STATUS_SUCCESS(status)) {
3944
3945            status = lib$find_image_symbol
3946                                (&filename2_dsc,
3947                                 &decw_term_port_dsc,
3948                                 (void *)&decw_term_port,
3949                                 NULL,
3950                                 0);
3951
3952         }
3953
3954     }
3955
3956
3957     /* No decw$term_port, give it up */
3958     if (!$VMS_STATUS_SUCCESS(status))
3959         return NULL;
3960
3961     /* Are we on a workstation? */
3962     /* to do: capture the rows / columns and pass their properties */
3963     ret_stat = vms_is_syscommand_xterm();
3964     if (ret_stat < 0)
3965         return NULL;
3966
3967     /* Make the title: */
3968     ret_char = strstr(cptr,"-title");
3969     if (ret_char != NULL) {
3970         while ((*cptr != 0) && (*cptr != '\"')) {
3971             cptr++;
3972         }
3973         if (*cptr == '\"')
3974             cptr++;
3975         n = 0;
3976         while ((*cptr != 0) && (*cptr != '\"')) {
3977             title[n] = *cptr;
3978             n++;
3979             if (n == 39) {
3980                 title[39] = 0;
3981                 break;
3982             }
3983             cptr++;
3984         }
3985         title[n] = 0;
3986     }
3987     else {
3988             /* Default title */
3989             strcpy(title,"Perl Debug DECTerm");
3990     }
3991     sprintf(customization, cust_str, title);
3992
3993     customization_dsc.dsc$a_pointer = customization;
3994     customization_dsc.dsc$w_length = strlen(customization);
3995     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3996     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3997
3998     device_name_dsc.dsc$a_pointer = device_name;
3999     device_name_dsc.dsc$w_length = sizeof device_name -1;
4000     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4001     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4002
4003     device_name_len = 0;
4004
4005     /* Try to create the window */
4006      status = (*decw_term_port)
4007        (NULL,
4008         NULL,
4009         &customization_dsc,
4010         &device_name_dsc,
4011         &device_name_len,
4012         NULL,
4013         NULL,
4014         NULL);
4015     if (!$VMS_STATUS_SUCCESS(status)) {
4016         SETERRNO(EVMSERR, status);
4017         return NULL;
4018     }
4019
4020     device_name[device_name_len] = '\0';
4021
4022     /* Need to set this up to look like a pipe for cleanup */
4023     n = sizeof(Info);
4024     status = lib$get_vm(&n, &info);
4025     if (!$VMS_STATUS_SUCCESS(status)) {
4026         SETERRNO(ENOMEM, status);
4027         return NULL;
4028     }
4029
4030     info->mode = *mode;
4031     info->done = FALSE;
4032     info->completion = 0;
4033     info->closing    = FALSE;
4034     info->in         = 0;
4035     info->out        = 0;
4036     info->err        = 0;
4037     info->fp         = NULL;
4038     info->useFILE    = 0;
4039     info->waiting    = 0;
4040     info->in_done    = TRUE;
4041     info->out_done   = TRUE;
4042     info->err_done   = TRUE;
4043
4044     /* Assign a channel on this so that it will persist, and not login */
4045     /* We stash this channel in the info structure for reference. */
4046     /* The created xterm self destructs when the last channel is removed */
4047     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4048     /* So leave this assigned. */
4049     device_name_dsc.dsc$w_length = device_name_len;
4050     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4051     if (!$VMS_STATUS_SUCCESS(status)) {
4052         SETERRNO(EVMSERR, status);
4053         return NULL;
4054     }
4055     info->xchan_valid = 1;
4056
4057     /* Now create a mailbox to be read by the application */
4058
4059     create_mbx(&p_chan, &d_mbx1);
4060
4061     /* write the name of the created terminal to the mailbox */
4062     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4063             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4064
4065     if (!$VMS_STATUS_SUCCESS(status)) {
4066         SETERRNO(EVMSERR, status);
4067         return NULL;
4068     }
4069
4070     info->fp  = PerlIO_open(mbx1, mode);
4071
4072     /* Done with this channel */
4073     sys$dassgn(p_chan);
4074
4075     /* If any errors, then clean up */
4076     if (!info->fp) {
4077         n = sizeof(Info);
4078         _ckvmssts_noperl(lib$free_vm(&n, &info));
4079         return NULL;
4080         }
4081
4082     /* All done */
4083     return info->fp;
4084 }
4085
4086 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4087
4088 static PerlIO *
4089 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4090 {
4091     static int handler_set_up = FALSE;
4092     PerlIO * ret_fp;
4093     unsigned long int sts, flags = CLI$M_NOWAIT;
4094     /* The use of a GLOBAL table (as was done previously) rendered
4095      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4096      * environment.  Hence we've switched to LOCAL symbol table.
4097      */
4098     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4099     int j, wait = 0, n;
4100     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4101     char *in, *out, *err, mbx[512];
4102     FILE *tpipe = 0;
4103     char tfilebuf[NAM$C_MAXRSS+1];
4104     pInfo info = NULL;
4105     char cmd_sym_name[20];
4106     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4107                                       DSC$K_CLASS_S, symbol};
4108     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4109                                       DSC$K_CLASS_S, 0};
4110     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4111                                       DSC$K_CLASS_S, cmd_sym_name};
4112     struct dsc$descriptor_s *vmscmd;
4113     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4114     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4115     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4116
4117     /* Check here for Xterm create request.  This means looking for
4118      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4119      *  is possible to create an xterm.
4120      */
4121     if (*in_mode == 'r') {
4122         PerlIO * xterm_fd;
4123
4124 #if defined(PERL_IMPLICIT_CONTEXT)
4125         /* Can not fork an xterm with a NULL context */
4126         /* This probably could never happen */
4127         xterm_fd = NULL;
4128         if (aTHX != NULL)
4129 #endif
4130         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4131         if (xterm_fd != NULL)
4132             return xterm_fd;
4133     }
4134
4135     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4136
4137     /* once-per-program initialization...
4138        note that the SETAST calls and the dual test of pipe_ef
4139        makes sure that only the FIRST thread through here does
4140        the initialization...all other threads wait until it's
4141        done.
4142
4143        Yeah, uglier than a pthread call, it's got all the stuff inline
4144        rather than in a separate routine.
4145     */
4146
4147     if (!pipe_ef) {
4148         _ckvmssts_noperl(sys$setast(0));
4149         if (!pipe_ef) {
4150             unsigned long int pidcode = JPI$_PID;
4151             $DESCRIPTOR(d_delay, RETRY_DELAY);
4152             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4153             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4154             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4155         }
4156         if (!handler_set_up) {
4157           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4158           handler_set_up = TRUE;
4159         }
4160         _ckvmssts_noperl(sys$setast(1));
4161     }
4162
4163     /* see if we can find a VMSPIPE.COM */
4164
4165     tfilebuf[0] = '@';
4166     vmspipe = find_vmspipe(aTHX);
4167     if (vmspipe) {
4168         vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4169     } else {        /* uh, oh...we're in tempfile hell */
4170         tpipe = vmspipe_tempfile(aTHX);
4171         if (!tpipe) {       /* a fish popular in Boston */
4172             if (ckWARN(WARN_PIPE)) {
4173                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4174             }
4175         return NULL;
4176         }
4177         fgetname(tpipe,tfilebuf+1,1);
4178         vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4179     }
4180     vmspipedsc.dsc$a_pointer = tfilebuf;
4181
4182     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4183     if (!(sts & 1)) {
4184       switch (sts) {
4185         case RMS$_FNF:  case RMS$_DNF:
4186           set_errno(ENOENT); break;
4187         case RMS$_DIR:
4188           set_errno(ENOTDIR); break;
4189         case RMS$_DEV:
4190           set_errno(ENODEV); break;
4191         case RMS$_PRV:
4192           set_errno(EACCES); break;
4193         case RMS$_SYN:
4194           set_errno(EINVAL); break;
4195         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4196           set_errno(E2BIG); break;
4197         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4198           _ckvmssts_noperl(sts); /* fall through */
4199         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4200           set_errno(EVMSERR);
4201       }
4202       set_vaxc_errno(sts);
4203       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4204         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4205       }
4206       *psts = sts;
4207       return NULL;
4208     }
4209     n = sizeof(Info);
4210     _ckvmssts_noperl(lib$get_vm(&n, &info));
4211
4212     my_strlcpy(mode, in_mode, sizeof(mode));
4213     info->mode = *mode;
4214     info->done = FALSE;
4215     info->completion = 0;
4216     info->closing    = FALSE;
4217     info->in         = 0;
4218     info->out        = 0;
4219     info->err        = 0;
4220     info->fp         = NULL;
4221     info->useFILE    = 0;
4222     info->waiting    = 0;
4223     info->in_done    = TRUE;
4224     info->out_done   = TRUE;
4225     info->err_done   = TRUE;
4226     info->xchan      = 0;
4227     info->xchan_valid = 0;
4228
4229     in = PerlMem_malloc(VMS_MAXRSS);
4230     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4231     out = PerlMem_malloc(VMS_MAXRSS);
4232     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4233     err = PerlMem_malloc(VMS_MAXRSS);
4234     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4235
4236     in[0] = out[0] = err[0] = '\0';
4237
4238     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4239         info->useFILE = 1;
4240         strcpy(p,p+1);
4241     }
4242     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4243         wait = 1;
4244         strcpy(p,p+1);
4245     }
4246
4247     if (*mode == 'r') {             /* piping from subroutine */
4248
4249         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4250         if (info->out) {
4251             info->out->pipe_done = &info->out_done;
4252             info->out_done = FALSE;
4253             info->out->info = info;
4254         }
4255         if (!info->useFILE) {
4256             info->fp  = PerlIO_open(mbx, mode);
4257         } else {
4258             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4259             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4260         }
4261
4262         if (!info->fp && info->out) {
4263             sys$cancel(info->out->chan_out);
4264
4265             while (!info->out_done) {
4266                 int done;
4267                 _ckvmssts_noperl(sys$setast(0));
4268                 done = info->out_done;
4269                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4270                 _ckvmssts_noperl(sys$setast(1));
4271                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4272             }
4273
4274             if (info->out->buf) {
4275                 n = info->out->bufsize * sizeof(char);
4276                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4277             }
4278             n = sizeof(Pipe);
4279             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4280             n = sizeof(Info);
4281             _ckvmssts_noperl(lib$free_vm(&n, &info));
4282             *psts = RMS$_FNF;
4283             return NULL;
4284         }
4285
4286         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4287         if (info->err) {
4288             info->err->pipe_done = &info->err_done;
4289             info->err_done = FALSE;
4290             info->err->info = info;
4291         }
4292
4293     } else if (*mode == 'w') {      /* piping to subroutine */
4294
4295         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4296         if (info->out) {
4297             info->out->pipe_done = &info->out_done;
4298             info->out_done = FALSE;
4299             info->out->info = info;
4300         }
4301
4302         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4303         if (info->err) {
4304             info->err->pipe_done = &info->err_done;
4305             info->err_done = FALSE;
4306             info->err->info = info;
4307         }
4308
4309         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4310         if (!info->useFILE) {
4311             info->fp  = PerlIO_open(mbx, mode);
4312         } else {
4313             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4314             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4315         }
4316
4317         if (info->in) {
4318             info->in->pipe_done = &info->in_done;
4319             info->in_done = FALSE;
4320             info->in->info = info;
4321         }
4322
4323         /* error cleanup */
4324         if (!info->fp && info->in) {
4325             info->done = TRUE;
4326             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4327                                       0, 0, 0, 0, 0, 0, 0, 0));
4328
4329             while (!info->in_done) {
4330                 int done;
4331                 _ckvmssts_noperl(sys$setast(0));
4332                 done = info->in_done;
4333                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4334                 _ckvmssts_noperl(sys$setast(1));
4335                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4336             }
4337
4338             if (info->in->buf) {
4339                 n = info->in->bufsize * sizeof(char);
4340                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4341             }
4342             n = sizeof(Pipe);
4343             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4344             n = sizeof(Info);
4345             _ckvmssts_noperl(lib$free_vm(&n, &info));
4346             *psts = RMS$_FNF;
4347             return NULL;
4348         }
4349
4350
4351     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4352         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4353         if (info->out) {
4354             info->out->pipe_done = &info->out_done;
4355             info->out_done = FALSE;
4356             info->out->info = info;
4357         }
4358
4359         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4360         if (info->err) {
4361             info->err->pipe_done = &info->err_done;
4362             info->err_done = FALSE;
4363             info->err->info = info;
4364         }
4365     }
4366
4367     d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4368     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4369
4370     d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4371     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4372
4373     d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4374     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4375
4376     /* Done with the names for the pipes */
4377     PerlMem_free(err);
4378     PerlMem_free(out);
4379     PerlMem_free(in);
4380
4381     p = vmscmd->dsc$a_pointer;
4382     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4383     if (*p == '$') p++;                         /* remove leading $ */
4384     while (*p == ' ' || *p == '\t') p++;
4385
4386     for (j = 0; j < 4; j++) {
4387         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4388         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4389
4390     d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4391     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4392
4393         if (strlen(p) > MAX_DCL_SYMBOL) {
4394             p += MAX_DCL_SYMBOL;
4395         } else {
4396             p += strlen(p);
4397         }
4398     }
4399     _ckvmssts_noperl(sys$setast(0));
4400     info->next=open_pipes;  /* prepend to list */
4401     open_pipes=info;
4402     _ckvmssts_noperl(sys$setast(1));
4403     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4404      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4405      * have SYS$COMMAND if we need it.
4406      */
4407     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4408                       0, &info->pid, &info->completion,
4409                       0, popen_completion_ast,info,0,0,0));
4410
4411     /* if we were using a tempfile, close it now */
4412
4413     if (tpipe) fclose(tpipe);
4414
4415     /* once the subprocess is spawned, it has copied the symbols and
4416        we can get rid of ours */
4417
4418     for (j = 0; j < 4; j++) {
4419         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4420         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4421     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4422     }
4423     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4424     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4425     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4426     vms_execfree(vmscmd);
4427
4428 #ifdef PERL_IMPLICIT_CONTEXT
4429     if (aTHX)
4430 #endif
4431     PL_forkprocess = info->pid;
4432
4433     ret_fp = info->fp;
4434     if (wait) {
4435          dSAVEDERRNO;
4436          int done = 0;
4437          while (!done) {
4438              _ckvmssts_noperl(sys$setast(0));
4439              done = info->done;
4440              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4441              _ckvmssts_noperl(sys$setast(1));
4442              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4443          }
4444         *psts = info->completion;
4445 /* Caller thinks it is open and tries to close it. */
4446 /* This causes some problems, as it changes the error status */
4447 /*        my_pclose(info->fp); */
4448
4449          /* If we did not have a file pointer open, then we have to */
4450          /* clean up here or eventually we will run out of something */
4451          SAVE_ERRNO;
4452          if (info->fp == NULL) {
4453              my_pclose_pinfo(aTHX_ info);
4454          }
4455          RESTORE_ERRNO;
4456
4457     } else {
4458         *psts = info->pid;
4459     }
4460     return ret_fp;
4461 }  /* end of safe_popen */
4462
4463
4464 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4465 PerlIO *
4466 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4467 {
4468     int sts;
4469     TAINT_ENV();
4470     TAINT_PROPER("popen");
4471     PERL_FLUSHALL_FOR_CHILD;
4472     return safe_popen(aTHX_ cmd,mode,&sts);
4473 }
4474
4475 /*}}}*/
4476
4477
4478 /* Routine to close and cleanup a pipe info structure */
4479
4480 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4481
4482     unsigned long int retsts;
4483     int done, n;
4484     pInfo next, last;
4485
4486     /* If we were writing to a subprocess, insure that someone reading from
4487      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4488      * produce an EOF record in the mailbox.
4489      *
4490      *  well, at least sometimes it *does*, so we have to watch out for
4491      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4492      */
4493      if (info->fp) {
4494         if (!info->useFILE
4495 #if defined(USE_ITHREADS)
4496           && my_perl
4497 #endif
4498 #ifdef USE_PERLIO
4499           && PL_perlio_fd_refcnt
4500 #endif
4501            )
4502             PerlIO_flush(info->fp);
4503         else
4504             fflush((FILE *)info->fp);
4505     }
4506
4507     _ckvmssts(sys$setast(0));
4508      info->closing = TRUE;
4509      done = info->done && info->in_done && info->out_done && info->err_done;
4510      /* hanging on write to Perl's input? cancel it */
4511      if (info->mode == 'r' && info->out && !info->out_done) {
4512         if (info->out->chan_out) {
4513             _ckvmssts(sys$cancel(info->out->chan_out));
4514             if (!info->out->chan_in) {   /* EOF generation, need AST */
4515                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4516             }
4517         }
4518      }
4519      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4520          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4521                            0, 0, 0, 0, 0, 0));
4522     _ckvmssts(sys$setast(1));
4523     if (info->fp) {
4524      if (!info->useFILE
4525 #if defined(USE_ITHREADS)
4526          && my_perl
4527 #endif
4528 #ifdef USE_PERLIO
4529          && PL_perlio_fd_refcnt
4530 #endif
4531         )
4532         PerlIO_close(info->fp);
4533      else
4534         fclose((FILE *)info->fp);
4535     }
4536      /*
4537         we have to wait until subprocess completes, but ALSO wait until all
4538         the i/o completes...otherwise we'll be freeing the "info" structure
4539         that the i/o ASTs could still be using...
4540      */
4541
4542      while (!done) {
4543          _ckvmssts(sys$setast(0));
4544          done = info->done && info->in_done && info->out_done && info->err_done;
4545          if (!done) _ckvmssts(sys$clref(pipe_ef));
4546          _ckvmssts(sys$setast(1));
4547          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4548      }
4549      retsts = info->completion;
4550
4551     /* remove from list of open pipes */
4552     _ckvmssts(sys$setast(0));
4553     last = NULL;
4554     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4555         if (next == info)
4556             break;
4557     }
4558
4559     if (last)
4560         last->next = info->next;
4561     else
4562         open_pipes = info->next;
4563     _ckvmssts(sys$setast(1));
4564
4565     /* free buffers and structures */
4566
4567     if (info->in) {
4568         if (info->in->buf) {
4569             n = info->in->bufsize * sizeof(char);
4570             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4571         }
4572         n = sizeof(Pipe);
4573         _ckvmssts(lib$free_vm(&n, &info->in));
4574     }
4575     if (info->out) {
4576         if (info->out->buf) {
4577             n = info->out->bufsize * sizeof(char);
4578             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4579         }
4580         n = sizeof(Pipe);
4581         _ckvmssts(lib$free_vm(&n, &info->out));
4582     }
4583     if (info->err) {
4584         if (info->err->buf) {
4585             n = info->err->bufsize * sizeof(char);
4586             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4587         }
4588         n = sizeof(Pipe);
4589         _ckvmssts(lib$free_vm(&n, &info->err));
4590     }
4591     n = sizeof(Info);
4592     _ckvmssts(lib$free_vm(&n, &info));
4593
4594     return retsts;
4595 }
4596
4597
4598 /*{{{  I32 my_pclose(PerlIO *fp)*/
4599 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4600 {
4601     pInfo info, last = NULL;
4602     I32 ret_status;
4603
4604     /* Fixme - need ast and mutex protection here */
4605     for (info = open_pipes; info != NULL; last = info, info = info->next)
4606         if (info->fp == fp) break;
4607
4608     if (info == NULL) {  /* no such pipe open */
4609       set_errno(ECHILD); /* quoth POSIX */
4610       set_vaxc_errno(SS$_NONEXPR);
4611       return -1;
4612     }
4613
4614     ret_status = my_pclose_pinfo(aTHX_ info);
4615
4616     return ret_status;
4617
4618 }  /* end of my_pclose() */
4619
4620 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4621   /* Roll our own prototype because we want this regardless of whether
4622    * _VMS_WAIT is defined.
4623    */
4624   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4625 #endif
4626 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4627    created with popen(); otherwise partially emulate waitpid() unless
4628    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4629    Also check processes not considered by the CRTL waitpid().
4630  */
4631 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4632 Pid_t
4633 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4634 {
4635     pInfo info;
4636     int done;
4637     int sts;
4638     int j;
4639
4640     if (statusp) *statusp = 0;
4641
4642     for (info = open_pipes; info != NULL; info = info->next)
4643         if (info->pid == pid) break;
4644
4645     if (info != NULL) {  /* we know about this child */
4646       while (!info->done) {
4647           _ckvmssts(sys$setast(0));
4648           done = info->done;
4649           if (!done) _ckvmssts(sys$clref(pipe_ef));
4650           _ckvmssts(sys$setast(1));
4651           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4652       }
4653
4654       if (statusp) *statusp = info->completion;
4655       return pid;
4656     }
4657
4658     /* child that already terminated? */
4659
4660     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4661         if (closed_list[j].pid == pid) {
4662             if (statusp) *statusp = closed_list[j].completion;
4663             return pid;
4664         }
4665     }
4666
4667     /* fall through if this child is not one of our own pipe children */
4668
4669 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4670
4671       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4672        * in 7.2 did we get a version that fills in the VMS completion
4673        * status as Perl has always tried to do.
4674        */
4675
4676       sts = __vms_waitpid( pid, statusp, flags );
4677
4678       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4679          return sts;
4680
4681       /* If the real waitpid tells us the child does not exist, we
4682        * fall through here to implement waiting for a child that
4683        * was created by some means other than exec() (say, spawned
4684        * from DCL) or to wait for a process that is not a subprocess
4685        * of the current process.
4686        */
4687
4688 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4689
4690     {
4691       $DESCRIPTOR(intdsc,"0 00:00:01");
4692       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4693       unsigned long int pidcode = JPI$_PID, mypid;
4694       unsigned long int interval[2];
4695       unsigned int jpi_iosb[2];
4696       struct itmlst_3 jpilist[2] = {
4697           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4698           {                      0,         0,                 0, 0}
4699       };
4700
4701       if (pid <= 0) {
4702         /* Sorry folks, we don't presently implement rooting around for
4703            the first child we can find, and we definitely don't want to
4704            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4705          */
4706         set_errno(ENOTSUP);
4707         return -1;
4708       }
4709
4710       /* Get the owner of the child so I can warn if it's not mine. If the
4711        * process doesn't exist or I don't have the privs to look at it,
4712        * I can go home early.
4713        */
4714       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4715       if (sts & 1) sts = jpi_iosb[0];
4716       if (!(sts & 1)) {
4717         switch (sts) {
4718             case SS$_NONEXPR:
4719                 set_errno(ECHILD);
4720                 break;
4721             case SS$_NOPRIV:
4722                 set_errno(EACCES);
4723                 break;
4724             default:
4725                 _ckvmssts(sts);
4726         }
4727         set_vaxc_errno(sts);
4728         return -1;
4729       }
4730
4731       if (ckWARN(WARN_EXEC)) {
4732         /* remind folks they are asking for non-standard waitpid behavior */
4733         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4734         if (ownerpid != mypid)
4735           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4736                       "waitpid: process %x is not a child of process %x",
4737                       pid,mypid);
4738       }
4739
4740       /* simply check on it once a second until it's not there anymore. */
4741
4742       _ckvmssts(sys$bintim(&intdsc,interval));
4743       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4744             _ckvmssts(sys$schdwk(0,0,interval,0));
4745             _ckvmssts(sys$hiber());
4746       }
4747       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4748
4749       _ckvmssts(sts);
4750       return pid;
4751     }
4752 }  /* end of waitpid() */
4753 /*}}}*/
4754 /*}}}*/
4755 /*}}}*/
4756
4757 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4758 char *
4759 my_gconvert(double val, int ndig, int trail, char *buf)
4760 {
4761   static char __gcvtbuf[DBL_DIG+1];
4762   char *loc;
4763
4764   loc = buf ? buf : __gcvtbuf;
4765
4766 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4767   if (val < 1) {
4768     sprintf(loc,"%.*g",ndig,val);
4769     return loc;
4770   }
4771 #endif
4772
4773   if (val) {
4774     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4775     return gcvt(val,ndig,loc);
4776   }
4777   else {
4778     loc[0] = '0'; loc[1] = '\0';
4779     return loc;
4780   }
4781
4782 }
4783 /*}}}*/
4784
4785 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4786 static int rms_free_search_context(struct FAB * fab)
4787 {
4788 struct NAM * nam;
4789
4790     nam = fab->fab$l_nam;
4791     nam->nam$b_nop |= NAM$M_SYNCHK;
4792     nam->nam$l_rlf = NULL;
4793     fab->fab$b_dns = 0;
4794     return sys$parse(fab, NULL, NULL);
4795 }
4796
4797 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4798 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4799 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4800 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4801 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4802 #define rms_nam_esll(nam) nam.nam$b_esl
4803 #define rms_nam_esl(nam) nam.nam$b_esl
4804 #define rms_nam_name(nam) nam.nam$l_name
4805 #define rms_nam_namel(nam) nam.nam$l_name
4806 #define rms_nam_type(nam) nam.nam$l_type
4807 #define rms_nam_typel(nam) nam.nam$l_type
4808 #define rms_nam_ver(nam) nam.nam$l_ver
4809 #define rms_nam_verl(nam) nam.nam$l_ver
4810 #define rms_nam_rsll(nam) nam.nam$b_rsl
4811 #define rms_nam_rsl(nam) nam.nam$b_rsl
4812 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4813 #define rms_set_fna(fab, nam, name, size) \
4814         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4815 #define rms_get_fna(fab, nam) fab.fab$l_fna
4816 #define rms_set_dna(fab, nam, name, size) \
4817         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4818 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4819 #define rms_set_esa(nam, name, size) \
4820         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4821 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4822         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4823 #define rms_set_rsa(nam, name, size) \
4824         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4825 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4826         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4827 #define rms_nam_name_type_l_size(nam) \
4828         (nam.nam$b_name + nam.nam$b_type)
4829 #else
4830 static int rms_free_search_context(struct FAB * fab)
4831 {
4832 struct NAML * nam;
4833
4834     nam = fab->fab$l_naml;
4835     nam->naml$b_nop |= NAM$M_SYNCHK;
4836     nam->naml$l_rlf = NULL;
4837     nam->naml$l_long_defname_size = 0;
4838
4839     fab->fab$b_dns = 0;
4840     return sys$parse(fab, NULL, NULL);
4841 }
4842
4843 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4844 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4845 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4846 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4847 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4848 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4849 #define rms_nam_esl(nam) nam.naml$b_esl
4850 #define rms_nam_name(nam) nam.naml$l_name
4851 #define rms_nam_namel(nam) nam.naml$l_long_name
4852 #define rms_nam_type(nam) nam.naml$l_type
4853 #define rms_nam_typel(nam) nam.naml$l_long_type
4854 #define rms_nam_ver(nam) nam.naml$l_ver
4855 #define rms_nam_verl(nam) nam.naml$l_long_ver
4856 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4857 #define rms_nam_rsl(nam) nam.naml$b_rsl
4858 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4859 #define rms_set_fna(fab, nam, name, size) \
4860         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4861         nam.naml$l_long_filename_size = size; \
4862         nam.naml$l_long_filename = name;}
4863 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4864 #define rms_set_dna(fab, nam, name, size) \
4865         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4866         nam.naml$l_long_defname_size = size; \
4867         nam.naml$l_long_defname = name; }
4868 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4869 #define rms_set_esa(nam, name, size) \
4870         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4871         nam.naml$l_long_expand_alloc = size; \
4872         nam.naml$l_long_expand = name; }
4873 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4874         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4875         nam.naml$l_long_expand = l_name; \
4876         nam.naml$l_long_expand_alloc = l_size; }
4877 #define rms_set_rsa(nam, name, size) \
4878         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4879         nam.naml$l_long_result = name; \
4880         nam.naml$l_long_result_alloc = size; }
4881 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4882         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4883         nam.naml$l_long_result = l_name; \
4884         nam.naml$l_long_result_alloc = l_size; }
4885 #define rms_nam_name_type_l_size(nam) \
4886         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4887 #endif
4888
4889
4890 /* rms_erase
4891  * The CRTL for 8.3 and later can create symbolic links in any mode,
4892  * however in 8.3 the unlink/remove/delete routines will only properly handle
4893  * them if one of the PCP modes is active.
4894  */
4895 static int rms_erase(const char * vmsname)
4896 {
4897   int status;
4898   struct FAB myfab = cc$rms_fab;
4899   rms_setup_nam(mynam);
4900
4901   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4902   rms_bind_fab_nam(myfab, mynam);
4903
4904 #ifdef NAML$M_OPEN_SPECIAL
4905   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4906 #endif
4907
4908   status = sys$erase(&myfab, 0, 0);
4909
4910   return status;
4911 }
4912
4913
4914 static int
4915 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4916                     const struct dsc$descriptor_s * vms_dst_dsc,
4917                     unsigned long flags)
4918 {
4919     /*  VMS and UNIX handle file permissions differently and the
4920      * the same ACL trick may be needed for renaming files,
4921      * especially if they are directories.
4922      */
4923
4924    /* todo: get kill_file and rename to share common code */
4925    /* I can not find online documentation for $change_acl
4926     * it appears to be replaced by $set_security some time ago */
4927
4928 const unsigned int access_mode = 0;
4929 $DESCRIPTOR(obj_file_dsc,"FILE");
4930 char *vmsname;
4931 char *rslt;
4932 unsigned long int jpicode = JPI$_UIC;
4933 int aclsts, fndsts, rnsts = -1;
4934 unsigned int ctx = 0;
4935 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4936 struct dsc$descriptor_s * clean_dsc;
4937
4938 struct myacedef {
4939     unsigned char myace$b_length;
4940     unsigned char myace$b_type;
4941     unsigned short int myace$w_flags;
4942     unsigned long int myace$l_access;
4943     unsigned long int myace$l_ident;
4944 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4945              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4946              0},
4947              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4948
4949 struct item_list_3
4950         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4951                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4952                       {0,0,0,0}},
4953         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4954         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4955                      {0,0,0,0}};
4956
4957
4958     /* Expand the input spec using RMS, since we do not want to put
4959      * ACLs on the target of a symbolic link */
4960     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4961     if (vmsname == NULL)
4962         return SS$_INSFMEM;
4963
4964     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4965                         vmsname,
4966                         PERL_RMSEXPAND_M_SYMLINK);
4967     if (rslt == NULL) {
4968         PerlMem_free(vmsname);
4969         return SS$_INSFMEM;
4970     }
4971
4972     /* So we get our own UIC to use as a rights identifier,
4973      * and the insert an ACE at the head of the ACL which allows us
4974      * to delete the file.
4975      */
4976     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4977
4978     fildsc.dsc$w_length = strlen(vmsname);
4979     fildsc.dsc$a_pointer = vmsname;
4980     ctx = 0;
4981     newace.myace$l_ident = oldace.myace$l_ident;
4982     rnsts = SS$_ABORT;
4983
4984     /* Grab any existing ACEs with this identifier in case we fail */
4985     clean_dsc = &fildsc;
4986     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4987                                &fildsc,
4988                                NULL,
4989                                OSS$M_WLOCK,
4990                                findlst,
4991                                &ctx,
4992                                &access_mode);
4993
4994     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4995         /* Add the new ACE . . . */
4996
4997         /* if the sys$get_security succeeded, then ctx is valid, and the
4998          * object/file descriptors will be ignored.  But otherwise they
4999          * are needed
5000          */
5001         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5002                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5003         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5004             set_errno(EVMSERR);
5005             set_vaxc_errno(aclsts);
5006             PerlMem_free(vmsname);
5007             return aclsts;
5008         }
5009
5010         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5011                                 NULL, NULL,
5012                                 &flags,
5013                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5014
5015         if ($VMS_STATUS_SUCCESS(rnsts)) {
5016             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5017         }
5018
5019         /* Put things back the way they were. */
5020         ctx = 0;
5021         aclsts = sys$get_security(&obj_file_dsc,
5022                                   clean_dsc,
5023                                   NULL,
5024                                   OSS$M_WLOCK,
5025                                   findlst,
5026                                   &ctx,
5027                                   &access_mode);
5028
5029         if ($VMS_STATUS_SUCCESS(aclsts)) {
5030         int sec_flags;
5031
5032             sec_flags = 0;
5033             if (!$VMS_STATUS_SUCCESS(fndsts))
5034                 sec_flags = OSS$M_RELCTX;
5035
5036             /* Get rid of the new ACE */
5037             aclsts = sys$set_security(NULL, NULL, NULL,
5038                                   sec_flags, dellst, &ctx, &access_mode);
5039
5040             /* If there was an old ACE, put it back */
5041             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5042                 addlst[0].bufadr = &oldace;
5043                 aclsts = sys$set_security(NULL, NULL, NULL,
5044                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5045                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5046                     set_errno(EVMSERR);
5047                     set_vaxc_errno(aclsts);
5048                     rnsts = aclsts;
5049                 }
5050             } else {
5051             int aclsts2;
5052
5053                 /* Try to clear the lock on the ACL list */
5054                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5055                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5056
5057                 /* Rename errors are most important */
5058                 if (!$VMS_STATUS_SUCCESS(rnsts))
5059                     aclsts = rnsts;
5060                 set_errno(EVMSERR);
5061                 set_vaxc_errno(aclsts);
5062                 rnsts = aclsts;
5063             }
5064         }
5065         else {
5066             if (aclsts != SS$_ACLEMPTY)
5067                 rnsts = aclsts;
5068         }
5069     }
5070     else
5071         rnsts = fndsts;
5072
5073     PerlMem_free(vmsname);
5074     return rnsts;
5075 }
5076
5077
5078 /*{{{int rename(const char *, const char * */
5079 /* Not exactly what X/Open says to do, but doing it absolutely right
5080  * and efficiently would require a lot more work.  This should be close
5081  * enough to pass all but the most strict X/Open compliance test.
5082  */
5083 int
5084 Perl_rename(pTHX_ const char *src, const char * dst)
5085 {
5086 int retval;
5087 int pre_delete = 0;
5088 int src_sts;
5089 int dst_sts;
5090 Stat_t src_st;
5091 Stat_t dst_st;
5092
5093     /* Validate the source file */
5094     src_sts = flex_lstat(src, &src_st);
5095     if (src_sts != 0) {
5096
5097         /* No source file or other problem */
5098         return src_sts;
5099     }
5100     if (src_st.st_devnam[0] == 0)  {
5101         /* This may be possible so fail if it is seen. */
5102         errno = EIO;
5103         return -1;
5104     }
5105
5106     dst_sts = flex_lstat(dst, &dst_st);
5107     if (dst_sts == 0) {
5108
5109         if (dst_st.st_dev != src_st.st_dev) {
5110             /* Must be on the same device */
5111             errno = EXDEV;
5112             return -1;
5113         }
5114
5115         /* VMS_INO_T_COMPARE is true if the inodes are different
5116          * to match the output of memcmp
5117          */
5118
5119         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5120             /* That was easy, the files are the same! */
5121             return 0;
5122         }
5123
5124         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5125             /* If source is a directory, so must be dest */
5126                 errno = EISDIR;
5127                 return -1;
5128         }
5129
5130     }
5131
5132
5133     if ((dst_sts == 0) &&
5134         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5135
5136         /* We have issues here if vms_unlink_all_versions is set
5137          * If the destination exists, and is not a directory, then
5138          * we must delete in advance.
5139          *
5140          * If the src is a directory, then we must always pre-delete
5141          * the destination.
5142          *
5143          * If we successfully delete the dst in advance, and the rename fails
5144          * X/Open requires that errno be EIO.
5145          *
5146          */
5147
5148         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5149             int d_sts;
5150             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5151                                      S_ISDIR(dst_st.st_mode));
5152
5153            /* Need to delete all versions ? */
5154            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5155                 int i = 0;
5156
5157                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5158                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5159                     if (d_sts != 0)
5160                         break;
5161                     i++;
5162
5163                     /* Make sure that we do not loop forever */
5164                     if (i > 32767) {
5165                         errno = EIO;
5166                         d_sts = -1;
5167                         break;
5168                     }
5169                 }
5170            }
5171
5172             if (d_sts != 0)
5173                 return d_sts;
5174
5175             /* We killed the destination, so only errno now is EIO */
5176             pre_delete = 1;
5177         }
5178     }
5179
5180     /* Originally the idea was to call the CRTL rename() and only
5181      * try the lib$rename_file if it failed.
5182      * It turns out that there are too many variants in what the
5183      * the CRTL rename might do, so only use lib$rename_file
5184      */
5185     retval = -1;
5186
5187     {
5188         /* Is the source and dest both in VMS format */
5189         /* if the source is a directory, then need to fileify */
5190         /*  and dest must be a directory or non-existent. */
5191
5192         char * vms_dst;
5193         int sts;
5194         char * ret_str;
5195         unsigned long flags;
5196         struct dsc$descriptor_s old_file_dsc;
5197         struct dsc$descriptor_s new_file_dsc;
5198
5199         /* We need to modify the src and dst depending
5200          * on if one or more of them are directories.
5201          */
5202
5203         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5204         if (vms_dst == NULL)
5205             _ckvmssts_noperl(SS$_INSFMEM);
5206
5207         if (S_ISDIR(src_st.st_mode)) {
5208         char * ret_str;
5209         char * vms_dir_file;
5210
5211             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5212             if (vms_dir_file == NULL)
5213                 _ckvmssts_noperl(SS$_INSFMEM);
5214
5215             /* If the dest is a directory, we must remove it */
5216             if (dst_sts == 0) {
5217                 int d_sts;
5218                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5219                 if (d_sts != 0) {
5220                     PerlMem_free(vms_dst);
5221                     errno = EIO;
5222                     return d_sts;
5223                 }
5224
5225                 pre_delete = 1;
5226             }
5227
5228            /* The dest must be a VMS file specification */
5229            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5230            if (ret_str == NULL) {
5231                 PerlMem_free(vms_dst);
5232                 errno = EIO;
5233                 return -1;
5234            }
5235
5236             /* The source must be a file specification */
5237             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5238             if (ret_str == NULL) {
5239                 PerlMem_free(vms_dst);
5240                 PerlMem_free(vms_dir_file);
5241                 errno = EIO;
5242                 return -1;
5243             }
5244             PerlMem_free(vms_dst);
5245             vms_dst = vms_dir_file;
5246
5247         } else {
5248             /* File to file or file to new dir */
5249
5250             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5251                 /* VMS pathify a dir target */
5252                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5253                 if (ret_str == NULL) {
5254                     PerlMem_free(vms_dst);
5255                     errno = EIO;
5256                     return -1;
5257                 }
5258             } else {
5259                 char * v_spec, * r_spec, * d_spec, * n_spec;
5260                 char * e_spec, * vs_spec;
5261                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5262
5263                 /* fileify a target VMS file specification */
5264                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5265                 if (ret_str == NULL) {
5266                     PerlMem_free(vms_dst);
5267                     errno = EIO;
5268                     return -1;
5269                 }
5270
5271                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5272                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5273                              &e_len, &vs_spec, &vs_len);
5274                 if (sts == 0) {
5275                      if (e_len == 0) {
5276                          /* Get rid of the version */
5277                          if (vs_len != 0) {
5278                              *vs_spec = '\0';
5279                          }
5280                          /* Need to specify a '.' so that the extension */
5281                          /* is not inherited */
5282                          strcat(vms_dst,".");
5283                      }
5284                 }
5285             }
5286         }
5287
5288         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5289         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5290         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5291         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5292
5293         new_file_dsc.dsc$a_pointer = vms_dst;
5294         new_file_dsc.dsc$w_length = strlen(vms_dst);
5295         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5296         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5297
5298         flags = 0;
5299 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5300         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5301 #endif
5302
5303         sts = lib$rename_file(&old_file_dsc,
5304                               &new_file_dsc,
5305                               NULL, NULL,
5306                               &flags,
5307                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5308         if (!$VMS_STATUS_SUCCESS(sts)) {
5309
5310            /* We could have failed because VMS style permissions do not
5311             * permit renames that UNIX will allow.  Just like the hack
5312             * in for kill_file.
5313             */
5314            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5315         }
5316
5317         PerlMem_free(vms_dst);
5318         if (!$VMS_STATUS_SUCCESS(sts)) {
5319             errno = EIO;
5320             return -1;
5321         }
5322         retval = 0;
5323     }
5324
5325     if (vms_unlink_all_versions) {
5326         /* Now get rid of any previous versions of the source file that
5327          * might still exist
5328          */
5329         int i = 0;
5330         dSAVEDERRNO;
5331         SAVE_ERRNO;
5332         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5333                                    S_ISDIR(src_st.st_mode));
5334         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5335              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5336                                        S_ISDIR(src_st.st_mode));
5337              if (src_sts != 0)
5338                  break;
5339              i++;
5340
5341              /* Make sure that we do not loop forever */
5342              if (i > 32767) {
5343                  src_sts = -1;
5344                  break;
5345              }
5346         }
5347         RESTORE_ERRNO;
5348     }
5349
5350     /* We deleted the destination, so must force the error to be EIO */
5351     if ((retval != 0) && (pre_delete != 0))
5352         errno = EIO;
5353
5354     return retval;
5355 }
5356 /*}}}*/
5357
5358
5359 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5360 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5361  * to expand file specification.  Allows for a single default file
5362  * specification and a simple mask of options.  If outbuf is non-NULL,
5363  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5364  * the resultant file specification is placed.  If outbuf is NULL, the
5365  * resultant file specification is placed into a static buffer.
5366  * The third argument, if non-NULL, is taken to be a default file
5367  * specification string.  The fourth argument is unused at present.
5368  * rmesexpand() returns the address of the resultant string if
5369  * successful, and NULL on error.
5370  *
5371  * New functionality for previously unused opts value:
5372  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5373  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5374  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5375  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5376  */
5377 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5378
5379 static char *
5380 int_rmsexpand
5381    (const char *filespec,
5382     char *outbuf,
5383     const char *defspec,
5384     unsigned opts,
5385     int * fs_utf8,
5386     int * dfs_utf8)
5387 {
5388   char * ret_spec;
5389   const char * in_spec;
5390   char * spec_buf;
5391   const char * def_spec;
5392   char * vmsfspec, *vmsdefspec;
5393   char * esa;
5394   char * esal = NULL;
5395   char * outbufl;
5396   struct FAB myfab = cc$rms_fab;
5397   rms_setup_nam(mynam);
5398   STRLEN speclen;
5399   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5400   int sts;
5401
5402   /* temp hack until UTF8 is actually implemented */
5403   if (fs_utf8 != NULL)
5404     *fs_utf8 = 0;
5405
5406   if (!filespec || !*filespec) {
5407     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5408     return NULL;
5409   }
5410
5411   vmsfspec = NULL;
5412   vmsdefspec = NULL;
5413   outbufl = NULL;
5414
5415   in_spec = filespec;
5416   isunix = 0;
5417   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5418       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5419       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5420
5421       /* If this is a UNIX file spec, convert it to VMS */
5422       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5423                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5424                            &e_len, &vs_spec, &vs_len);
5425       if (sts != 0) {
5426           isunix = 1;
5427           char * ret_spec;
5428
5429           vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5430           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5431           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5432           if (ret_spec == NULL) {
5433               PerlMem_free(vmsfspec);
5434               return NULL;
5435           }
5436           in_spec = (const char *)vmsfspec;
5437
5438           /* Unless we are forcing to VMS format, a UNIX input means
5439            * UNIX output, and that requires long names to be used
5440            */
5441           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5442 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5443               opts |= PERL_RMSEXPAND_M_LONG;
5444 #else
5445               NOOP;
5446 #endif
5447           else
5448               isunix = 0;
5449       }
5450
5451   }
5452
5453   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5454   rms_bind_fab_nam(myfab, mynam);
5455
5456   /* Process the default file specification if present */
5457   def_spec = defspec;
5458   if (defspec && *defspec) {
5459     int t_isunix;
5460     t_isunix = is_unix_filespec(defspec);
5461     if (t_isunix) {
5462       vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5463       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5464       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5465
5466       if (ret_spec == NULL) {
5467           /* Clean up and bail */
5468           PerlMem_free(vmsdefspec);
5469           if (vmsfspec != NULL)
5470               PerlMem_free(vmsfspec);
5471               return NULL;
5472           }
5473           def_spec = (const char *)vmsdefspec;
5474       }
5475       rms_set_dna(myfab, mynam,
5476                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5477   }
5478
5479   /* Now we need the expansion buffers */
5480   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5481   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5482 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5483   esal = PerlMem_malloc(VMS_MAXRSS);
5484   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5485 #endif
5486   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5487
5488   /* If a NAML block is used RMS always writes to the long and short
5489    * addresses unless you suppress the short name.
5490    */
5491 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5492   outbufl = PerlMem_malloc(VMS_MAXRSS);
5493   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5494 #endif
5495    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5496
5497 #ifdef NAM$M_NO_SHORT_UPCASE
5498   if (decc_efs_case_preserve)
5499     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5500 #endif
5501
5502    /* We may not want to follow symbolic links */
5503 #ifdef NAML$M_OPEN_SPECIAL
5504   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5505     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5506 #endif
5507
5508   /* First attempt to parse as an existing file */
5509   retsts = sys$parse(&myfab,0,0);
5510   if (!(retsts & STS$K_SUCCESS)) {
5511
5512     /* Could not find the file, try as syntax only if error is not fatal */
5513     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5514     if (retsts == RMS$_DNF ||
5515         retsts == RMS$_DIR ||
5516         retsts == RMS$_DEV ||
5517         retsts == RMS$_PRV) {
5518       retsts = sys$parse(&myfab,0,0);
5519       if (retsts & STS$K_SUCCESS) goto int_expanded;
5520     }
5521
5522      /* Still could not parse the file specification */
5523     /*----------------------------------------------*/
5524     sts = rms_free_search_context(&myfab); /* Free search context */
5525     if (vmsdefspec != NULL)
5526         PerlMem_free(vmsdefspec);
5527     if (vmsfspec != NULL)
5528         PerlMem_free(vmsfspec);
5529     if (outbufl != NULL)
5530         PerlMem_free(outbufl);
5531     PerlMem_free(esa);
5532     if (esal != NULL)
5533         PerlMem_free(esal);
5534     set_vaxc_errno(retsts);
5535     if      (retsts == RMS$_PRV) set_errno(EACCES);
5536     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5537     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5538     else                         set_errno(EVMSERR);
5539     return NULL;
5540   }
5541   retsts = sys$search(&myfab,0,0);
5542   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5543     sts = rms_free_search_context(&myfab); /* Free search context */
5544     if (vmsdefspec != NULL)
5545         PerlMem_free(vmsdefspec);
5546     if (vmsfspec != NULL)
5547         PerlMem_free(vmsfspec);
5548     if (outbufl != NULL)
5549         PerlMem_free(outbufl);
5550     PerlMem_free(esa);
5551     if (esal != NULL)
5552         PerlMem_free(esal);
5553     set_vaxc_errno(retsts);
5554     if      (retsts == RMS$_PRV) set_errno(EACCES);
5555     else                         set_errno(EVMSERR);
5556     return NULL;
5557   }
5558
5559   /* If the input filespec contained any lowercase characters,
5560    * downcase the result for compatibility with Unix-minded code. */
5561 int_expanded:
5562   if (!decc_efs_case_preserve) {
5563     char * tbuf;
5564     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5565       if (islower(*tbuf)) { haslower = 1; break; }
5566   }
5567
5568    /* Is a long or a short name expected */
5569   /*------------------------------------*/
5570   spec_buf = NULL;
5571 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5572   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5573     if (rms_nam_rsll(mynam)) {
5574         spec_buf = outbufl;
5575         speclen = rms_nam_rsll(mynam);
5576     }
5577     else {
5578         spec_buf = esal; /* Not esa */
5579         speclen = rms_nam_esll(mynam);
5580     }
5581   }
5582   else {
5583 #endif
5584     if (rms_nam_rsl(mynam)) {
5585         spec_buf = outbuf;
5586         speclen = rms_nam_rsl(mynam);
5587     }
5588     else {
5589         spec_buf = esa; /* Not esal */
5590         speclen = rms_nam_esl(mynam);
5591     }
5592 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5593   }
5594 #endif
5595   spec_buf[speclen] = '\0';
5596
5597   /* Trim off null fields added by $PARSE
5598    * If type > 1 char, must have been specified in original or default spec
5599    * (not true for version; $SEARCH may have added version of existing file).
5600    */
5601   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5602   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5603     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5604              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5605   }
5606   else {
5607     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5608              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5609   }
5610   if (trimver || trimtype) {
5611     if (defspec && *defspec) {
5612       char *defesal = NULL;
5613       char *defesa = NULL;
5614       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5615       if (defesa != NULL) {
5616         struct FAB deffab = cc$rms_fab;
5617 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5618         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5619         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5620 #endif
5621         rms_setup_nam(defnam);
5622
5623         rms_bind_fab_nam(deffab, defnam);
5624
5625         /* Cast ok */
5626         rms_set_fna
5627             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5628
5629         /* RMS needs the esa/esal as a work area if wildcards are involved */
5630         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5631
5632         rms_clear_nam_nop(defnam);
5633         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5634 #ifdef NAM$M_NO_SHORT_UPCASE
5635         if (decc_efs_case_preserve)
5636           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5637 #endif
5638 #ifdef NAML$M_OPEN_SPECIAL
5639         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5640           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5641 #endif
5642         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5643           if (trimver) {
5644              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5645           }
5646           if (trimtype) {
5647             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5648           }
5649         }
5650         if (defesal != NULL)
5651             PerlMem_free(defesal);
5652         PerlMem_free(defesa);
5653       } else {
5654           _ckvmssts_noperl(SS$_INSFMEM);
5655       }
5656     }
5657     if (trimver) {
5658       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5659         if (*(rms_nam_verl(mynam)) != '\"')
5660           speclen = rms_nam_verl(mynam) - spec_buf;
5661       }
5662       else {
5663         if (*(rms_nam_ver(mynam)) != '\"')
5664           speclen = rms_nam_ver(mynam) - spec_buf;
5665       }
5666     }
5667     if (trimtype) {
5668       /* If we didn't already trim version, copy down */
5669       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5670         if (speclen > rms_nam_verl(mynam) - spec_buf)
5671           memmove
5672            (rms_nam_typel(mynam),
5673             rms_nam_verl(mynam),
5674             speclen - (rms_nam_verl(mynam) - spec_buf));
5675           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5676       }
5677       else {
5678         if (speclen > rms_nam_ver(mynam) - spec_buf)
5679           memmove
5680            (rms_nam_type(mynam),
5681             rms_nam_ver(mynam),
5682             speclen - (rms_nam_ver(mynam) - spec_buf));
5683           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5684       }
5685     }
5686   }
5687
5688    /* Done with these copies of the input files */
5689   /*-------------------------------------------*/
5690   if (vmsfspec != NULL)
5691         PerlMem_free(vmsfspec);
5692   if (vmsdefspec != NULL)
5693         PerlMem_free(vmsdefspec);
5694
5695   /* If we just had a directory spec on input, $PARSE "helpfully"
5696    * adds an empty name and type for us */
5697 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5698   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5699     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5700         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5701         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5702       speclen = rms_nam_namel(mynam) - spec_buf;
5703   }
5704   else
5705 #endif
5706   {
5707     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5708         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5709         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5710       speclen = rms_nam_name(mynam) - spec_buf;
5711   }
5712
5713   /* Posix format specifications must have matching quotes */
5714   if (speclen < (VMS_MAXRSS - 1)) {
5715     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5716       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5717         spec_buf[speclen] = '\"';
5718         speclen++;
5719       }
5720     }
5721   }
5722   spec_buf[speclen] = '\0';
5723   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5724
5725   /* Have we been working with an expanded, but not resultant, spec? */
5726   /* Also, convert back to Unix syntax if necessary. */
5727   {
5728   int rsl;
5729
5730 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5731     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5732       rsl = rms_nam_rsll(mynam);
5733     } else
5734 #endif
5735     {
5736       rsl = rms_nam_rsl(mynam);
5737     }
5738     if (!rsl) {
5739       /* rsl is not present, it means that spec_buf is either */
5740       /* esa or esal, and needs to be copied to outbuf */
5741       /* convert to Unix if desired */
5742       if (isunix) {
5743         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5744       } else {
5745         /* VMS file specs are not in UTF-8 */
5746         if (fs_utf8 != NULL)
5747             *fs_utf8 = 0;
5748         my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5749         ret_spec = outbuf;
5750       }
5751     }
5752     else {
5753       /* Now spec_buf is either outbuf or outbufl */
5754       /* We need the result into outbuf */
5755       if (isunix) {
5756            /* If we need this in UNIX, then we need another buffer */
5757            /* to keep things in order */
5758            char * src;
5759            char * new_src = NULL;
5760            if (spec_buf == outbuf) {
5761                new_src = PerlMem_malloc(VMS_MAXRSS);
5762                my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5763            } else {
5764                src = spec_buf;
5765            }
5766            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5767            if (new_src) {
5768                PerlMem_free(new_src);
5769            }
5770       } else {
5771            /* VMS file specs are not in UTF-8 */
5772            if (fs_utf8 != NULL)
5773                *fs_utf8 = 0;
5774
5775            /* Copy the buffer if needed */
5776            if (outbuf != spec_buf)
5777                my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5778            ret_spec = outbuf;
5779       }
5780     }
5781   }
5782
5783   /* Need to clean up the search context */
5784   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5785   sts = rms_free_search_context(&myfab); /* Free search context */
5786
5787   /* Clean up the extra buffers */
5788   if (esal != NULL)
5789       PerlMem_free(esal);
5790   PerlMem_free(esa);
5791   if (outbufl != NULL)
5792      PerlMem_free(outbufl);
5793
5794   /* Return the result */
5795   return ret_spec;
5796 }
5797
5798 /* Common simple case - Expand an already VMS spec */
5799 static char *
5800 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5801     opts |= PERL_RMSEXPAND_M_VMS_IN;
5802     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5803 }
5804
5805 /* Common simple case - Expand to a VMS spec */
5806 static char *
5807 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5808     opts |= PERL_RMSEXPAND_M_VMS;
5809     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5810 }
5811
5812
5813 /* Entry point used by perl routines */
5814 static char *
5815 mp_do_rmsexpand
5816    (pTHX_ const char *filespec,
5817     char *outbuf,
5818     int ts,
5819     const char *defspec,
5820     unsigned opts,
5821     int * fs_utf8,
5822     int * dfs_utf8)
5823 {
5824     static char __rmsexpand_retbuf[VMS_MAXRSS];
5825     char * expanded, *ret_spec, *ret_buf;
5826
5827     expanded = NULL;
5828     ret_buf = outbuf;
5829     if (ret_buf == NULL) {
5830         if (ts) {
5831             Newx(expanded, VMS_MAXRSS, char);
5832             if (expanded == NULL)
5833                 _ckvmssts(SS$_INSFMEM);
5834             ret_buf = expanded;
5835         } else {
5836             ret_buf = __rmsexpand_retbuf;
5837         }
5838     }
5839
5840
5841     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5842                              opts, fs_utf8,  dfs_utf8);
5843
5844     if (ret_spec == NULL) {
5845        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5846        if (expanded)
5847            Safefree(expanded);
5848     }
5849
5850     return ret_spec;
5851 }
5852 /*}}}*/
5853 /* External entry points */
5854 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5855 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5856 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5857 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5858 char *Perl_rmsexpand_utf8
5859   (pTHX_ const char *spec, char *buf, const char *def,
5860    unsigned opt, int * fs_utf8, int * dfs_utf8)
5861 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5862 char *Perl_rmsexpand_utf8_ts
5863   (pTHX_ const char *spec, char *buf, const char *def,
5864    unsigned opt, int * fs_utf8, int * dfs_utf8)
5865 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5866
5867
5868 /*
5869 ** The following routines are provided to make life easier when
5870 ** converting among VMS-style and Unix-style directory specifications.
5871 ** All will take input specifications in either VMS or Unix syntax. On
5872 ** failure, all return NULL.  If successful, the routines listed below
5873 ** return a pointer to a buffer containing the appropriately
5874 ** reformatted spec (and, therefore, subsequent calls to that routine
5875 ** will clobber the result), while the routines of the same names with
5876 ** a _ts suffix appended will return a pointer to a mallocd string
5877 ** containing the appropriately reformatted spec.
5878 ** In all cases, only explicit syntax is altered; no check is made that
5879 ** the resulting string is valid or that the directory in question
5880 ** actually exists.
5881 **
5882 **   fileify_dirspec() - convert a directory spec into the name of the
5883 **     directory file (i.e. what you can stat() to see if it's a dir).
5884 **     The style (VMS or Unix) of the result is the same as the style
5885 **     of the parameter passed in.
5886 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5887 **     what you prepend to a filename to indicate what directory it's in).
5888 **     The style (VMS or Unix) of the result is the same as the style
5889 **     of the parameter passed in.
5890 **   tounixpath() - convert a directory spec into a Unix-style path.
5891 **   tovmspath() - convert a directory spec into a VMS-style path.
5892 **   tounixspec() - convert any file spec into a Unix-style file spec.
5893 **   tovmsspec() - convert any file spec into a VMS-style spec.
5894 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5895 **
5896 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5897 ** Permission is given to distribute this code as part of the Perl
5898 ** standard distribution under the terms of the GNU General Public
5899 ** License or the Perl Artistic License.  Copies of each may be
5900 ** found in the Perl standard distribution.
5901  */
5902
5903 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5904 static char *
5905 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5906 {
5907     unsigned long int dirlen, retlen, hasfilename = 0;
5908     char *cp1, *cp2, *lastdir;
5909     char *trndir, *vmsdir;
5910     unsigned short int trnlnm_iter_count;
5911     int is_vms = 0;
5912     int is_unix = 0;
5913     int sts;
5914     if (utf8_fl != NULL)
5915         *utf8_fl = 0;
5916
5917     if (!dir || !*dir) {
5918       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5919     }
5920     dirlen = strlen(dir);
5921     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5922     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5923       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5924         dir = "/sys$disk";
5925         dirlen = 9;
5926       }
5927       else
5928         dirlen = 1;
5929     }
5930     if (dirlen > (VMS_MAXRSS - 1)) {
5931       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5932       return NULL;
5933     }
5934     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5935     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5936     if (!strpbrk(dir+1,"/]>:")  &&
5937         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5938       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5939       trnlnm_iter_count = 0;
5940       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
5941         trnlnm_iter_count++;
5942         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5943       }
5944       dirlen = strlen(trndir);
5945     }
5946     else {
5947       memcpy(trndir, dir, dirlen);
5948       trndir[dirlen] = '\0';
5949     }
5950
5951     /* At this point we are done with *dir and use *trndir which is a
5952      * copy that can be modified.  *dir must not be modified.
5953      */
5954
5955     /* If we were handed a rooted logical name or spec, treat it like a
5956      * simple directory, so that
5957      *    $ Define myroot dev:[dir.]
5958      *    ... do_fileify_dirspec("myroot",buf,1) ...
5959      * does something useful.
5960      */
5961     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5962       trndir[--dirlen] = '\0';
5963       trndir[dirlen-1] = ']';
5964     }
5965     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5966       trndir[--dirlen] = '\0';
5967       trndir[dirlen-1] = '>';
5968     }
5969
5970     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5971       /* If we've got an explicit filename, we can just shuffle the string. */
5972       if (*(cp1+1)) hasfilename = 1;
5973       /* Similarly, we can just back up a level if we've got multiple levels
5974          of explicit directories in a VMS spec which ends with directories. */
5975       else {
5976         for (cp2 = cp1; cp2 > trndir; cp2--) {
5977           if (*cp2 == '.') {
5978             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5979 /* fix-me, can not scan EFS file specs backward like this */
5980               *cp2 = *cp1; *cp1 = '\0';
5981               hasfilename = 1;
5982               break;
5983             }
5984           }
5985           if (*cp2 == '[' || *cp2 == '<') break;
5986         }
5987       }
5988     }
5989
5990     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5991     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5992     cp1 = strpbrk(trndir,"]:>");
5993     if (hasfilename || !cp1) { /* filename present or not VMS */
5994
5995       if (decc_efs_charset && !cp1) {
5996
5997           /* EFS handling for UNIX mode */
5998
5999           /* Just remove the trailing '/' and we should be done */
6000           STRLEN trndir_len;
6001           trndir_len = strlen(trndir);
6002
6003           if (trndir_len > 1) {
6004               trndir_len--;
6005               if (trndir[trndir_len] == '/') {
6006                   trndir[trndir_len] = '\0';
6007               }
6008           }
6009           my_strlcpy(buf, trndir, VMS_MAXRSS);
6010           PerlMem_free(trndir);
6011           PerlMem_free(vmsdir);
6012           return buf;
6013       }
6014
6015       /* For non-EFS mode, this is left for backwards compatibility */
6016       /* For EFS mode, this is only done for VMS format filespecs as */
6017       /* Perl programs generally have problems when a UNIX format spec */
6018       /* returns a VMS format spec */
6019       if (trndir[0] == '.') {
6020         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6021           PerlMem_free(trndir);
6022           PerlMem_free(vmsdir);
6023           return int_fileify_dirspec("[]", buf, NULL);
6024         }
6025         else if (trndir[1] == '.' &&
6026                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6027           PerlMem_free(trndir);
6028           PerlMem_free(vmsdir);
6029           return int_fileify_dirspec("[-]", buf, NULL);
6030         }
6031       }
6032       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6033         dirlen -= 1;                 /* to last element */
6034         lastdir = strrchr(trndir,'/');
6035       }
6036       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6037         /* If we have "/." or "/..", VMSify it and let the VMS code
6038          * below expand it, rather than repeating the code to handle
6039          * relative components of a filespec here */
6040         do {
6041           if (*(cp1+2) == '.') cp1++;
6042           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6043             char * ret_chr;
6044             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6045                 PerlMem_free(trndir);
6046                 PerlMem_free(vmsdir);
6047                 return NULL;
6048             }
6049             if (strchr(vmsdir,'/') != NULL) {
6050               /* If int_tovmsspec() returned it, it must have VMS syntax
6051                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6052                * the time to check this here only so we avoid a recursion
6053                * loop; otherwise, gigo.
6054                */
6055               PerlMem_free(trndir);
6056               PerlMem_free(vmsdir);
6057               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
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           cp1++;
6071         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6072         lastdir = strrchr(trndir,'/');
6073       }
6074       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6075         char * ret_chr;
6076         /* Ditto for specs that end in an MFD -- let the VMS code
6077          * figure out whether it's a real device or a rooted logical. */
6078
6079         /* This should not happen any more.  Allowing the fake /000000
6080          * in a UNIX pathname causes all sorts of problems when trying
6081          * to run in UNIX emulation.  So the VMS to UNIX conversions
6082          * now remove the fake /000000 directories.
6083          */
6084
6085         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6086         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6087             PerlMem_free(trndir);
6088             PerlMem_free(vmsdir);
6089             return NULL;
6090         }
6091         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6092             PerlMem_free(trndir);
6093             PerlMem_free(vmsdir);
6094             return NULL;
6095         }
6096         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6097         PerlMem_free(trndir);
6098         PerlMem_free(vmsdir);
6099         return ret_chr;
6100       }
6101       else {
6102
6103         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6104              !(lastdir = cp1 = strrchr(trndir,']')) &&
6105              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6106
6107         cp2 = strrchr(cp1,'.');
6108         if (cp2) {
6109             int e_len, vs_len = 0;
6110             int is_dir = 0;
6111             char * cp3;
6112             cp3 = strchr(cp2,';');
6113             e_len = strlen(cp2);
6114             if (cp3) {
6115                 vs_len = strlen(cp3);
6116                 e_len = e_len - vs_len;
6117             }
6118             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6119             if (!is_dir) {
6120                 if (!decc_efs_charset) {
6121                     /* If this is not EFS, then not a directory */
6122                     PerlMem_free(trndir);
6123                     PerlMem_free(vmsdir);
6124                     set_errno(ENOTDIR);
6125                     set_vaxc_errno(RMS$_DIR);
6126                     return NULL;
6127                 }
6128             } else {
6129                 /* Ok, here we have an issue, technically if a .dir shows */
6130                 /* from inside a directory, then we should treat it as */
6131                 /* xxx^.dir.dir.  But we do not have that context at this */
6132                 /* point unless this is totally restructured, so we remove */
6133                 /* The .dir for now, and fix this better later */
6134                 dirlen = cp2 - trndir;
6135             }
6136         }
6137
6138       }
6139
6140       retlen = dirlen + 6;
6141       memcpy(buf, trndir, dirlen);
6142       buf[dirlen] = '\0';
6143
6144       /* We've picked up everything up to the directory file name.
6145          Now just add the type and version, and we're set. */
6146
6147       /* We should only add type for VMS syntax, but historically Perl
6148          has added it for UNIX style also */
6149
6150       /* Fix me - we should not be using the same routine for VMS and
6151          UNIX format files.  Things are too tangled so we need to lookup
6152          what syntax the output is */
6153
6154       is_unix = 0;
6155       is_vms = 0;
6156       lastdir = strrchr(trndir,'/');
6157       if (lastdir) {
6158           is_unix = 1;
6159       } else {
6160           lastdir = strpbrk(trndir,"]:>");
6161           if (lastdir) {
6162               is_vms = 1;
6163           }
6164       }
6165
6166       if ((is_vms == 0) && (is_unix == 0)) {
6167           /* We still do not  know? */
6168           is_unix = decc_filename_unix_report;
6169           if (is_unix == 0)
6170               is_vms = 1;
6171       }
6172
6173       if ((is_unix && !decc_efs_charset) || is_vms) {
6174
6175            /* It is a bug to add a .dir to a UNIX format directory spec */
6176            /* However Perl on VMS may have programs that expect this so */
6177            /* If not using EFS character specifications allow it. */
6178
6179            if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6180                /* Traditionally Perl expects filenames in lower case */
6181                strcat(buf, ".dir");
6182            } else {
6183                /* VMS expects the .DIR to be in upper case */
6184                strcat(buf, ".DIR");
6185            }
6186
6187            /* It is also a bug to put a VMS format version on a UNIX file */
6188            /* specification.  Perl self tests are looking for this */
6189            if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6190                strcat(buf, ";1");
6191       }
6192       PerlMem_free(trndir);
6193       PerlMem_free(vmsdir);
6194       return buf;
6195     }
6196     else {  /* VMS-style directory spec */
6197
6198       char *esa, *esal, term, *cp;
6199       char *my_esa;
6200       int my_esa_len;
6201       unsigned long int cmplen, haslower = 0;
6202       struct FAB dirfab = cc$rms_fab;
6203       rms_setup_nam(savnam);
6204       rms_setup_nam(dirnam);
6205
6206       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6207       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6208       esal = NULL;
6209 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6210       esal = PerlMem_malloc(VMS_MAXRSS);
6211       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6212 #endif
6213       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6214       rms_bind_fab_nam(dirfab, dirnam);
6215       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6216       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6217 #ifdef NAM$M_NO_SHORT_UPCASE
6218       if (decc_efs_case_preserve)
6219         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6220 #endif
6221
6222       for (cp = trndir; *cp; cp++)
6223         if (islower(*cp)) { haslower = 1; break; }
6224       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6225         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6226             (dirfab.fab$l_sts == RMS$_DNF) ||
6227             (dirfab.fab$l_sts == RMS$_PRV)) {
6228             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6229             sts = sys$parse(&dirfab);
6230         }
6231         if (!sts) {
6232           PerlMem_free(esa);
6233           if (esal != NULL)
6234               PerlMem_free(esal);
6235           PerlMem_free(trndir);
6236           PerlMem_free(vmsdir);
6237           set_errno(EVMSERR);
6238           set_vaxc_errno(dirfab.fab$l_sts);
6239           return NULL;
6240         }
6241       }
6242       else {
6243         savnam = dirnam;
6244         /* Does the file really exist? */
6245         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6246           /* Yes; fake the fnb bits so we'll check type below */
6247           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6248         }
6249         else { /* No; just work with potential name */
6250           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6251           else {
6252             int fab_sts;
6253             fab_sts = dirfab.fab$l_sts;
6254             sts = rms_free_search_context(&dirfab);
6255             PerlMem_free(esa);
6256             if (esal != NULL)
6257                 PerlMem_free(esal);
6258             PerlMem_free(trndir);
6259             PerlMem_free(vmsdir);
6260             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6261             return NULL;
6262           }
6263         }
6264       }
6265
6266       /* Make sure we are using the right buffer */
6267 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6268       if (esal != NULL) {
6269         my_esa = esal;
6270         my_esa_len = rms_nam_esll(dirnam);
6271       } else {
6272 #endif
6273         my_esa = esa;
6274         my_esa_len = rms_nam_esl(dirnam);
6275 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6276       }
6277 #endif
6278       my_esa[my_esa_len] = '\0';
6279       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6280         cp1 = strchr(my_esa,']');
6281         if (!cp1) cp1 = strchr(my_esa,'>');
6282         if (cp1) {  /* Should always be true */
6283           my_esa_len -= cp1 - my_esa - 1;
6284           memmove(my_esa, cp1 + 1, my_esa_len);
6285         }
6286       }
6287       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6288         /* Yep; check version while we're at it, if it's there. */
6289         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6290         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6291           /* Something other than .DIR[;1].  Bzzt. */
6292           sts = rms_free_search_context(&dirfab);
6293           PerlMem_free(esa);
6294           if (esal != NULL)
6295              PerlMem_free(esal);
6296           PerlMem_free(trndir);
6297           PerlMem_free(vmsdir);
6298           set_errno(ENOTDIR);
6299           set_vaxc_errno(RMS$_DIR);
6300           return NULL;
6301         }
6302       }
6303
6304       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6305         /* They provided at least the name; we added the type, if necessary, */
6306         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6307         sts = rms_free_search_context(&dirfab);
6308         PerlMem_free(trndir);
6309         PerlMem_free(esa);
6310         if (esal != NULL)
6311             PerlMem_free(esal);
6312         PerlMem_free(vmsdir);
6313         return buf;
6314       }
6315       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6316         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6317         *cp1 = '\0';
6318         my_esa_len -= 9;
6319       }
6320       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6321       if (cp1 == NULL) { /* should never happen */
6322         sts = rms_free_search_context(&dirfab);
6323         PerlMem_free(trndir);
6324         PerlMem_free(esa);
6325         if (esal != NULL)
6326             PerlMem_free(esal);
6327         PerlMem_free(vmsdir);
6328         return NULL;
6329       }
6330       term = *cp1;
6331       *cp1 = '\0';
6332       retlen = strlen(my_esa);
6333       cp1 = strrchr(my_esa,'.');
6334       /* ODS-5 directory specifications can have extra "." in them. */
6335       /* Fix-me, can not scan EFS file specifications backwards */
6336       while (cp1 != NULL) {
6337         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6338           break;
6339         else {
6340            cp1--;
6341            while ((cp1 > my_esa) && (*cp1 != '.'))
6342              cp1--;
6343         }
6344         if (cp1 == my_esa)
6345           cp1 = NULL;
6346       }
6347
6348       if ((cp1) != NULL) {
6349         /* There's more than one directory in the path.  Just roll back. */
6350         *cp1 = term;
6351         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6352       }
6353       else {
6354         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6355           /* Go back and expand rooted logical name */
6356           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6357 #ifdef NAM$M_NO_SHORT_UPCASE
6358           if (decc_efs_case_preserve)
6359             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6360 #endif
6361           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6362             sts = rms_free_search_context(&dirfab);
6363             PerlMem_free(esa);
6364             if (esal != NULL)
6365                 PerlMem_free(esal);
6366             PerlMem_free(trndir);
6367             PerlMem_free(vmsdir);
6368             set_errno(EVMSERR);
6369             set_vaxc_errno(dirfab.fab$l_sts);
6370             return NULL;
6371           }
6372
6373           /* This changes the length of the string of course */
6374           if (esal != NULL) {
6375               my_esa_len = rms_nam_esll(dirnam);
6376           } else {
6377               my_esa_len = rms_nam_esl(dirnam);
6378           }
6379
6380           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6381           cp1 = strstr(my_esa,"][");
6382           if (!cp1) cp1 = strstr(my_esa,"]<");
6383           dirlen = cp1 - my_esa;
6384           memcpy(buf, my_esa, dirlen);
6385           if (!strncmp(cp1+2,"000000]",7)) {
6386             buf[dirlen-1] = '\0';
6387             /* fix-me Not full ODS-5, just extra dots in directories for now */
6388             cp1 = buf + dirlen - 1;
6389             while (cp1 > buf)
6390             {
6391               if (*cp1 == '[')
6392                 break;
6393               if (*cp1 == '.') {
6394                 if (*(cp1-1) != '^')
6395                   break;
6396               }
6397               cp1--;
6398             }
6399             if (*cp1 == '.') *cp1 = ']';
6400             else {
6401               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6402               memmove(cp1+1,"000000]",7);
6403             }
6404           }
6405           else {
6406             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6407             buf[retlen] = '\0';
6408             /* Convert last '.' to ']' */
6409             cp1 = buf+retlen-1;
6410             while (*cp != '[') {
6411               cp1--;
6412               if (*cp1 == '.') {
6413                 /* Do not trip on extra dots in ODS-5 directories */
6414                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6415                 break;
6416               }
6417             }
6418             if (*cp1 == '.') *cp1 = ']';
6419             else {
6420               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6421               memmove(cp1+1,"000000]",7);
6422             }
6423           }
6424         }
6425         else {  /* This is a top-level dir.  Add the MFD to the path. */
6426           cp1 = my_esa;
6427           cp2 = buf;
6428           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6429           strcpy(cp2,":[000000]");
6430           cp1 += 2;
6431           strcpy(cp2+9,cp1);
6432         }
6433       }
6434       sts = rms_free_search_context(&dirfab);
6435       /* We've set up the string up through the filename.  Add the
6436          type and version, and we're done. */
6437       strcat(buf,".DIR;1");
6438
6439       /* $PARSE may have upcased filespec, so convert output to lower
6440        * case if input contained any lowercase characters. */
6441       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6442       PerlMem_free(trndir);
6443       PerlMem_free(esa);
6444       if (esal != NULL)
6445         PerlMem_free(esal);
6446       PerlMem_free(vmsdir);
6447       return buf;
6448     }
6449 }  /* end of int_fileify_dirspec() */
6450
6451
6452 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6453 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6454 {
6455     static char __fileify_retbuf[VMS_MAXRSS];
6456     char * fileified, *ret_spec, *ret_buf;
6457
6458     fileified = NULL;
6459     ret_buf = buf;
6460     if (ret_buf == NULL) {
6461         if (ts) {
6462             Newx(fileified, VMS_MAXRSS, char);
6463             if (fileified == NULL)
6464                 _ckvmssts(SS$_INSFMEM);
6465             ret_buf = fileified;
6466         } else {
6467             ret_buf = __fileify_retbuf;
6468         }
6469     }
6470
6471     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6472
6473     if (ret_spec == NULL) {
6474        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6475        if (fileified)
6476            Safefree(fileified);
6477     }
6478
6479     return ret_spec;
6480 }  /* end of do_fileify_dirspec() */
6481 /*}}}*/
6482
6483 /* External entry points */
6484 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6485 { return do_fileify_dirspec(dir,buf,0,NULL); }
6486 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6487 { return do_fileify_dirspec(dir,buf,1,NULL); }
6488 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6489 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6490 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6491 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6492
6493 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6494     char * v_spec, int v_len, char * r_spec, int r_len,
6495     char * d_spec, int d_len, char * n_spec, int n_len,
6496     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6497
6498     /* VMS specification - Try to do this the simple way */
6499     if ((v_len + r_len > 0) || (d_len > 0)) {
6500         int is_dir;
6501
6502         /* No name or extension component, already a directory */
6503         if ((n_len + e_len + vs_len) == 0) {
6504             strcpy(buf, dir);
6505             return buf;
6506         }
6507
6508         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6509         /* This results from catfile() being used instead of catdir() */
6510         /* So even though it should not work, we need to allow it */
6511
6512         /* If this is .DIR;1 then do a simple conversion */
6513         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6514         if (is_dir || (e_len == 0) && (d_len > 0)) {
6515              int len;
6516              len = v_len + r_len + d_len - 1;
6517              char dclose = d_spec[d_len - 1];
6518              memcpy(buf, dir, len);
6519              buf[len] = '.';
6520              len++;
6521              memcpy(&buf[len], n_spec, n_len);
6522              len += n_len;
6523              buf[len] = dclose;
6524              buf[len + 1] = '\0';
6525              return buf;
6526         }
6527
6528 #ifdef HAS_SYMLINK
6529         else if (d_len > 0) {
6530             /* In the olden days, a directory needed to have a .DIR */
6531             /* extension to be a valid directory, but now it could  */
6532             /* be a symbolic link */
6533             int len;
6534             len = v_len + r_len + d_len - 1;
6535             char dclose = d_spec[d_len - 1];
6536             memcpy(buf, dir, len);
6537             buf[len] = '.';
6538             len++;
6539             memcpy(&buf[len], n_spec, n_len);
6540             len += n_len;
6541             if (e_len > 0) {
6542                 if (decc_efs_charset) {
6543                     buf[len] = '^';
6544                     len++;
6545                     memcpy(&buf[len], e_spec, e_len);
6546                     len += e_len;
6547                 } else {
6548                     set_vaxc_errno(RMS$_DIR);
6549                     set_errno(ENOTDIR);
6550                     return NULL;
6551                 }
6552             }
6553             buf[len] = dclose;
6554             buf[len + 1] = '\0';
6555             return buf;
6556         }
6557 #else
6558         else {
6559             set_vaxc_errno(RMS$_DIR);
6560             set_errno(ENOTDIR);
6561             return NULL;
6562         }
6563 #endif
6564     }
6565     set_vaxc_errno(RMS$_DIR);
6566     set_errno(ENOTDIR);
6567     return NULL;
6568 }
6569
6570
6571 /* Internal routine to make sure or convert a directory to be in a */
6572 /* path specification.  No utf8 flag because it is not changed or used */
6573 static char *int_pathify_dirspec(const char *dir, char *buf)
6574 {
6575     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6576     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6577     char * exp_spec, *ret_spec;
6578     char * trndir;
6579     unsigned short int trnlnm_iter_count;
6580     STRLEN trnlen;
6581     int need_to_lower;
6582
6583     if (vms_debug_fileify) {
6584         if (dir == NULL)
6585             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6586         else
6587             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6588     }
6589
6590     /* We may need to lower case the result if we translated  */
6591     /* a logical name or got the current working directory */
6592     need_to_lower = 0;
6593
6594     if (!dir || !*dir) {
6595       set_errno(EINVAL);
6596       set_vaxc_errno(SS$_BADPARAM);
6597       return NULL;
6598     }
6599
6600     trndir = PerlMem_malloc(VMS_MAXRSS);
6601     if (trndir == NULL)
6602         _ckvmssts_noperl(SS$_INSFMEM);
6603
6604     /* If no directory specified use the current default */
6605     if (*dir)
6606         my_strlcpy(trndir, dir, VMS_MAXRSS);
6607     else {
6608         getcwd(trndir, VMS_MAXRSS - 1);
6609         need_to_lower = 1;
6610     }
6611
6612     /* now deal with bare names that could be logical names */
6613     trnlnm_iter_count = 0;
6614     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6615            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6616         trnlnm_iter_count++;
6617         need_to_lower = 1;
6618         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6619             break;
6620         trnlen = strlen(trndir);
6621
6622         /* Trap simple rooted lnms, and return lnm:[000000] */
6623         if (!strcmp(trndir+trnlen-2,".]")) {
6624             my_strlcpy(buf, dir, VMS_MAXRSS);
6625             strcat(buf, ":[000000]");
6626             PerlMem_free(trndir);
6627
6628             if (vms_debug_fileify) {
6629                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6630             }
6631             return buf;
6632         }
6633     }
6634
6635     /* At this point we do not work with *dir, but the copy in  *trndir */
6636
6637     if (need_to_lower && !decc_efs_case_preserve) {
6638         /* Legacy mode, lower case the returned value */
6639         __mystrtolower(trndir);
6640     }
6641
6642
6643     /* Some special cases, '..', '.' */
6644     sts = 0;
6645     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6646        /* Force UNIX filespec */
6647        sts = 1;
6648
6649     } else {
6650         /* Is this Unix or VMS format? */
6651         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6652                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6653                              &e_len, &vs_spec, &vs_len);
6654         if (sts == 0) {
6655
6656             /* Just a filename? */
6657             if ((v_len + r_len + d_len) == 0) {
6658
6659                 /* Now we have a problem, this could be Unix or VMS */
6660                 /* We have to guess.  .DIR usually means VMS */
6661
6662                 /* In UNIX report mode, the .DIR extension is removed */
6663                 /* if one shows up, it is for a non-directory or a directory */
6664                 /* in EFS charset mode */
6665
6666                 /* So if we are in Unix report mode, assume that this */
6667                 /* is a relative Unix directory specification */
6668
6669                 sts = 1;
6670                 if (!decc_filename_unix_report && decc_efs_charset) {
6671                     int is_dir;
6672                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6673
6674                     if (is_dir) {
6675                         /* Traditional mode, assume .DIR is directory */
6676                         buf[0] = '[';
6677                         buf[1] = '.';
6678                         memcpy(&buf[2], n_spec, n_len);
6679                         buf[n_len + 2] = ']';
6680                         buf[n_len + 3] = '\0';
6681                         PerlMem_free(trndir);
6682                         if (vms_debug_fileify) {
6683                             fprintf(stderr,
6684                                     "int_pathify_dirspec: buf = %s\n",
6685                                     buf);
6686                         }
6687                         return buf;
6688                     }
6689                 }
6690             }
6691         }
6692     }
6693     if (sts == 0) {
6694         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6695             v_spec, v_len, r_spec, r_len,
6696             d_spec, d_len, n_spec, n_len,
6697             e_spec, e_len, vs_spec, vs_len);
6698
6699         if (ret_spec != NULL) {
6700             PerlMem_free(trndir);
6701             if (vms_debug_fileify) {
6702                 fprintf(stderr,
6703                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6704             }
6705             return ret_spec;
6706         }
6707
6708         /* Simple way did not work, which means that a logical name */
6709         /* was present for the directory specification.             */
6710         /* Need to use an rmsexpand variant to decode it completely */
6711         exp_spec = PerlMem_malloc(VMS_MAXRSS);
6712         if (exp_spec == NULL)
6713             _ckvmssts_noperl(SS$_INSFMEM);
6714
6715         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6716         if (ret_spec != NULL) {
6717             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6718                                  &r_spec, &r_len, &d_spec, &d_len,
6719                                  &n_spec, &n_len, &e_spec,
6720                                  &e_len, &vs_spec, &vs_len);
6721             if (sts == 0) {
6722                 ret_spec = int_pathify_dirspec_simple(
6723                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6724                     d_spec, d_len, n_spec, n_len,
6725                     e_spec, e_len, vs_spec, vs_len);
6726
6727                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6728                     /* Legacy mode, lower case the returned value */
6729                     __mystrtolower(ret_spec);
6730                 }
6731             } else {
6732                 set_vaxc_errno(RMS$_DIR);
6733                 set_errno(ENOTDIR);
6734                 ret_spec = NULL;
6735             }
6736         }
6737         PerlMem_free(exp_spec);
6738         PerlMem_free(trndir);
6739         if (vms_debug_fileify) {
6740             if (ret_spec == NULL)
6741                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6742             else
6743                 fprintf(stderr,
6744                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6745         }
6746         return ret_spec;
6747
6748     } else {
6749         /* Unix specification, Could be trivial conversion */
6750         STRLEN dir_len;
6751         dir_len = strlen(trndir);
6752
6753         /* If the extended file character set is in effect */
6754         /* then pathify is simple */
6755
6756         if (!decc_efs_charset) {
6757             /* Have to deal with trailing '.dir' or extra '.' */
6758             /* that should not be there in legacy mode, but is */
6759
6760             char * lastdot;
6761             char * lastslash;
6762             int is_dir;
6763
6764             lastslash = strrchr(trndir, '/');
6765             if (lastslash == NULL)
6766                 lastslash = trndir;
6767             else
6768                 lastslash++;
6769
6770             lastdot = NULL;
6771
6772             /* '..' or '.' are valid directory components */
6773             is_dir = 0;
6774             if (lastslash[0] == '.') {
6775                 if (lastslash[1] == '\0') {
6776                    is_dir = 1;
6777                 } else if (lastslash[1] == '.') {
6778                     if (lastslash[2] == '\0') {
6779                         is_dir = 1;
6780                     } else {
6781                         /* And finally allow '...' */
6782                         if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6783                             is_dir = 1;
6784                         }
6785                     }
6786                 }
6787             }
6788
6789             if (!is_dir) {
6790                lastdot = strrchr(lastslash, '.');
6791             }
6792             if (lastdot != NULL) {
6793                 STRLEN e_len;
6794
6795                 /* '.dir' is discarded, and any other '.' is invalid */
6796                 e_len = strlen(lastdot);
6797
6798                 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6799
6800                 if (is_dir) {
6801                     dir_len = dir_len - 4;
6802
6803                 }
6804             }
6805         }
6806
6807         my_strlcpy(buf, trndir, VMS_MAXRSS);
6808         if (buf[dir_len - 1] != '/') {
6809             buf[dir_len] = '/';
6810             buf[dir_len + 1] = '\0';
6811         }
6812
6813         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6814         if (!decc_efs_charset) {
6815              int dir_start = 0;
6816              char * str = buf;
6817              if (str[0] == '.') {
6818                  char * dots = str;
6819                  int cnt = 1;
6820                  while ((dots[cnt] == '.') && (cnt < 3))
6821                      cnt++;
6822                  if (cnt <= 3) {
6823                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6824                          dir_start = 1;
6825                          str += cnt;
6826                      }
6827                  }
6828              }
6829              for (; *str; ++str) {
6830                  while (*str == '/') {
6831                      dir_start = 1;
6832                      *str++;
6833                  }
6834                  if (dir_start) {
6835
6836                      /* Have to skip up to three dots which could be */
6837                      /* directories, 3 dots being a VMS extension for Perl */
6838                      char * dots = str;
6839                      int cnt = 0;
6840                      while ((dots[cnt] == '.') && (cnt < 3)) {
6841                          cnt++;
6842                      }
6843                      if (dots[cnt] == '\0')
6844                          break;
6845                      if ((cnt > 1) && (dots[cnt] != '/')) {
6846                          dir_start = 0;
6847                      } else {
6848                          str += cnt;
6849                      }
6850
6851                      /* too many dots? */
6852                      if ((cnt == 0) || (cnt > 3)) {
6853                          dir_start = 0;
6854                      }
6855                  }
6856                  if (!dir_start && (*str == '.')) {
6857                      *str = '_';
6858                  }
6859              }
6860         }
6861         PerlMem_free(trndir);
6862         ret_spec = buf;
6863         if (vms_debug_fileify) {
6864             if (ret_spec == NULL)
6865                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6866             else
6867                 fprintf(stderr,
6868                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6869         }
6870         return ret_spec;
6871     }
6872 }
6873
6874 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6875 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6876 {
6877     static char __pathify_retbuf[VMS_MAXRSS];
6878     char * pathified, *ret_spec, *ret_buf;
6879
6880     pathified = NULL;
6881     ret_buf = buf;
6882     if (ret_buf == NULL) {
6883         if (ts) {
6884             Newx(pathified, VMS_MAXRSS, char);
6885             if (pathified == NULL)
6886                 _ckvmssts(SS$_INSFMEM);
6887             ret_buf = pathified;
6888         } else {
6889             ret_buf = __pathify_retbuf;
6890         }
6891     }
6892
6893     ret_spec = int_pathify_dirspec(dir, ret_buf);
6894
6895     if (ret_spec == NULL) {
6896        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6897        if (pathified)
6898            Safefree(pathified);
6899     }
6900
6901     return ret_spec;
6902
6903 }  /* end of do_pathify_dirspec() */
6904
6905
6906 /* External entry points */
6907 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6908 { return do_pathify_dirspec(dir,buf,0,NULL); }
6909 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6910 { return do_pathify_dirspec(dir,buf,1,NULL); }
6911 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6912 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6913 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6914 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6915
6916 /* Internal tounixspec routine that does not use a thread context */
6917 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6918 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6919 {
6920   char *dirend, *cp1, *cp3, *tmp;
6921   const char *cp2;
6922   int dirlen;
6923   unsigned short int trnlnm_iter_count;
6924   int cmp_rslt;
6925   if (utf8_fl != NULL)
6926     *utf8_fl = 0;
6927
6928   if (vms_debug_fileify) {
6929       if (spec == NULL)
6930           fprintf(stderr, "int_tounixspec: spec = NULL\n");
6931       else
6932           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6933   }
6934
6935
6936   if (spec == NULL) {
6937       set_errno(EINVAL);
6938       set_vaxc_errno(SS$_BADPARAM);
6939       return NULL;
6940   }
6941   if (strlen(spec) > (VMS_MAXRSS-1)) {
6942       set_errno(E2BIG);
6943       set_vaxc_errno(SS$_BUFFEROVF);
6944       return NULL;
6945   }
6946
6947   /* New VMS specific format needs translation
6948    * glob passes filenames with trailing '\n' and expects this preserved.
6949    */
6950   if (decc_posix_compliant_pathnames) {
6951     if (strncmp(spec, "\"^UP^", 5) == 0) {
6952       char * uspec;
6953       char *tunix;
6954       int tunix_len;
6955       int nl_flag;
6956
6957       tunix = PerlMem_malloc(VMS_MAXRSS);
6958       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6959       tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
6960       nl_flag = 0;
6961       if (tunix[tunix_len - 1] == '\n') {
6962         tunix[tunix_len - 1] = '\"';
6963         tunix[tunix_len] = '\0';
6964         tunix_len--;
6965         nl_flag = 1;
6966       }
6967       uspec = decc$translate_vms(tunix);
6968       PerlMem_free(tunix);
6969       if ((int)uspec > 0) {
6970         my_strlcpy(rslt, uspec, VMS_MAXRSS);
6971         if (nl_flag) {
6972           strcat(rslt,"\n");
6973         }
6974         else {
6975           /* If we can not translate it, makemaker wants as-is */
6976           my_strlcpy(rslt, spec, VMS_MAXRSS);
6977         }
6978         return rslt;
6979       }
6980     }
6981   }
6982
6983   cmp_rslt = 0; /* Presume VMS */
6984   cp1 = strchr(spec, '/');
6985   if (cp1 == NULL)
6986     cmp_rslt = 0;
6987
6988     /* Look for EFS ^/ */
6989     if (decc_efs_charset) {
6990       while (cp1 != NULL) {
6991         cp2 = cp1 - 1;
6992         if (*cp2 != '^') {
6993           /* Found illegal VMS, assume UNIX */
6994           cmp_rslt = 1;
6995           break;
6996         }
6997       cp1++;
6998       cp1 = strchr(cp1, '/');
6999     }
7000   }
7001
7002   /* Look for "." and ".." */
7003   if (decc_filename_unix_report) {
7004     if (spec[0] == '.') {
7005       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7006         cmp_rslt = 1;
7007       }
7008       else {
7009         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7010           cmp_rslt = 1;
7011         }
7012       }
7013     }
7014   }
7015   /* This is already UNIX or at least nothing VMS understands */
7016   if (cmp_rslt) {
7017     my_strlcpy(rslt, spec, VMS_MAXRSS);
7018     if (vms_debug_fileify) {
7019         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7020     }
7021     return rslt;
7022   }
7023
7024   cp1 = rslt;
7025   cp2 = spec;
7026   dirend = strrchr(spec,']');
7027   if (dirend == NULL) dirend = strrchr(spec,'>');
7028   if (dirend == NULL) dirend = strchr(spec,':');
7029   if (dirend == NULL) {
7030     strcpy(rslt,spec);
7031     if (vms_debug_fileify) {
7032         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7033     }
7034     return rslt;
7035   }
7036
7037   /* Special case 1 - sys$posix_root = / */
7038   if (!decc_disable_posix_root) {
7039     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7040       *cp1 = '/';
7041       cp1++;
7042       cp2 = cp2 + 15;
7043       }
7044   }
7045
7046   /* Special case 2 - Convert NLA0: to /dev/null */
7047   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7048   if (cmp_rslt == 0) {
7049     strcpy(rslt, "/dev/null");
7050     cp1 = cp1 + 9;
7051     cp2 = cp2 + 5;
7052     if (spec[6] != '\0') {
7053       cp1[9] = '/';
7054       cp1++;
7055       cp2++;
7056     }
7057   }
7058
7059    /* Also handle special case "SYS$SCRATCH:" */
7060   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7061   tmp = PerlMem_malloc(VMS_MAXRSS);
7062   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7063   if (cmp_rslt == 0) {
7064   int islnm;
7065
7066     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7067     if (!islnm) {
7068       strcpy(rslt, "/tmp");
7069       cp1 = cp1 + 4;
7070       cp2 = cp2 + 12;
7071       if (spec[12] != '\0') {
7072         cp1[4] = '/';
7073         cp1++;
7074         cp2++;
7075       }
7076     }
7077   }
7078
7079   if (*cp2 != '[' && *cp2 != '<') {
7080     *(cp1++) = '/';
7081   }
7082   else {  /* the VMS spec begins with directories */
7083     cp2++;
7084     if (*cp2 == ']' || *cp2 == '>') {
7085       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7086       PerlMem_free(tmp);
7087       return rslt;
7088     }
7089     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7090       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7091         PerlMem_free(tmp);
7092         if (vms_debug_fileify) {
7093             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7094         }
7095         return NULL;
7096       }
7097       trnlnm_iter_count = 0;
7098       do {
7099         cp3 = tmp;
7100         while (*cp3 != ':' && *cp3) cp3++;
7101         *(cp3++) = '\0';
7102         if (strchr(cp3,']') != NULL) break;
7103         trnlnm_iter_count++;
7104         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7105       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7106       cp1 = rslt;
7107       cp3 = tmp;
7108       *(cp1++) = '/';
7109       while (*cp3) {
7110         *(cp1++) = *(cp3++);
7111         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7112             PerlMem_free(tmp);
7113             set_errno(ENAMETOOLONG);
7114             set_vaxc_errno(SS$_BUFFEROVF);
7115             if (vms_debug_fileify) {
7116                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7117             }
7118             return NULL; /* No room */
7119         }
7120       }
7121       *(cp1++) = '/';
7122     }
7123     if ((*cp2 == '^')) {
7124         /* EFS file escape, pass the next character as is */
7125         /* Fix me: HEX encoding for Unicode not implemented */
7126         cp2++;
7127     }
7128     else if ( *cp2 == '.') {
7129       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7130         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7131         cp2 += 3;
7132       }
7133       else cp2++;
7134     }
7135   }
7136   PerlMem_free(tmp);
7137   for (; cp2 <= dirend; cp2++) {
7138     if ((*cp2 == '^')) {
7139         /* EFS file escape, pass the next character as is */
7140         /* Fix me: HEX encoding for Unicode not implemented */
7141         *(cp1++) = *(++cp2);
7142         /* An escaped dot stays as is -- don't convert to slash */
7143         if (*cp2 == '.') cp2++;
7144     }
7145     if (*cp2 == ':') {
7146       *(cp1++) = '/';
7147       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7148     }
7149     else if (*cp2 == ']' || *cp2 == '>') {
7150       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7151     }
7152     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7153       *(cp1++) = '/';
7154       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7155         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7156                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7157         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7158             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7159       }
7160       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7161         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7162         cp2 += 2;
7163       }
7164     }
7165     else if (*cp2 == '-') {
7166       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7167         while (*cp2 == '-') {
7168           cp2++;
7169           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7170         }
7171         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7172                                                          /* filespecs like */
7173           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7174           if (vms_debug_fileify) {
7175               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7176           }
7177           return NULL;
7178         }
7179       }
7180       else *(cp1++) = *cp2;
7181     }
7182     else *(cp1++) = *cp2;
7183   }
7184   /* Translate the rest of the filename. */
7185   while (*cp2) {
7186       int dot_seen;
7187       dot_seen = 0;
7188       switch(*cp2) {
7189       /* Fixme - for compatibility with the CRTL we should be removing */
7190       /* spaces from the file specifications, but this may show that */
7191       /* some tests that were appearing to pass are not really passing */
7192       case '%':
7193           cp2++;
7194           *(cp1++) = '?';
7195           break;
7196       case '^':
7197           /* Fix me hex expansions not implemented */
7198           cp2++;  /* '^.' --> '.' and other. */
7199           if (*cp2) {
7200               if (*cp2 == '_') {
7201                   cp2++;
7202                   *(cp1++) = ' ';
7203               } else {
7204                   *(cp1++) = *(cp2++);
7205               }
7206           }
7207           break;
7208       case ';':
7209           if (decc_filename_unix_no_version) {
7210               /* Easy, drop the version */
7211               while (*cp2)
7212                   cp2++;
7213               break;
7214           } else {
7215               /* Punt - passing the version as a dot will probably */
7216               /* break perl in weird ways, but so did passing */
7217               /* through the ; as a version.  Follow the CRTL and */
7218               /* hope for the best. */
7219               cp2++;
7220               *(cp1++) = '.';
7221           }
7222           break;
7223       case '.':
7224           if (dot_seen) {
7225               /* We will need to fix this properly later */
7226               /* As Perl may be installed on an ODS-5 volume, but not */
7227               /* have the EFS_CHARSET enabled, it still may encounter */
7228               /* filenames with extra dots in them, and a precedent got */
7229               /* set which allowed them to work, that we will uphold here */
7230               /* If extra dots are present in a name and no ^ is on them */
7231               /* VMS assumes that the first one is the extension delimiter */
7232               /* the rest have an implied ^. */
7233
7234               /* this is also a conflict as the . is also a version */
7235               /* delimiter in VMS, */
7236
7237               *(cp1++) = *(cp2++);
7238               break;
7239           }
7240           dot_seen = 1;
7241           /* This is an extension */
7242           if (decc_readdir_dropdotnotype) {
7243               cp2++;
7244               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7245                   /* Drop the dot for the extension */
7246                   break;
7247               } else {
7248                   *(cp1++) = '.';
7249               }
7250               break;
7251           }
7252       default:
7253           *(cp1++) = *(cp2++);
7254       }
7255   }
7256   *cp1 = '\0';
7257
7258   /* This still leaves /000000/ when working with a
7259    * VMS device root or concealed root.
7260    */
7261   {
7262   int ulen;
7263   char * zeros;
7264
7265       ulen = strlen(rslt);
7266
7267       /* Get rid of "000000/ in rooted filespecs */
7268       if (ulen > 7) {
7269         zeros = strstr(rslt, "/000000/");
7270         if (zeros != NULL) {
7271           int mlen;
7272           mlen = ulen - (zeros - rslt) - 7;
7273           memmove(zeros, &zeros[7], mlen);
7274           ulen = ulen - 7;
7275           rslt[ulen] = '\0';
7276         }
7277       }
7278   }
7279
7280   if (vms_debug_fileify) {
7281       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7282   }
7283   return rslt;
7284
7285 }  /* end of int_tounixspec() */
7286
7287
7288 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7289 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7290 {
7291     static char __tounixspec_retbuf[VMS_MAXRSS];
7292     char * unixspec, *ret_spec, *ret_buf;
7293
7294     unixspec = NULL;
7295     ret_buf = buf;
7296     if (ret_buf == NULL) {
7297         if (ts) {
7298             Newx(unixspec, VMS_MAXRSS, char);
7299             if (unixspec == NULL)
7300                 _ckvmssts(SS$_INSFMEM);
7301             ret_buf = unixspec;
7302         } else {
7303             ret_buf = __tounixspec_retbuf;
7304         }
7305     }
7306
7307     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7308
7309     if (ret_spec == NULL) {
7310        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7311        if (unixspec)
7312            Safefree(unixspec);
7313     }
7314
7315     return ret_spec;
7316
7317 }  /* end of do_tounixspec() */
7318 /*}}}*/
7319 /* External entry points */
7320 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7321   { return do_tounixspec(spec,buf,0, NULL); }
7322 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7323   { return do_tounixspec(spec,buf,1, NULL); }
7324 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7325   { return do_tounixspec(spec,buf,0, utf8_fl); }
7326 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7327   { return do_tounixspec(spec,buf,1, utf8_fl); }
7328
7329 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7330
7331 /*
7332  This procedure is used to identify if a path is based in either
7333  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7334  it returns the OpenVMS format directory for it.
7335
7336  It is expecting specifications of only '/' or '/xxxx/'
7337
7338  If a posix root does not exist, or 'xxxx' is not a directory
7339  in the posix root, it returns a failure.
7340
7341  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7342
7343  It is used only internally by posix_to_vmsspec_hardway().
7344  */
7345
7346 static int posix_root_to_vms
7347   (char *vmspath, int vmspath_len,
7348    const char *unixpath,
7349    const int * utf8_fl)
7350 {
7351 int sts;
7352 struct FAB myfab = cc$rms_fab;
7353 rms_setup_nam(mynam);
7354 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7355 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7356 char * esa, * esal, * rsa, * rsal;
7357 int dir_flag;
7358 int unixlen;
7359
7360     dir_flag = 0;
7361     vmspath[0] = '\0';
7362     unixlen = strlen(unixpath);
7363     if (unixlen == 0) {
7364       return RMS$_FNF;
7365     }
7366
7367 #if __CRTL_VER >= 80200000
7368   /* If not a posix spec already, convert it */
7369   if (decc_posix_compliant_pathnames) {
7370     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7371       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7372     }
7373     else {
7374       /* This is already a VMS specification, no conversion */
7375       unixlen--;
7376       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7377     }
7378   }
7379   else
7380 #endif
7381   {
7382   int path_len;
7383   int i,j;
7384
7385      /* Check to see if this is under the POSIX root */
7386      if (decc_disable_posix_root) {
7387         return RMS$_FNF;
7388      }
7389
7390      /* Skip leading / */
7391      if (unixpath[0] == '/') {
7392         unixpath++;
7393         unixlen--;
7394      }
7395
7396
7397      strcpy(vmspath,"SYS$POSIX_ROOT:");
7398
7399      /* If this is only the / , or blank, then... */
7400      if (unixpath[0] == '\0') {
7401         /* by definition, this is the answer */
7402         return SS$_NORMAL;
7403      }
7404
7405      /* Need to look up a directory */
7406      vmspath[15] = '[';
7407      vmspath[16] = '\0';
7408
7409      /* Copy and add '^' escape characters as needed */
7410      j = 16;
7411      i = 0;
7412      while (unixpath[i] != 0) {
7413      int k;
7414
7415         j += copy_expand_unix_filename_escape
7416             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7417         i += k;
7418      }
7419
7420      path_len = strlen(vmspath);
7421      if (vmspath[path_len - 1] == '/')
7422         path_len--;
7423      vmspath[path_len] = ']';
7424      path_len++;
7425      vmspath[path_len] = '\0';
7426
7427   }
7428   vmspath[vmspath_len] = 0;
7429   if (unixpath[unixlen - 1] == '/')
7430   dir_flag = 1;
7431   esal = PerlMem_malloc(VMS_MAXRSS);
7432   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7433   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7434   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7435   rsal = PerlMem_malloc(VMS_MAXRSS);
7436   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7437   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7438   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7439   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7440   rms_bind_fab_nam(myfab, mynam);
7441   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7442   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7443   if (decc_efs_case_preserve)
7444     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7445 #ifdef NAML$M_OPEN_SPECIAL
7446   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7447 #endif
7448
7449   /* Set up the remaining naml fields */
7450   sts = sys$parse(&myfab);
7451
7452   /* It failed! Try again as a UNIX filespec */
7453   if (!(sts & 1)) {
7454     PerlMem_free(esal);
7455     PerlMem_free(esa);
7456     PerlMem_free(rsal);
7457     PerlMem_free(rsa);
7458     return sts;
7459   }
7460
7461    /* get the Device ID and the FID */
7462    sts = sys$search(&myfab);
7463
7464    /* These are no longer needed */
7465    PerlMem_free(esa);
7466    PerlMem_free(rsal);
7467    PerlMem_free(rsa);
7468
7469    /* on any failure, returned the POSIX ^UP^ filespec */
7470    if (!(sts & 1)) {
7471       PerlMem_free(esal);
7472       return sts;
7473    }
7474    specdsc.dsc$a_pointer = vmspath;
7475    specdsc.dsc$w_length = vmspath_len;
7476
7477    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7478    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7479    sts = lib$fid_to_name
7480       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7481
7482   /* on any failure, returned the POSIX ^UP^ filespec */
7483   if (!(sts & 1)) {
7484      /* This can happen if user does not have permission to read directories */
7485      if (strncmp(unixpath,"\"^UP^",5) != 0)
7486        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7487      else
7488        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7489   }
7490   else {
7491     vmspath[specdsc.dsc$w_length] = 0;
7492
7493     /* Are we expecting a directory? */
7494     if (dir_flag != 0) {
7495     int i;
7496     char *eptr;
7497
7498       eptr = NULL;
7499
7500       i = specdsc.dsc$w_length - 1;
7501       while (i > 0) {
7502       int zercnt;
7503         zercnt = 0;
7504         /* Version must be '1' */
7505         if (vmspath[i--] != '1')
7506           break;
7507         /* Version delimiter is one of ".;" */
7508         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7509           break;
7510         i--;
7511         if (vmspath[i--] != 'R')
7512           break;
7513         if (vmspath[i--] != 'I')
7514           break;
7515         if (vmspath[i--] != 'D')
7516           break;
7517         if (vmspath[i--] != '.')
7518           break;
7519         eptr = &vmspath[i+1];
7520         while (i > 0) {
7521           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7522             if (vmspath[i-1] != '^') {
7523               if (zercnt != 6) {
7524                 *eptr = vmspath[i];
7525                 eptr[1] = '\0';
7526                 vmspath[i] = '.';
7527                 break;
7528               }
7529               else {
7530                 /* Get rid of 6 imaginary zero directory filename */
7531                 vmspath[i+1] = '\0';
7532               }
7533             }
7534           }
7535           if (vmspath[i] == '0')
7536             zercnt++;
7537           else
7538             zercnt = 10;
7539           i--;
7540         }
7541         break;
7542       }
7543     }
7544   }
7545   PerlMem_free(esal);
7546   return sts;
7547 }
7548
7549 /* /dev/mumble needs to be handled special.
7550    /dev/null becomes NLA0:, And there is the potential for other stuff
7551    like /dev/tty which may need to be mapped to something.
7552 */
7553
7554 static int
7555 slash_dev_special_to_vms
7556    (const char * unixptr,
7557     char * vmspath,
7558     int vmspath_len)
7559 {
7560 char * nextslash;
7561 int len;
7562 int cmp;
7563
7564     unixptr += 4;
7565     nextslash = strchr(unixptr, '/');
7566     len = strlen(unixptr);
7567     if (nextslash != NULL)
7568         len = nextslash - unixptr;
7569     cmp = strncmp("null", unixptr, 5);
7570     if (cmp == 0) {
7571         if (vmspath_len >= 6) {
7572             strcpy(vmspath, "_NLA0:");
7573             return SS$_NORMAL;
7574         }
7575     }
7576     return 0;
7577 }
7578
7579
7580 /* The built in routines do not understand perl's special needs, so
7581     doing a manual conversion from UNIX to VMS
7582
7583     If the utf8_fl is not null and points to a non-zero value, then
7584     treat 8 bit characters as UTF-8.
7585
7586     The sequence starting with '$(' and ending with ')' will be passed
7587     through with out interpretation instead of being escaped.
7588
7589   */
7590 static int posix_to_vmsspec_hardway
7591   (char *vmspath, int vmspath_len,
7592    const char *unixpath,
7593    int dir_flag,
7594    int * utf8_fl) {
7595
7596 char *esa;
7597 const char *unixptr;
7598 const char *unixend;
7599 char *vmsptr;
7600 const char *lastslash;
7601 const char *lastdot;
7602 int unixlen;
7603 int vmslen;
7604 int dir_start;
7605 int dir_dot;
7606 int quoted;
7607 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7608 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7609
7610   if (utf8_fl != NULL)
7611     *utf8_fl = 0;
7612
7613   unixptr = unixpath;
7614   dir_dot = 0;
7615
7616   /* Ignore leading "/" characters */
7617   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7618     unixptr++;
7619   }
7620   unixlen = strlen(unixptr);
7621
7622   /* Do nothing with blank paths */
7623   if (unixlen == 0) {
7624     vmspath[0] = '\0';
7625     return SS$_NORMAL;
7626   }
7627
7628   quoted = 0;
7629   /* This could have a "^UP^ on the front */
7630   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7631     quoted = 1;
7632     unixptr+= 5;
7633     unixlen-= 5;
7634   }
7635
7636   lastslash = strrchr(unixptr,'/');
7637   lastdot = strrchr(unixptr,'.');
7638   unixend = strrchr(unixptr,'\"');
7639   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7640     unixend = unixptr + unixlen;
7641   }
7642
7643   /* last dot is last dot or past end of string */
7644   if (lastdot == NULL)
7645     lastdot = unixptr + unixlen;
7646
7647   /* if no directories, set last slash to beginning of string */
7648   if (lastslash == NULL) {
7649     lastslash = unixptr;
7650   }
7651   else {
7652     /* Watch out for trailing "." after last slash, still a directory */
7653     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7654       lastslash = unixptr + unixlen;
7655     }
7656
7657     /* Watch out for trailing ".." after last slash, still a directory */
7658     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7659       lastslash = unixptr + unixlen;
7660     }
7661
7662     /* dots in directories are aways escaped */
7663     if (lastdot < lastslash)
7664       lastdot = unixptr + unixlen;
7665   }
7666
7667   /* if (unixptr < lastslash) then we are in a directory */
7668
7669   dir_start = 0;
7670
7671   vmsptr = vmspath;
7672   vmslen = 0;
7673
7674   /* Start with the UNIX path */
7675   if (*unixptr != '/') {
7676     /* relative paths */
7677
7678     /* If allowing logical names on relative pathnames, then handle here */
7679     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7680         !decc_posix_compliant_pathnames) {
7681     char * nextslash;
7682     int seg_len;
7683     char * trn;
7684     int islnm;
7685
7686         /* Find the next slash */
7687         nextslash = strchr(unixptr,'/');
7688
7689         esa = PerlMem_malloc(vmspath_len);
7690         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7691
7692         trn = PerlMem_malloc(VMS_MAXRSS);
7693         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7694
7695         if (nextslash != NULL) {
7696
7697             seg_len = nextslash - unixptr;
7698             memcpy(esa, unixptr, seg_len);
7699             esa[seg_len] = 0;
7700         }
7701         else {
7702             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7703         }
7704         /* trnlnm(section) */
7705         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7706
7707         if (islnm) {
7708             /* Now fix up the directory */
7709
7710             /* Split up the path to find the components */
7711             sts = vms_split_path
7712                   (trn,
7713                    &v_spec,
7714                    &v_len,
7715                    &r_spec,
7716                    &r_len,
7717                    &d_spec,
7718                    &d_len,
7719                    &n_spec,
7720                    &n_len,
7721                    &e_spec,
7722                    &e_len,
7723                    &vs_spec,
7724                    &vs_len);
7725
7726             while (sts == 0) {
7727             int cmp;
7728
7729                 /* A logical name must be a directory  or the full
7730                    specification.  It is only a full specification if
7731                    it is the only component */
7732                 if ((unixptr[seg_len] == '\0') ||
7733                     (unixptr[seg_len+1] == '\0')) {
7734
7735                     /* Is a directory being required? */
7736                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7737                         /* Not a logical name */
7738                         break;
7739                     }
7740
7741
7742                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7743                         /* This must be a directory */
7744                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7745                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7746                             vmsptr[vmslen] = ':';
7747                             vmslen++;
7748                             vmsptr[vmslen] = '\0';
7749                             return SS$_NORMAL;
7750                         }
7751                     }
7752
7753                 }
7754
7755
7756                 /* must be dev/directory - ignore version */
7757                 if ((n_len + e_len) != 0)
7758                     break;
7759
7760                 /* transfer the volume */
7761                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7762                     memcpy(vmsptr, v_spec, v_len);
7763                     vmsptr += v_len;
7764                     vmsptr[0] = '\0';
7765                     vmslen += v_len;
7766                 }
7767
7768                 /* unroot the rooted directory */
7769                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7770                     r_spec[0] = '[';
7771                     r_spec[r_len - 1] = ']';
7772
7773                     /* This should not be there, but nothing is perfect */
7774                     if (r_len > 9) {
7775                         cmp = strcmp(&r_spec[1], "000000.");
7776                         if (cmp == 0) {
7777                             r_spec += 7;
7778                             r_spec[7] = '[';
7779                             r_len -= 7;
7780                             if (r_len == 2)
7781                                 r_len = 0;
7782                         }
7783                     }
7784                     if (r_len > 0) {
7785                         memcpy(vmsptr, r_spec, r_len);
7786                         vmsptr += r_len;
7787                         vmslen += r_len;
7788                         vmsptr[0] = '\0';
7789                     }
7790                 }
7791                 /* Bring over the directory. */
7792                 if ((d_len > 0) &&
7793                     ((d_len + vmslen) < vmspath_len)) {
7794                     d_spec[0] = '[';
7795                     d_spec[d_len - 1] = ']';
7796                     if (d_len > 9) {
7797                         cmp = strcmp(&d_spec[1], "000000.");
7798                         if (cmp == 0) {
7799                             d_spec += 7;
7800                             d_spec[7] = '[';
7801                             d_len -= 7;
7802                             if (d_len == 2)
7803                                 d_len = 0;
7804                         }
7805                     }
7806
7807                     if (r_len > 0) {
7808                         /* Remove the redundant root */
7809                         if (r_len > 0) {
7810                             /* remove the ][ */
7811                             vmsptr--;
7812                             vmslen--;
7813                             d_spec++;
7814                             d_len--;
7815                         }
7816                         memcpy(vmsptr, d_spec, d_len);
7817                             vmsptr += d_len;
7818                             vmslen += d_len;
7819                             vmsptr[0] = '\0';
7820                     }
7821                 }
7822                 break;
7823             }
7824         }
7825
7826         PerlMem_free(esa);
7827         PerlMem_free(trn);
7828     }
7829
7830     if (lastslash > unixptr) {
7831     int dotdir_seen;
7832
7833       /* skip leading ./ */
7834       dotdir_seen = 0;
7835       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7836         dotdir_seen = 1;
7837         unixptr++;
7838         unixptr++;
7839       }
7840
7841       /* Are we still in a directory? */
7842       if (unixptr <= lastslash) {
7843         *vmsptr++ = '[';
7844         vmslen = 1;
7845         dir_start = 1;
7846
7847         /* if not backing up, then it is relative forward. */
7848         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7849               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7850           *vmsptr++ = '.';
7851           vmslen++;
7852           dir_dot = 1;
7853           }
7854        }
7855        else {
7856          if (dotdir_seen) {
7857            /* Perl wants an empty directory here to tell the difference
7858             * between a DCL command and a filename
7859             */
7860           *vmsptr++ = '[';
7861           *vmsptr++ = ']';
7862           vmslen = 2;
7863         }
7864       }
7865     }
7866     else {
7867       /* Handle two special files . and .. */
7868       if (unixptr[0] == '.') {
7869         if (&unixptr[1] == unixend) {
7870           *vmsptr++ = '[';
7871           *vmsptr++ = ']';
7872           vmslen += 2;
7873           *vmsptr++ = '\0';
7874           return SS$_NORMAL;
7875         }
7876         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7877           *vmsptr++ = '[';
7878           *vmsptr++ = '-';
7879           *vmsptr++ = ']';
7880           vmslen += 3;
7881           *vmsptr++ = '\0';
7882           return SS$_NORMAL;
7883         }
7884       }
7885     }
7886   }
7887   else {        /* Absolute PATH handling */
7888   int sts;
7889   char * nextslash;
7890   int seg_len;
7891     /* Need to find out where root is */
7892
7893     /* In theory, this procedure should never get an absolute POSIX pathname
7894      * that can not be found on the POSIX root.
7895      * In practice, that can not be relied on, and things will show up
7896      * here that are a VMS device name or concealed logical name instead.
7897      * So to make things work, this procedure must be tolerant.
7898      */
7899     esa = PerlMem_malloc(vmspath_len);
7900     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7901
7902     sts = SS$_NORMAL;
7903     nextslash = strchr(&unixptr[1],'/');
7904     seg_len = 0;
7905     if (nextslash != NULL) {
7906       int cmp;
7907       seg_len = nextslash - &unixptr[1];
7908       my_strlcpy(vmspath, unixptr, seg_len + 2);
7909       cmp = 1;
7910       if (seg_len == 3) {
7911         cmp = strncmp(vmspath, "dev", 4);
7912         if (cmp == 0) {
7913             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7914             if (sts == SS$_NORMAL)
7915                 return SS$_NORMAL;
7916         }
7917       }
7918       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7919     }
7920
7921     if ($VMS_STATUS_SUCCESS(sts)) {
7922       /* This is verified to be a real path */
7923
7924       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7925       if ($VMS_STATUS_SUCCESS(sts)) {
7926         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
7927         vmsptr = vmspath + vmslen;
7928         unixptr++;
7929         if (unixptr < lastslash) {
7930         char * rptr;
7931           vmsptr--;
7932           *vmsptr++ = '.';
7933           dir_start = 1;
7934           dir_dot = 1;
7935           if (vmslen > 7) {
7936           int cmp;
7937             rptr = vmsptr - 7;
7938             cmp = strcmp(rptr,"000000.");
7939             if (cmp == 0) {
7940               vmslen -= 7;
7941               vmsptr -= 7;
7942               vmsptr[1] = '\0';
7943             } /* removing 6 zeros */
7944           } /* vmslen < 7, no 6 zeros possible */
7945         } /* Not in a directory */
7946       } /* Posix root found */
7947       else {
7948         /* No posix root, fall back to default directory */
7949         strcpy(vmspath, "SYS$DISK:[");
7950         vmsptr = &vmspath[10];
7951         vmslen = 10;
7952         if (unixptr > lastslash) {
7953            *vmsptr = ']';
7954            vmsptr++;
7955            vmslen++;
7956         }
7957         else {
7958            dir_start = 1;
7959         }
7960       }
7961     } /* end of verified real path handling */
7962     else {
7963     int add_6zero;
7964     int islnm;
7965
7966       /* Ok, we have a device or a concealed root that is not in POSIX
7967        * or we have garbage.  Make the best of it.
7968        */
7969
7970       /* Posix to VMS destroyed this, so copy it again */
7971       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
7972       vmslen = strlen(vmspath); /* We know we're truncating. */
7973       vmsptr = &vmsptr[vmslen];
7974       islnm = 0;
7975
7976       /* Now do we need to add the fake 6 zero directory to it? */
7977       add_6zero = 1;
7978       if ((*lastslash == '/') && (nextslash < lastslash)) {
7979         /* No there is another directory */
7980         add_6zero = 0;
7981       }
7982       else {
7983       int trnend;
7984       int cmp;
7985
7986         /* now we have foo:bar or foo:[000000]bar to decide from */
7987         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7988
7989         if (!islnm && !decc_posix_compliant_pathnames) {
7990
7991             cmp = strncmp("bin", vmspath, 4);
7992             if (cmp == 0) {
7993                 /* bin => SYS$SYSTEM: */
7994                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7995             }
7996             else {
7997                 /* tmp => SYS$SCRATCH: */
7998                 cmp = strncmp("tmp", vmspath, 4);
7999                 if (cmp == 0) {
8000                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8001                 }
8002             }
8003         }
8004
8005         trnend = islnm ? islnm - 1 : 0;
8006
8007         /* if this was a logical name, ']' or '>' must be present */
8008         /* if not a logical name, then assume a device and hope. */
8009         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8010
8011         /* if log name and trailing '.' then rooted - treat as device */
8012         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8013
8014         /* Fix me, if not a logical name, a device lookup should be
8015          * done to see if the device is file structured.  If the device
8016          * is not file structured, the 6 zeros should not be put on.
8017          *
8018          * As it is, perl is occasionally looking for dev:[000000]tty.
8019          * which looks a little strange.
8020          *
8021          * Not that easy to detect as "/dev" may be file structured with
8022          * special device files.
8023          */
8024
8025         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
8026             (&nextslash[1] == unixend)) {
8027           /* No real directory present */
8028           add_6zero = 1;
8029         }
8030       }
8031
8032       /* Put the device delimiter on */
8033       *vmsptr++ = ':';
8034       vmslen++;
8035       unixptr = nextslash;
8036       unixptr++;
8037
8038       /* Start directory if needed */
8039       if (!islnm || add_6zero) {
8040         *vmsptr++ = '[';
8041         vmslen++;
8042         dir_start = 1;
8043       }
8044
8045       /* add fake 000000] if needed */
8046       if (add_6zero) {
8047         *vmsptr++ = '0';
8048         *vmsptr++ = '0';
8049         *vmsptr++ = '0';
8050         *vmsptr++ = '0';
8051         *vmsptr++ = '0';
8052         *vmsptr++ = '0';
8053         *vmsptr++ = ']';
8054         vmslen += 7;
8055         dir_start = 0;
8056       }
8057
8058     } /* non-POSIX translation */
8059     PerlMem_free(esa);
8060   } /* End of relative/absolute path handling */
8061
8062   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8063   int dash_flag;
8064   int in_cnt;
8065   int out_cnt;
8066
8067     dash_flag = 0;
8068
8069     if (dir_start != 0) {
8070
8071       /* First characters in a directory are handled special */
8072       while ((*unixptr == '/') ||
8073              ((*unixptr == '.') &&
8074               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8075                 (&unixptr[1]==unixend)))) {
8076       int loop_flag;
8077
8078         loop_flag = 0;
8079
8080         /* Skip redundant / in specification */
8081         while ((*unixptr == '/') && (dir_start != 0)) {
8082           loop_flag = 1;
8083           unixptr++;
8084           if (unixptr == lastslash)
8085             break;
8086         }
8087         if (unixptr == lastslash)
8088           break;
8089
8090         /* Skip redundant ./ characters */
8091         while ((*unixptr == '.') &&
8092                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8093           loop_flag = 1;
8094           unixptr++;
8095           if (unixptr == lastslash)
8096             break;
8097           if (*unixptr == '/')
8098             unixptr++;
8099         }
8100         if (unixptr == lastslash)
8101           break;
8102
8103         /* Skip redundant ../ characters */
8104         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8105              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8106           /* Set the backing up flag */
8107           loop_flag = 1;
8108           dir_dot = 0;
8109           dash_flag = 1;
8110           *vmsptr++ = '-';
8111           vmslen++;
8112           unixptr++; /* first . */
8113           unixptr++; /* second . */
8114           if (unixptr == lastslash)
8115             break;
8116           if (*unixptr == '/') /* The slash */
8117             unixptr++;
8118         }
8119         if (unixptr == lastslash)
8120           break;
8121
8122         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8123         /* Not needed when VMS is pretending to be UNIX. */
8124
8125         /* Is this loop stuck because of too many dots? */
8126         if (loop_flag == 0) {
8127           /* Exit the loop and pass the rest through */
8128           break;
8129         }
8130       }
8131
8132       /* Are we done with directories yet? */
8133       if (unixptr >= lastslash) {
8134
8135         /* Watch out for trailing dots */
8136         if (dir_dot != 0) {
8137             vmslen --;
8138             vmsptr--;
8139         }
8140         *vmsptr++ = ']';
8141         vmslen++;
8142         dash_flag = 0;
8143         dir_start = 0;
8144         if (*unixptr == '/')
8145           unixptr++;
8146       }
8147       else {
8148         /* Have we stopped backing up? */
8149         if (dash_flag) {
8150           *vmsptr++ = '.';
8151           vmslen++;
8152           dash_flag = 0;
8153           /* dir_start continues to be = 1 */
8154         }
8155         if (*unixptr == '-') {
8156           *vmsptr++ = '^';
8157           *vmsptr++ = *unixptr++;
8158           vmslen += 2;
8159           dir_start = 0;
8160
8161           /* Now are we done with directories yet? */
8162           if (unixptr >= lastslash) {
8163
8164             /* Watch out for trailing dots */
8165             if (dir_dot != 0) {
8166               vmslen --;
8167               vmsptr--;
8168             }
8169
8170             *vmsptr++ = ']';
8171             vmslen++;
8172             dash_flag = 0;
8173             dir_start = 0;
8174           }
8175         }
8176       }
8177     }
8178
8179     /* All done? */
8180     if (unixptr >= unixend)
8181       break;
8182
8183     /* Normal characters - More EFS work probably needed */
8184     dir_start = 0;
8185     dir_dot = 0;
8186
8187     switch(*unixptr) {
8188     case '/':
8189         /* remove multiple / */
8190         while (unixptr[1] == '/') {
8191            unixptr++;
8192         }
8193         if (unixptr == lastslash) {
8194           /* Watch out for trailing dots */
8195           if (dir_dot != 0) {
8196             vmslen --;
8197             vmsptr--;
8198           }
8199           *vmsptr++ = ']';
8200         }
8201         else {
8202           dir_start = 1;
8203           *vmsptr++ = '.';
8204           dir_dot = 1;
8205
8206           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8207           /* Not needed when VMS is pretending to be UNIX. */
8208
8209         }
8210         dash_flag = 0;
8211         if (unixptr != unixend)
8212           unixptr++;
8213         vmslen++;
8214         break;
8215     case '.':
8216         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8217             (&unixptr[1] == unixend)) {
8218           *vmsptr++ = '^';
8219           *vmsptr++ = '.';
8220           vmslen += 2;
8221           unixptr++;
8222
8223           /* trailing dot ==> '^..' on VMS */
8224           if (unixptr == unixend) {
8225             *vmsptr++ = '.';
8226             vmslen++;
8227             unixptr++;
8228           }
8229           break;
8230         }
8231
8232         *vmsptr++ = *unixptr++;
8233         vmslen ++;
8234         break;
8235     case '"':
8236         if (quoted && (&unixptr[1] == unixend)) {
8237             unixptr++;
8238             break;
8239         }
8240         in_cnt = copy_expand_unix_filename_escape
8241                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8242         vmsptr += out_cnt;
8243         unixptr += in_cnt;
8244         break;
8245     case '~':
8246     case ';':
8247     case '\\':
8248     case '?':
8249     case ' ':
8250     default:
8251         in_cnt = copy_expand_unix_filename_escape
8252                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8253         vmsptr += out_cnt;
8254         unixptr += in_cnt;
8255         break;
8256     }
8257   }
8258
8259   /* Make sure directory is closed */
8260   if (unixptr == lastslash) {
8261     char *vmsptr2;
8262     vmsptr2 = vmsptr - 1;
8263
8264     if (*vmsptr2 != ']') {
8265       *vmsptr2--;
8266
8267       /* directories do not end in a dot bracket */
8268       if (*vmsptr2 == '.') {
8269         vmsptr2--;
8270
8271         /* ^. is allowed */
8272         if (*vmsptr2 != '^') {
8273           vmsptr--; /* back up over the dot */
8274         }
8275       }
8276       *vmsptr++ = ']';
8277     }
8278   }
8279   else {
8280     char *vmsptr2;
8281     /* Add a trailing dot if a file with no extension */
8282     vmsptr2 = vmsptr - 1;
8283     if ((vmslen > 1) &&
8284         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8285         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8286         *vmsptr++ = '.';
8287         vmslen++;
8288     }
8289   }
8290
8291   *vmsptr = '\0';
8292   return SS$_NORMAL;
8293 }
8294 #endif
8295
8296  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8297 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8298 {
8299 char * result;
8300 int utf8_flag;
8301
8302    /* If a UTF8 flag is being passed, honor it */
8303    utf8_flag = 0;
8304    if (utf8_fl != NULL) {
8305      utf8_flag = *utf8_fl;
8306     *utf8_fl = 0;
8307    }
8308
8309    if (utf8_flag) {
8310      /* If there is a possibility of UTF8, then if any UTF8 characters
8311         are present, then they must be converted to VTF-7
8312       */
8313      result = strcpy(rslt, path); /* FIX-ME */
8314    }
8315    else
8316      result = strcpy(rslt, path);
8317
8318    return result;
8319 }
8320
8321
8322
8323 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8324 static char *int_tovmsspec
8325    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8326   char *dirend;
8327   char *lastdot;
8328   register char *cp1;
8329   const char *cp2;
8330   unsigned long int infront = 0, hasdir = 1;
8331   int rslt_len;
8332   int no_type_seen;
8333   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8334   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8335
8336   if (vms_debug_fileify) {
8337       if (path == NULL)
8338           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8339       else
8340           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8341   }
8342
8343   if (path == NULL) {
8344       /* If we fail, we should be setting errno */
8345       set_errno(EINVAL);
8346       set_vaxc_errno(SS$_BADPARAM);
8347       return NULL;
8348   }
8349   rslt_len = VMS_MAXRSS-1;
8350
8351   /* '.' and '..' are "[]" and "[-]" for a quick check */
8352   if (path[0] == '.') {
8353     if (path[1] == '\0') {
8354       strcpy(rslt,"[]");
8355       if (utf8_flag != NULL)
8356         *utf8_flag = 0;
8357       return rslt;
8358     }
8359     else {
8360       if (path[1] == '.' && path[2] == '\0') {
8361         strcpy(rslt,"[-]");
8362         if (utf8_flag != NULL)
8363            *utf8_flag = 0;
8364         return rslt;
8365       }
8366     }
8367   }
8368
8369    /* Posix specifications are now a native VMS format */
8370   /*--------------------------------------------------*/
8371 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8372   if (decc_posix_compliant_pathnames) {
8373     if (strncmp(path,"\"^UP^",5) == 0) {
8374       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8375       return rslt;
8376     }
8377   }
8378 #endif
8379
8380   /* This is really the only way to see if this is already in VMS format */
8381   sts = vms_split_path
8382        (path,
8383         &v_spec,
8384         &v_len,
8385         &r_spec,
8386         &r_len,
8387         &d_spec,
8388         &d_len,
8389         &n_spec,
8390         &n_len,
8391         &e_spec,
8392         &e_len,
8393         &vs_spec,
8394         &vs_len);
8395   if (sts == 0) {
8396     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8397        replacement, because the above parse just took care of most of
8398        what is needed to do vmspath when the specification is already
8399        in VMS format.
8400
8401        And if it is not already, it is easier to do the conversion as
8402        part of this routine than to call this routine and then work on
8403        the result.
8404      */
8405
8406     /* If VMS punctuation was found, it is already VMS format */
8407     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8408       if (utf8_flag != NULL)
8409         *utf8_flag = 0;
8410       my_strlcpy(rslt, path, VMS_MAXRSS);
8411       if (vms_debug_fileify) {
8412           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8413       }
8414       return rslt;
8415     }
8416     /* Now, what to do with trailing "." cases where there is no
8417        extension?  If this is a UNIX specification, and EFS characters
8418        are enabled, then the trailing "." should be converted to a "^.".
8419        But if this was already a VMS specification, then it should be
8420        left alone.
8421
8422        So in the case of ambiguity, leave the specification alone.
8423      */
8424
8425
8426     /* If there is a possibility of UTF8, then if any UTF8 characters
8427         are present, then they must be converted to VTF-7
8428      */
8429     if (utf8_flag != NULL)
8430       *utf8_flag = 0;
8431     my_strlcpy(rslt, path, VMS_MAXRSS);
8432     if (vms_debug_fileify) {
8433         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8434     }
8435     return rslt;
8436   }
8437
8438   dirend = strrchr(path,'/');
8439
8440   if (dirend == NULL) {
8441      char *macro_start;
8442      int has_macro;
8443
8444      /* If we get here with no UNIX directory delimiters, then this is
8445         not a complete file specification, either garbage a UNIX glob
8446         specification that can not be converted to a VMS wildcard, or
8447         it a UNIX shell macro.  MakeMaker wants shell macros passed
8448         through AS-IS,
8449
8450         utf8 flag setting needs to be preserved.
8451       */
8452       hasdir = 0;
8453
8454       has_macro = 0;
8455       macro_start = strchr(path,'$');
8456       if (macro_start != NULL) {
8457           if (macro_start[1] == '(') {
8458               has_macro = 1;
8459           }
8460       }
8461       if ((decc_efs_charset == 0) || (has_macro)) {
8462           my_strlcpy(rslt, path, VMS_MAXRSS);
8463           if (vms_debug_fileify) {
8464               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8465           }
8466           return rslt;
8467       }
8468   }
8469
8470 /* If EFS charset mode active, handle the conversion */
8471 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8472   if (decc_efs_charset) {
8473     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8474     if (vms_debug_fileify) {
8475         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8476     }
8477     return rslt;
8478   }
8479 #endif
8480
8481   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8482     if (!*(dirend+2)) dirend +=2;
8483     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8484     if (decc_efs_charset == 0) {
8485       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8486     }
8487   }
8488
8489   cp1 = rslt;
8490   cp2 = path;
8491   lastdot = strrchr(cp2,'.');
8492   if (*cp2 == '/') {
8493     char *trndev;
8494     int islnm, rooted;
8495     STRLEN trnend;
8496
8497     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8498     if (!*(cp2+1)) {
8499       if (decc_disable_posix_root) {
8500         strcpy(rslt,"sys$disk:[000000]");
8501       }
8502       else {
8503         strcpy(rslt,"sys$posix_root:[000000]");
8504       }
8505       if (utf8_flag != NULL)
8506         *utf8_flag = 0;
8507       if (vms_debug_fileify) {
8508           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8509       }
8510       return rslt;
8511     }
8512     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8513     *cp1 = '\0';
8514     trndev = PerlMem_malloc(VMS_MAXRSS);
8515     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8516     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8517
8518      /* DECC special handling */
8519     if (!islnm) {
8520       if (strcmp(rslt,"bin") == 0) {
8521         strcpy(rslt,"sys$system");
8522         cp1 = rslt + 10;
8523         *cp1 = 0;
8524         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8525       }
8526       else if (strcmp(rslt,"tmp") == 0) {
8527         strcpy(rslt,"sys$scratch");
8528         cp1 = rslt + 11;
8529         *cp1 = 0;
8530         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8531       }
8532       else if (!decc_disable_posix_root) {
8533         strcpy(rslt, "sys$posix_root");
8534         cp1 = rslt + 14;
8535         *cp1 = 0;
8536         cp2 = path;
8537         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8538         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8539       }
8540       else if (strcmp(rslt,"dev") == 0) {
8541         if (strncmp(cp2,"/null", 5) == 0) {
8542           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8543             strcpy(rslt,"NLA0");
8544             cp1 = rslt + 4;
8545             *cp1 = 0;
8546             cp2 = cp2 + 5;
8547             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8548           }
8549         }
8550       }
8551     }
8552
8553     trnend = islnm ? strlen(trndev) - 1 : 0;
8554     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8555     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8556     /* If the first element of the path is a logical name, determine
8557      * whether it has to be translated so we can add more directories. */
8558     if (!islnm || rooted) {
8559       *(cp1++) = ':';
8560       *(cp1++) = '[';
8561       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8562       else cp2++;
8563     }
8564     else {
8565       if (cp2 != dirend) {
8566         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8567         cp1 = rslt + trnend;
8568         if (*cp2 != 0) {
8569           *(cp1++) = '.';
8570           cp2++;
8571         }
8572       }
8573       else {
8574         if (decc_disable_posix_root) {
8575           *(cp1++) = ':';
8576           hasdir = 0;
8577         }
8578       }
8579     }
8580     PerlMem_free(trndev);
8581   }
8582   else {
8583     *(cp1++) = '[';
8584     if (*cp2 == '.') {
8585       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8586         cp2 += 2;         /* skip over "./" - it's redundant */
8587         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8588       }
8589       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8590         *(cp1++) = '-';                                 /* "../" --> "-" */
8591         cp2 += 3;
8592       }
8593       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8594                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8595         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8596         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8597         cp2 += 4;
8598       }
8599       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8600         /* Escape the extra dots in EFS file specifications */
8601         *(cp1++) = '^';
8602       }
8603       if (cp2 > dirend) cp2 = dirend;
8604     }
8605     else *(cp1++) = '.';
8606   }
8607   for (; cp2 < dirend; cp2++) {
8608     if (*cp2 == '/') {
8609       if (*(cp2-1) == '/') continue;
8610       if (*(cp1-1) != '.') *(cp1++) = '.';
8611       infront = 0;
8612     }
8613     else if (!infront && *cp2 == '.') {
8614       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8615       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8616       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8617         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8618         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8619         else {  /* back up over previous directory name */
8620           cp1--;
8621           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8622           if (*(cp1-1) == '[') {
8623             memcpy(cp1,"000000.",7);
8624             cp1 += 7;
8625           }
8626         }
8627         cp2 += 2;
8628         if (cp2 == dirend) break;
8629       }
8630       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8631                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8632         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8633         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8634         if (!*(cp2+3)) {
8635           *(cp1++) = '.';  /* Simulate trailing '/' */
8636           cp2 += 2;  /* for loop will incr this to == dirend */
8637         }
8638         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8639       }
8640       else {
8641         if (decc_efs_charset == 0)
8642           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8643         else {
8644           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8645           *(cp1++) = '.';
8646         }
8647       }
8648     }
8649     else {
8650       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8651       if (*cp2 == '.') {
8652         if (decc_efs_charset == 0)
8653           *(cp1++) = '_';
8654         else {
8655           *(cp1++) = '^';
8656           *(cp1++) = '.';
8657         }
8658       }
8659       else                  *(cp1++) =  *cp2;
8660       infront = 1;
8661     }
8662   }
8663   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8664   if (hasdir) *(cp1++) = ']';
8665   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8666   /* fixme for ODS5 */
8667   no_type_seen = 0;
8668   if (cp2 > lastdot)
8669     no_type_seen = 1;
8670   while (*cp2) {
8671     switch(*cp2) {
8672     case '?':
8673         if (decc_efs_charset == 0)
8674           *(cp1++) = '%';
8675         else
8676           *(cp1++) = '?';
8677         cp2++;
8678     case ' ':
8679         *(cp1)++ = '^';
8680         *(cp1)++ = '_';
8681         cp2++;
8682         break;
8683     case '.':
8684         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8685             decc_readdir_dropdotnotype) {
8686           *(cp1)++ = '^';
8687           *(cp1)++ = '.';
8688           cp2++;
8689
8690           /* trailing dot ==> '^..' on VMS */
8691           if (*cp2 == '\0') {
8692             *(cp1++) = '.';
8693             no_type_seen = 0;
8694           }
8695         }
8696         else {
8697           *(cp1++) = *(cp2++);
8698           no_type_seen = 0;
8699         }
8700         break;
8701     case '$':
8702          /* This could be a macro to be passed through */
8703         *(cp1++) = *(cp2++);
8704         if (*cp2 == '(') {
8705         const char * save_cp2;
8706         char * save_cp1;
8707         int is_macro;
8708
8709             /* paranoid check */
8710             save_cp2 = cp2;
8711             save_cp1 = cp1;
8712             is_macro = 0;
8713
8714             /* Test through */
8715             *(cp1++) = *(cp2++);
8716             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8717                 *(cp1++) = *(cp2++);
8718                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8719                     *(cp1++) = *(cp2++);
8720                 }
8721                 if (*cp2 == ')') {
8722                     *(cp1++) = *(cp2++);
8723                     is_macro = 1;
8724                 }
8725             }
8726             if (is_macro == 0) {
8727                 /* Not really a macro - never mind */
8728                 cp2 = save_cp2;
8729                 cp1 = save_cp1;
8730             }
8731         }
8732         break;
8733     case '\"':
8734     case '~':
8735     case '`':
8736     case '!':
8737     case '#':
8738     case '%':
8739     case '^':
8740         /* Don't escape again if following character is
8741          * already something we escape.
8742          */
8743         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8744             *(cp1++) = *(cp2++);
8745             break;
8746         }
8747         /* But otherwise fall through and escape it. */
8748     case '&':
8749     case '(':
8750     case ')':
8751     case '=':
8752     case '+':
8753     case '\'':
8754     case '@':
8755     case '[':
8756     case ']':
8757     case '{':
8758     case '}':
8759     case ':':
8760     case '\\':
8761     case '|':
8762     case '<':
8763     case '>':
8764         *(cp1++) = '^';
8765         *(cp1++) = *(cp2++);
8766         break;
8767     case ';':
8768         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8769          * which is wrong.  UNIX notation should be ".dir." unless
8770          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8771          * changing this behavior could break more things at this time.
8772          * efs character set effectively does not allow "." to be a version
8773          * delimiter as a further complication about changing this.
8774          */
8775         if (decc_filename_unix_report != 0) {
8776           *(cp1++) = '^';
8777         }
8778         *(cp1++) = *(cp2++);
8779         break;
8780     default:
8781         *(cp1++) = *(cp2++);
8782     }
8783   }
8784   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8785   char *lcp1;
8786     lcp1 = cp1;
8787     lcp1--;
8788      /* Fix me for "^]", but that requires making sure that you do
8789       * not back up past the start of the filename
8790       */
8791     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8792       *cp1++ = '.';
8793   }
8794   *cp1 = '\0';
8795
8796   if (utf8_flag != NULL)
8797     *utf8_flag = 0;
8798   if (vms_debug_fileify) {
8799       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8800   }
8801   return rslt;
8802
8803 }  /* end of int_tovmsspec() */
8804
8805
8806 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8807 static char *mp_do_tovmsspec
8808    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8809   static char __tovmsspec_retbuf[VMS_MAXRSS];
8810     char * vmsspec, *ret_spec, *ret_buf;
8811
8812     vmsspec = NULL;
8813     ret_buf = buf;
8814     if (ret_buf == NULL) {
8815         if (ts) {
8816             Newx(vmsspec, VMS_MAXRSS, char);
8817             if (vmsspec == NULL)
8818                 _ckvmssts(SS$_INSFMEM);
8819             ret_buf = vmsspec;
8820         } else {
8821             ret_buf = __tovmsspec_retbuf;
8822         }
8823     }
8824
8825     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8826
8827     if (ret_spec == NULL) {
8828        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8829        if (vmsspec)
8830            Safefree(vmsspec);
8831     }
8832
8833     return ret_spec;
8834
8835 }  /* end of mp_do_tovmsspec() */
8836 /*}}}*/
8837 /* External entry points */
8838 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8839   { return do_tovmsspec(path,buf,0,NULL); }
8840 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8841   { return do_tovmsspec(path,buf,1,NULL); }
8842 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8843   { return do_tovmsspec(path,buf,0,utf8_fl); }
8844 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8845   { return do_tovmsspec(path,buf,1,utf8_fl); }
8846
8847 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8848 /* Internal routine for use with out an explicit context present */
8849 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
8850
8851     char * ret_spec, *pathified;
8852
8853     if (path == NULL)
8854         return NULL;
8855
8856     pathified = PerlMem_malloc(VMS_MAXRSS);
8857     if (pathified == NULL)
8858         _ckvmssts_noperl(SS$_INSFMEM);
8859
8860     ret_spec = int_pathify_dirspec(path, pathified);
8861
8862     if (ret_spec == NULL) {
8863         PerlMem_free(pathified);
8864         return NULL;
8865     }
8866
8867     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8868
8869     PerlMem_free(pathified);
8870     return ret_spec;
8871
8872 }
8873
8874 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8875 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8876   static char __tovmspath_retbuf[VMS_MAXRSS];
8877   int vmslen;
8878   char *pathified, *vmsified, *cp;
8879
8880   if (path == NULL) return NULL;
8881   pathified = PerlMem_malloc(VMS_MAXRSS);
8882   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8883   if (int_pathify_dirspec(path, pathified) == NULL) {
8884     PerlMem_free(pathified);
8885     return NULL;
8886   }
8887
8888   vmsified = NULL;
8889   if (buf == NULL)
8890      Newx(vmsified, VMS_MAXRSS, char);
8891   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8892     PerlMem_free(pathified);
8893     if (vmsified) Safefree(vmsified);
8894     return NULL;
8895   }
8896   PerlMem_free(pathified);
8897   if (buf) {
8898     return buf;
8899   }
8900   else if (ts) {
8901     vmslen = strlen(vmsified);
8902     Newx(cp,vmslen+1,char);
8903     memcpy(cp,vmsified,vmslen);
8904     cp[vmslen] = '\0';
8905     Safefree(vmsified);
8906     return cp;
8907   }
8908   else {
8909     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8910     Safefree(vmsified);
8911     return __tovmspath_retbuf;
8912   }
8913
8914 }  /* end of do_tovmspath() */
8915 /*}}}*/
8916 /* External entry points */
8917 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8918   { return do_tovmspath(path,buf,0, NULL); }
8919 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8920   { return do_tovmspath(path,buf,1, NULL); }
8921 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8922   { return do_tovmspath(path,buf,0,utf8_fl); }
8923 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8924   { return do_tovmspath(path,buf,1,utf8_fl); }
8925
8926
8927 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8928 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8929   static char __tounixpath_retbuf[VMS_MAXRSS];
8930   int unixlen;
8931   char *pathified, *unixified, *cp;
8932
8933   if (path == NULL) return NULL;
8934   pathified = PerlMem_malloc(VMS_MAXRSS);
8935   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8936   if (int_pathify_dirspec(path, pathified) == NULL) {
8937     PerlMem_free(pathified);
8938     return NULL;
8939   }
8940
8941   unixified = NULL;
8942   if (buf == NULL) {
8943       Newx(unixified, VMS_MAXRSS, char);
8944   }
8945   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8946     PerlMem_free(pathified);
8947     if (unixified) Safefree(unixified);
8948     return NULL;
8949   }
8950   PerlMem_free(pathified);
8951   if (buf) {
8952     return buf;
8953   }
8954   else if (ts) {
8955     unixlen = strlen(unixified);
8956     Newx(cp,unixlen+1,char);
8957     memcpy(cp,unixified,unixlen);
8958     cp[unixlen] = '\0';
8959     Safefree(unixified);
8960     return cp;
8961   }
8962   else {
8963     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
8964     Safefree(unixified);
8965     return __tounixpath_retbuf;
8966   }
8967
8968 }  /* end of do_tounixpath() */
8969 /*}}}*/
8970 /* External entry points */
8971 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8972   { return do_tounixpath(path,buf,0,NULL); }
8973 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8974   { return do_tounixpath(path,buf,1,NULL); }
8975 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8976   { return do_tounixpath(path,buf,0,utf8_fl); }
8977 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8978   { return do_tounixpath(path,buf,1,utf8_fl); }
8979
8980 /*
8981  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8982  *
8983  *****************************************************************************
8984  *                                                                           *
8985  *  Copyright (C) 1989-1994, 2007 by                                         *
8986  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8987  *                                                                           *
8988  *  Permission is hereby granted for the reproduction of this software       *
8989  *  on condition that this copyright notice is included in source            *
8990  *  distributions of the software.  The code may be modified and             *
8991  *  distributed under the same terms as Perl itself.                         *
8992  *                                                                           *
8993  *  27-Aug-1994 Modified for inclusion in perl5                              *
8994  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8995  *****************************************************************************
8996  */
8997
8998 /*
8999  * getredirection() is intended to aid in porting C programs
9000  * to VMS (Vax-11 C).  The native VMS environment does not support
9001  * '>' and '<' I/O redirection, or command line wild card expansion,
9002  * or a command line pipe mechanism using the '|' AND background
9003  * command execution '&'.  All of these capabilities are provided to any
9004  * C program which calls this procedure as the first thing in the
9005  * main program.
9006  * The piping mechanism will probably work with almost any 'filter' type
9007  * of program.  With suitable modification, it may useful for other
9008  * portability problems as well.
9009  *
9010  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9011  */
9012 struct list_item
9013     {
9014     struct list_item *next;
9015     char *value;
9016     };
9017
9018 static void add_item(struct list_item **head,
9019                      struct list_item **tail,
9020                      char *value,
9021                      int *count);
9022
9023 static void mp_expand_wild_cards(pTHX_ char *item,
9024                                 struct list_item **head,
9025                                 struct list_item **tail,
9026                                 int *count);
9027
9028 static int background_process(pTHX_ int argc, char **argv);
9029
9030 static void pipe_and_fork(pTHX_ char **cmargv);
9031
9032 /*{{{ void getredirection(int *ac, char ***av)*/
9033 static void
9034 mp_getredirection(pTHX_ int *ac, char ***av)
9035 /*
9036  * Process vms redirection arg's.  Exit if any error is seen.
9037  * If getredirection() processes an argument, it is erased
9038  * from the vector.  getredirection() returns a new argc and argv value.
9039  * In the event that a background command is requested (by a trailing "&"),
9040  * this routine creates a background subprocess, and simply exits the program.
9041  *
9042  * Warning: do not try to simplify the code for vms.  The code
9043  * presupposes that getredirection() is called before any data is
9044  * read from stdin or written to stdout.
9045  *
9046  * Normal usage is as follows:
9047  *
9048  *      main(argc, argv)
9049  *      int             argc;
9050  *      char            *argv[];
9051  *      {
9052  *              getredirection(&argc, &argv);
9053  *      }
9054  */
9055 {
9056     int                 argc = *ac;     /* Argument Count         */
9057     char                **argv = *av;   /* Argument Vector        */
9058     char                *ap;            /* Argument pointer       */
9059     int                 j;              /* argv[] index           */
9060     int                 item_count = 0; /* Count of Items in List */
9061     struct list_item    *list_head = 0; /* First Item in List       */
9062     struct list_item    *list_tail;     /* Last Item in List        */
9063     char                *in = NULL;     /* Input File Name          */
9064     char                *out = NULL;    /* Output File Name         */
9065     char                *outmode = "w"; /* Mode to Open Output File */
9066     char                *err = NULL;    /* Error File Name          */
9067     char                *errmode = "w"; /* Mode to Open Error File  */
9068     int                 cmargc = 0;     /* Piped Command Arg Count  */
9069     char                **cmargv = NULL;/* Piped Command Arg Vector */
9070
9071     /*
9072      * First handle the case where the last thing on the line ends with
9073      * a '&'.  This indicates the desire for the command to be run in a
9074      * subprocess, so we satisfy that desire.
9075      */
9076     ap = argv[argc-1];
9077     if (0 == strcmp("&", ap))
9078        exit(background_process(aTHX_ --argc, argv));
9079     if (*ap && '&' == ap[strlen(ap)-1])
9080         {
9081         ap[strlen(ap)-1] = '\0';
9082        exit(background_process(aTHX_ argc, argv));
9083         }
9084     /*
9085      * Now we handle the general redirection cases that involve '>', '>>',
9086      * '<', and pipes '|'.
9087      */
9088     for (j = 0; j < argc; ++j)
9089         {
9090         if (0 == strcmp("<", argv[j]))
9091             {
9092             if (j+1 >= argc)
9093                 {
9094                 fprintf(stderr,"No input file after < on command line");
9095                 exit(LIB$_WRONUMARG);
9096                 }
9097             in = argv[++j];
9098             continue;
9099             }
9100         if ('<' == *(ap = argv[j]))
9101             {
9102             in = 1 + ap;
9103             continue;
9104             }
9105         if (0 == strcmp(">", ap))
9106             {
9107             if (j+1 >= argc)
9108                 {
9109                 fprintf(stderr,"No output file after > on command line");
9110                 exit(LIB$_WRONUMARG);
9111                 }
9112             out = argv[++j];
9113             continue;
9114             }
9115         if ('>' == *ap)
9116             {
9117             if ('>' == ap[1])
9118                 {
9119                 outmode = "a";
9120                 if ('\0' == ap[2])
9121                     out = argv[++j];
9122                 else
9123                     out = 2 + ap;
9124                 }
9125             else
9126                 out = 1 + ap;
9127             if (j >= argc)
9128                 {
9129                 fprintf(stderr,"No output file after > or >> on command line");
9130                 exit(LIB$_WRONUMARG);
9131                 }
9132             continue;
9133             }
9134         if (('2' == *ap) && ('>' == ap[1]))
9135             {
9136             if ('>' == ap[2])
9137                 {
9138                 errmode = "a";
9139                 if ('\0' == ap[3])
9140                     err = argv[++j];
9141                 else
9142                     err = 3 + ap;
9143                 }
9144             else
9145                 if ('\0' == ap[2])
9146                     err = argv[++j];
9147                 else
9148                     err = 2 + ap;
9149             if (j >= argc)
9150                 {
9151                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9152                 exit(LIB$_WRONUMARG);
9153                 }
9154             continue;
9155             }
9156         if (0 == strcmp("|", argv[j]))
9157             {
9158             if (j+1 >= argc)
9159                 {
9160                 fprintf(stderr,"No command into which to pipe on command line");
9161                 exit(LIB$_WRONUMARG);
9162                 }
9163             cmargc = argc-(j+1);
9164             cmargv = &argv[j+1];
9165             argc = j;
9166             continue;
9167             }
9168         if ('|' == *(ap = argv[j]))
9169             {
9170             ++argv[j];
9171             cmargc = argc-j;
9172             cmargv = &argv[j];
9173             argc = j;
9174             continue;
9175             }
9176         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9177         }
9178     /*
9179      * Allocate and fill in the new argument vector, Some Unix's terminate
9180      * the list with an extra null pointer.
9181      */
9182     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9183     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9184     *av = argv;
9185     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9186         argv[j] = list_head->value;
9187     *ac = item_count;
9188     if (cmargv != NULL)
9189         {
9190         if (out != NULL)
9191             {
9192             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9193             exit(LIB$_INVARGORD);
9194             }
9195         pipe_and_fork(aTHX_ cmargv);
9196         }
9197
9198     /* Check for input from a pipe (mailbox) */
9199
9200     if (in == NULL && 1 == isapipe(0))
9201         {
9202         char mbxname[L_tmpnam];
9203         long int bufsize;
9204         long int dvi_item = DVI$_DEVBUFSIZ;
9205         $DESCRIPTOR(mbxnam, "");
9206         $DESCRIPTOR(mbxdevnam, "");
9207
9208         /* Input from a pipe, reopen it in binary mode to disable       */
9209         /* carriage control processing.                                 */
9210
9211         fgetname(stdin, mbxname, 1);
9212         mbxnam.dsc$a_pointer = mbxname;
9213         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9214         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9215         mbxdevnam.dsc$a_pointer = mbxname;
9216         mbxdevnam.dsc$w_length = sizeof(mbxname);
9217         dvi_item = DVI$_DEVNAM;
9218         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9219         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9220         set_errno(0);
9221         set_vaxc_errno(1);
9222         freopen(mbxname, "rb", stdin);
9223         if (errno != 0)
9224             {
9225             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9226             exit(vaxc$errno);
9227             }
9228         }
9229     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9230         {
9231         fprintf(stderr,"Can't open input file %s as stdin",in);
9232         exit(vaxc$errno);
9233         }
9234     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9235         {
9236         fprintf(stderr,"Can't open output file %s as stdout",out);
9237         exit(vaxc$errno);
9238         }
9239         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9240
9241     if (err != NULL) {
9242         if (strcmp(err,"&1") == 0) {
9243             dup2(fileno(stdout), fileno(stderr));
9244             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9245         } else {
9246         FILE *tmperr;
9247         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9248             {
9249             fprintf(stderr,"Can't open error file %s as stderr",err);
9250             exit(vaxc$errno);
9251             }
9252             fclose(tmperr);
9253            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9254                 {
9255                 exit(vaxc$errno);
9256                 }
9257             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9258         }
9259         }
9260 #ifdef ARGPROC_DEBUG
9261     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9262     for (j = 0; j < *ac;  ++j)
9263         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9264 #endif
9265    /* Clear errors we may have hit expanding wildcards, so they don't
9266       show up in Perl's $! later */
9267    set_errno(0); set_vaxc_errno(1);
9268 }  /* end of getredirection() */
9269 /*}}}*/
9270
9271 static void add_item(struct list_item **head,
9272                      struct list_item **tail,
9273                      char *value,
9274                      int *count)
9275 {
9276     if (*head == 0)
9277         {
9278         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9279         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9280         *tail = *head;
9281         }
9282     else {
9283         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9284         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9285         *tail = (*tail)->next;
9286         }
9287     (*tail)->value = value;
9288     ++(*count);
9289 }
9290
9291 static void mp_expand_wild_cards(pTHX_ char *item,
9292                               struct list_item **head,
9293                               struct list_item **tail,
9294                               int *count)
9295 {
9296 int expcount = 0;
9297 unsigned long int context = 0;
9298 int isunix = 0;
9299 int item_len = 0;
9300 char *had_version;
9301 char *had_device;
9302 int had_directory;
9303 char *devdir,*cp;
9304 char *vmsspec;
9305 $DESCRIPTOR(filespec, "");
9306 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9307 $DESCRIPTOR(resultspec, "");
9308 unsigned long int lff_flags = 0;
9309 int sts;
9310 int rms_sts;
9311
9312 #ifdef VMS_LONGNAME_SUPPORT
9313     lff_flags = LIB$M_FIL_LONG_NAMES;
9314 #endif
9315
9316     for (cp = item; *cp; cp++) {
9317         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9318         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9319     }
9320     if (!*cp || isspace(*cp))
9321         {
9322         add_item(head, tail, item, count);
9323         return;
9324         }
9325     else
9326         {
9327      /* "double quoted" wild card expressions pass as is */
9328      /* From DCL that means using e.g.:                  */
9329      /* perl program """perl.*"""                        */
9330      item_len = strlen(item);
9331      if ( '"' == *item && '"' == item[item_len-1] )
9332        {
9333        item++;
9334        item[item_len-2] = '\0';
9335        add_item(head, tail, item, count);
9336        return;
9337        }
9338      }
9339     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9340     resultspec.dsc$b_class = DSC$K_CLASS_D;
9341     resultspec.dsc$a_pointer = NULL;
9342     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9343     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9344     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9345       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9346     if (!isunix || !filespec.dsc$a_pointer)
9347       filespec.dsc$a_pointer = item;
9348     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9349     /*
9350      * Only return version specs, if the caller specified a version
9351      */
9352     had_version = strchr(item, ';');
9353     /*
9354      * Only return device and directory specs, if the caller specified either.
9355      */
9356     had_device = strchr(item, ':');
9357     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9358
9359     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9360                                  (&filespec, &resultspec, &context,
9361                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9362         {
9363         char *string;
9364         char *c;
9365
9366         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9367         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9368         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9369         if (NULL == had_version)
9370             *(strrchr(string, ';')) = '\0';
9371         if ((!had_directory) && (had_device == NULL))
9372             {
9373             if (NULL == (devdir = strrchr(string, ']')))
9374                 devdir = strrchr(string, '>');
9375             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9376             }
9377         /*
9378          * Be consistent with what the C RTL has already done to the rest of
9379          * the argv items and lowercase all of these names.
9380          */
9381         if (!decc_efs_case_preserve) {
9382             for (c = string; *c; ++c)
9383             if (isupper(*c))
9384                 *c = tolower(*c);
9385         }
9386         if (isunix) trim_unixpath(string,item,1);
9387         add_item(head, tail, string, count);
9388         ++expcount;
9389     }
9390     PerlMem_free(vmsspec);
9391     if (sts != RMS$_NMF)
9392         {
9393         set_vaxc_errno(sts);
9394         switch (sts)
9395             {
9396             case RMS$_FNF: case RMS$_DNF:
9397                 set_errno(ENOENT); break;
9398             case RMS$_DIR:
9399                 set_errno(ENOTDIR); break;
9400             case RMS$_DEV:
9401                 set_errno(ENODEV); break;
9402             case RMS$_FNM: case RMS$_SYN:
9403                 set_errno(EINVAL); break;
9404             case RMS$_PRV:
9405                 set_errno(EACCES); break;
9406             default:
9407                 _ckvmssts_noperl(sts);
9408             }
9409         }
9410     if (expcount == 0)
9411         add_item(head, tail, item, count);
9412     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9413     _ckvmssts_noperl(lib$find_file_end(&context));
9414 }
9415
9416 static int child_st[2];/* Event Flag set when child process completes   */
9417
9418 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9419
9420 static unsigned long int exit_handler(void)
9421 {
9422 short iosb[4];
9423
9424     if (0 == child_st[0])
9425         {
9426 #ifdef ARGPROC_DEBUG
9427         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9428 #endif
9429         fflush(stdout);     /* Have to flush pipe for binary data to    */
9430                             /* terminate properly -- <tp@mccall.com>    */
9431         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9432         sys$dassgn(child_chan);
9433         fclose(stdout);
9434         sys$synch(0, child_st);
9435         }
9436     return(1);
9437 }
9438
9439 static void sig_child(int chan)
9440 {
9441 #ifdef ARGPROC_DEBUG
9442     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9443 #endif
9444     if (child_st[0] == 0)
9445         child_st[0] = 1;
9446 }
9447
9448 static struct exit_control_block exit_block =
9449     {
9450     0,
9451     exit_handler,
9452     1,
9453     &exit_block.exit_status,
9454     0
9455     };
9456
9457 static void
9458 pipe_and_fork(pTHX_ char **cmargv)
9459 {
9460     PerlIO *fp;
9461     struct dsc$descriptor_s *vmscmd;
9462     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9463     int sts, j, l, ismcr, quote, tquote = 0;
9464
9465     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9466     vms_execfree(vmscmd);
9467
9468     j = l = 0;
9469     p = subcmd;
9470     q = cmargv[0];
9471     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9472               && toupper(*(q+2)) == 'R' && !*(q+3);
9473
9474     while (q && l < MAX_DCL_LINE_LENGTH) {
9475         if (!*q) {
9476             if (j > 0 && quote) {
9477                 *p++ = '"';
9478                 l++;
9479             }
9480             q = cmargv[++j];
9481             if (q) {
9482                 if (ismcr && j > 1) quote = 1;
9483                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9484                 *p++ = ' ';
9485                 l++;
9486                 if (quote || tquote) {
9487                     *p++ = '"';
9488                     l++;
9489                 }
9490             }
9491         } else {
9492             if ((quote||tquote) && *q == '"') {
9493                 *p++ = '"';
9494                 l++;
9495             }
9496             *p++ = *q++;
9497             l++;
9498         }
9499     }
9500     *p = '\0';
9501
9502     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9503     if (fp == NULL) {
9504         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9505     }
9506 }
9507
9508 static int background_process(pTHX_ int argc, char **argv)
9509 {
9510 char command[MAX_DCL_SYMBOL + 1] = "$";
9511 $DESCRIPTOR(value, "");
9512 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9513 static $DESCRIPTOR(null, "NLA0:");
9514 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9515 char pidstring[80];
9516 $DESCRIPTOR(pidstr, "");
9517 int pid;
9518 unsigned long int flags = 17, one = 1, retsts;
9519 int len;
9520
9521     len = my_strlcat(command, argv[0], sizeof(command));
9522     while (--argc && (len < MAX_DCL_SYMBOL))
9523         {
9524         my_strlcat(command, " \"", sizeof(command));
9525         my_strlcat(command, *(++argv), sizeof(command));
9526         len = my_strlcat(command, "\"", sizeof(command));
9527         }
9528     value.dsc$a_pointer = command;
9529     value.dsc$w_length = strlen(value.dsc$a_pointer);
9530     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9531     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9532     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9533         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9534     }
9535     else {
9536         _ckvmssts_noperl(retsts);
9537     }
9538 #ifdef ARGPROC_DEBUG
9539     PerlIO_printf(Perl_debug_log, "%s\n", command);
9540 #endif
9541     sprintf(pidstring, "%08X", pid);
9542     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9543     pidstr.dsc$a_pointer = pidstring;
9544     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9545     lib$set_symbol(&pidsymbol, &pidstr);
9546     return(SS$_NORMAL);
9547 }
9548 /*}}}*/
9549 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9550
9551
9552 /* OS-specific initialization at image activation (not thread startup) */
9553 /* Older VAXC header files lack these constants */
9554 #ifndef JPI$_RIGHTS_SIZE
9555 #  define JPI$_RIGHTS_SIZE 817
9556 #endif
9557 #ifndef KGB$M_SUBSYSTEM
9558 #  define KGB$M_SUBSYSTEM 0x8
9559 #endif
9560
9561 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9562
9563 /*{{{void vms_image_init(int *, char ***)*/
9564 void
9565 vms_image_init(int *argcp, char ***argvp)
9566 {
9567   int status;
9568   char eqv[LNM$C_NAMLENGTH+1] = "";
9569   unsigned int len, tabct = 8, tabidx = 0;
9570   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9571   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9572   unsigned short int dummy, rlen;
9573   struct dsc$descriptor_s **tabvec;
9574 #if defined(PERL_IMPLICIT_CONTEXT)
9575   pTHX = NULL;
9576 #endif
9577   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9578                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9579                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9580                                  {          0,                0,    0,      0} };
9581
9582 #ifdef KILL_BY_SIGPRC
9583     Perl_csighandler_init();
9584 #endif
9585
9586 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9587     /* This was moved from the pre-image init handler because on threaded */
9588     /* Perl it was always returning 0 for the default value. */
9589     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9590     if (status > 0) {
9591         int s;
9592         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9593         if (s > 0) {
9594             int initial;
9595             initial = decc$feature_get_value(s, 4);
9596             if (initial > 0) {
9597                 /* initial is: 0 if nothing has set the feature */
9598                 /*            -1 if initialized to default */
9599                 /*             1 if set by logical name */
9600                 /*             2 if set by decc$feature_set_value */
9601                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9602
9603                 /* If the value is not valid, force the feature off */
9604                 if (decc_disable_posix_root < 0) {
9605                     decc$feature_set_value(s, 1, 1);
9606                     decc_disable_posix_root = 1;
9607                 }
9608             }
9609             else {
9610                 /* Nothing has asked for it explicitly, so use our own default. */
9611                 decc_disable_posix_root = 1;
9612                 decc$feature_set_value(s, 1, 1);
9613             }
9614         }
9615     }
9616 #endif
9617
9618   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9619   _ckvmssts_noperl(iosb[0]);
9620   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9621     if (iprv[i]) {           /* Running image installed with privs? */
9622       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9623       will_taint = TRUE;
9624       break;
9625     }
9626   }
9627   /* Rights identifiers might trigger tainting as well. */
9628   if (!will_taint && (rlen || rsz)) {
9629     while (rlen < rsz) {
9630       /* We didn't get all the identifiers on the first pass.  Allocate a
9631        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9632        * were needed to hold all identifiers at time of last call; we'll
9633        * allocate that many unsigned long ints), and go back and get 'em.
9634        * If it gave us less than it wanted to despite ample buffer space,
9635        * something's broken.  Is your system missing a system identifier?
9636        */
9637       if (rsz <= jpilist[1].buflen) {
9638          /* Perl_croak accvios when used this early in startup. */
9639          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9640                          rsz, (unsigned long) jpilist[1].buflen,
9641                          "Check your rights database for corruption.\n");
9642          exit(SS$_ABORT);
9643       }
9644       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9645       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9646       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9647       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9648       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9649       _ckvmssts_noperl(iosb[0]);
9650     }
9651     mask = jpilist[1].bufadr;
9652     /* Check attribute flags for each identifier (2nd longword); protected
9653      * subsystem identifiers trigger tainting.
9654      */
9655     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9656       if (mask[i] & KGB$M_SUBSYSTEM) {
9657         will_taint = TRUE;
9658         break;
9659       }
9660     }
9661     if (mask != rlst) PerlMem_free(mask);
9662   }
9663
9664   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9665    * logical, some versions of the CRTL will add a phanthom /000000/
9666    * directory.  This needs to be removed.
9667    */
9668   if (decc_filename_unix_report) {
9669   char * zeros;
9670   int ulen;
9671     ulen = strlen(argvp[0][0]);
9672     if (ulen > 7) {
9673       zeros = strstr(argvp[0][0], "/000000/");
9674       if (zeros != NULL) {
9675         int mlen;
9676         mlen = ulen - (zeros - argvp[0][0]) - 7;
9677         memmove(zeros, &zeros[7], mlen);
9678         ulen = ulen - 7;
9679         argvp[0][0][ulen] = '\0';
9680       }
9681     }
9682     /* It also may have a trailing dot that needs to be removed otherwise
9683      * it will be converted to VMS mode incorrectly.
9684      */
9685     ulen--;
9686     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9687       argvp[0][0][ulen] = '\0';
9688   }
9689
9690   /* We need to use this hack to tell Perl it should run with tainting,
9691    * since its tainting flag may be part of the PL_curinterp struct, which
9692    * hasn't been allocated when vms_image_init() is called.
9693    */
9694   if (will_taint) {
9695     char **newargv, **oldargv;
9696     oldargv = *argvp;
9697     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9698     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9699     newargv[0] = oldargv[0];
9700     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9701     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9702     strcpy(newargv[1], "-T");
9703     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9704     (*argcp)++;
9705     newargv[*argcp] = NULL;
9706     /* We orphan the old argv, since we don't know where it's come from,
9707      * so we don't know how to free it.
9708      */
9709     *argvp = newargv;
9710   }
9711   else {  /* Did user explicitly request tainting? */
9712     int i;
9713     char *cp, **av = *argvp;
9714     for (i = 1; i < *argcp; i++) {
9715       if (*av[i] != '-') break;
9716       for (cp = av[i]+1; *cp; cp++) {
9717         if (*cp == 'T') { will_taint = 1; break; }
9718         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9719                   strchr("DFIiMmx",*cp)) break;
9720       }
9721       if (will_taint) break;
9722     }
9723   }
9724
9725   for (tabidx = 0;
9726        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9727        tabidx++) {
9728     if (!tabidx) {
9729       tabvec = (struct dsc$descriptor_s **)
9730             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9731       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9732     }
9733     else if (tabidx >= tabct) {
9734       tabct += 8;
9735       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9736       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9737     }
9738     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9739     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9740     tabvec[tabidx]->dsc$w_length  = 0;
9741     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9742     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9743     tabvec[tabidx]->dsc$a_pointer = NULL;
9744     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9745   }
9746   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9747
9748   getredirection(argcp,argvp);
9749 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9750   {
9751 # include <reentrancy.h>
9752   decc$set_reentrancy(C$C_MULTITHREAD);
9753   }
9754 #endif
9755   return;
9756 }
9757 /*}}}*/
9758
9759
9760 /* trim_unixpath()
9761  * Trim Unix-style prefix off filespec, so it looks like what a shell
9762  * glob expansion would return (i.e. from specified prefix on, not
9763  * full path).  Note that returned filespec is Unix-style, regardless
9764  * of whether input filespec was VMS-style or Unix-style.
9765  *
9766  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9767  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9768  * vector of options; at present, only bit 0 is used, and if set tells
9769  * trim unixpath to try the current default directory as a prefix when
9770  * presented with a possibly ambiguous ... wildcard.
9771  *
9772  * Returns !=0 on success, with trimmed filespec replacing contents of
9773  * fspec, and 0 on failure, with contents of fpsec unchanged.
9774  */
9775 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9776 int
9777 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9778 {
9779   char *unixified, *unixwild,
9780        *template, *base, *end, *cp1, *cp2;
9781   register int tmplen, reslen = 0, dirs = 0;
9782
9783   if (!wildspec || !fspec) return 0;
9784
9785   unixwild = PerlMem_malloc(VMS_MAXRSS);
9786   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9787   template = unixwild;
9788   if (strpbrk(wildspec,"]>:") != NULL) {
9789     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9790         PerlMem_free(unixwild);
9791         return 0;
9792     }
9793   }
9794   else {
9795     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9796   }
9797   unixified = PerlMem_malloc(VMS_MAXRSS);
9798   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9799   if (strpbrk(fspec,"]>:") != NULL) {
9800     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9801         PerlMem_free(unixwild);
9802         PerlMem_free(unixified);
9803         return 0;
9804     }
9805     else base = unixified;
9806     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9807      * check to see that final result fits into (isn't longer than) fspec */
9808     reslen = strlen(fspec);
9809   }
9810   else base = fspec;
9811
9812   /* No prefix or absolute path on wildcard, so nothing to remove */
9813   if (!*template || *template == '/') {
9814     PerlMem_free(unixwild);
9815     if (base == fspec) {
9816         PerlMem_free(unixified);
9817         return 1;
9818     }
9819     tmplen = strlen(unixified);
9820     if (tmplen > reslen) {
9821         PerlMem_free(unixified);
9822         return 0;  /* not enough space */
9823     }
9824     /* Copy unixified resultant, including trailing NUL */
9825     memmove(fspec,unixified,tmplen+1);
9826     PerlMem_free(unixified);
9827     return 1;
9828   }
9829
9830   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9831   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9832     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9833     for (cp1 = end ;cp1 >= base; cp1--)
9834       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9835         { cp1++; break; }
9836     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9837     PerlMem_free(unixified);
9838     PerlMem_free(unixwild);
9839     return 1;
9840   }
9841   else {
9842     char *tpl, *lcres;
9843     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9844     int ells = 1, totells, segdirs, match;
9845     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9846                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9847
9848     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9849     totells = ells;
9850     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9851     tpl = PerlMem_malloc(VMS_MAXRSS);
9852     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9853     if (ellipsis == template && opts & 1) {
9854       /* Template begins with an ellipsis.  Since we can't tell how many
9855        * directory names at the front of the resultant to keep for an
9856        * arbitrary starting point, we arbitrarily choose the current
9857        * default directory as a starting point.  If it's there as a prefix,
9858        * clip it off.  If not, fall through and act as if the leading
9859        * ellipsis weren't there (i.e. return shortest possible path that
9860        * could match template).
9861        */
9862       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9863           PerlMem_free(tpl);
9864           PerlMem_free(unixified);
9865           PerlMem_free(unixwild);
9866           return 0;
9867       }
9868       if (!decc_efs_case_preserve) {
9869         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9870           if (_tolower(*cp1) != _tolower(*cp2)) break;
9871       }
9872       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9873       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9874       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9875         memmove(fspec,cp2+1,end - cp2);
9876         PerlMem_free(tpl);
9877         PerlMem_free(unixified);
9878         PerlMem_free(unixwild);
9879         return 1;
9880       }
9881     }
9882     /* First off, back up over constant elements at end of path */
9883     if (dirs) {
9884       for (front = end ; front >= base; front--)
9885          if (*front == '/' && !dirs--) { front++; break; }
9886     }
9887     lcres = PerlMem_malloc(VMS_MAXRSS);
9888     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9889     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9890          cp1++,cp2++) {
9891             if (!decc_efs_case_preserve) {
9892                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9893             }
9894             else {
9895                 *cp2 = *cp1;
9896             }
9897     }
9898     if (cp1 != '\0') {
9899         PerlMem_free(tpl);
9900         PerlMem_free(unixified);
9901         PerlMem_free(unixwild);
9902         PerlMem_free(lcres);
9903         return 0;  /* Path too long. */
9904     }
9905     lcend = cp2;
9906     *cp2 = '\0';  /* Pick up with memcpy later */
9907     lcfront = lcres + (front - base);
9908     /* Now skip over each ellipsis and try to match the path in front of it. */
9909     while (ells--) {
9910       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9911         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9912             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9913       if (cp1 < template) break; /* template started with an ellipsis */
9914       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9915         ellipsis = cp1; continue;
9916       }
9917       wilddsc.dsc$a_pointer = tpl;
9918       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9919       nextell = cp1;
9920       for (segdirs = 0, cp2 = tpl;
9921            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9922            cp1++, cp2++) {
9923          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9924          else {
9925             if (!decc_efs_case_preserve) {
9926               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9927             }
9928             else {
9929               *cp2 = *cp1;  /* else preserve case for match */
9930             }
9931          }
9932          if (*cp2 == '/') segdirs++;
9933       }
9934       if (cp1 != ellipsis - 1) {
9935           PerlMem_free(tpl);
9936           PerlMem_free(unixified);
9937           PerlMem_free(unixwild);
9938           PerlMem_free(lcres);
9939           return 0; /* Path too long */
9940       }
9941       /* Back up at least as many dirs as in template before matching */
9942       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9943         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9944       for (match = 0; cp1 > lcres;) {
9945         resdsc.dsc$a_pointer = cp1;
9946         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9947           match++;
9948           if (match == 1) lcfront = cp1;
9949         }
9950         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9951       }
9952       if (!match) {
9953         PerlMem_free(tpl);
9954         PerlMem_free(unixified);
9955         PerlMem_free(unixwild);
9956         PerlMem_free(lcres);
9957         return 0;  /* Can't find prefix ??? */
9958       }
9959       if (match > 1 && opts & 1) {
9960         /* This ... wildcard could cover more than one set of dirs (i.e.
9961          * a set of similar dir names is repeated).  If the template
9962          * contains more than 1 ..., upstream elements could resolve the
9963          * ambiguity, but it's not worth a full backtracking setup here.
9964          * As a quick heuristic, clip off the current default directory
9965          * if it's present to find the trimmed spec, else use the
9966          * shortest string that this ... could cover.
9967          */
9968         char def[NAM$C_MAXRSS+1], *st;
9969
9970         if (getcwd(def, sizeof def,0) == NULL) {
9971             PerlMem_free(unixified);
9972             PerlMem_free(unixwild);
9973             PerlMem_free(lcres);
9974             PerlMem_free(tpl);
9975             return 0;
9976         }
9977         if (!decc_efs_case_preserve) {
9978           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9979             if (_tolower(*cp1) != _tolower(*cp2)) break;
9980         }
9981         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9982         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9983         if (*cp1 == '\0' && *cp2 == '/') {
9984           memmove(fspec,cp2+1,end - cp2);
9985           PerlMem_free(tpl);
9986           PerlMem_free(unixified);
9987           PerlMem_free(unixwild);
9988           PerlMem_free(lcres);
9989           return 1;
9990         }
9991         /* Nope -- stick with lcfront from above and keep going. */
9992       }
9993     }
9994     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9995     PerlMem_free(tpl);
9996     PerlMem_free(unixified);
9997     PerlMem_free(unixwild);
9998     PerlMem_free(lcres);
9999     return 1;
10000   }
10001
10002 }  /* end of trim_unixpath() */
10003 /*}}}*/
10004
10005
10006 /*
10007  *  VMS readdir() routines.
10008  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10009  *
10010  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10011  *  Minor modifications to original routines.
10012  */
10013
10014 /* readdir may have been redefined by reentr.h, so make sure we get
10015  * the local version for what we do here.
10016  */
10017 #ifdef readdir
10018 # undef readdir
10019 #endif
10020 #if !defined(PERL_IMPLICIT_CONTEXT)
10021 # define readdir Perl_readdir
10022 #else
10023 # define readdir(a) Perl_readdir(aTHX_ a)
10024 #endif
10025
10026     /* Number of elements in vms_versions array */
10027 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10028
10029 /*
10030  *  Open a directory, return a handle for later use.
10031  */
10032 /*{{{ DIR *opendir(char*name) */
10033 DIR *
10034 Perl_opendir(pTHX_ const char *name)
10035 {
10036     DIR *dd;
10037     char *dir;
10038     Stat_t sb;
10039
10040     Newx(dir, VMS_MAXRSS, char);
10041     if (int_tovmspath(name, dir, NULL) == NULL) {
10042       Safefree(dir);
10043       return NULL;
10044     }
10045     /* Check access before stat; otherwise stat does not
10046      * accurately report whether it's a directory.
10047      */
10048     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10049       /* cando_by_name has already set errno */
10050       Safefree(dir);
10051       return NULL;
10052     }
10053     if (flex_stat(dir,&sb) == -1) return NULL;
10054     if (!S_ISDIR(sb.st_mode)) {
10055       Safefree(dir);
10056       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10057       return NULL;
10058     }
10059     /* Get memory for the handle, and the pattern. */
10060     Newx(dd,1,DIR);
10061     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10062
10063     /* Fill in the fields; mainly playing with the descriptor. */
10064     sprintf(dd->pattern, "%s*.*",dir);
10065     Safefree(dir);
10066     dd->context = 0;
10067     dd->count = 0;
10068     dd->flags = 0;
10069     /* By saying we always want the result of readdir() in unix format, we
10070      * are really saying we want all the escapes removed.  Otherwise the caller,
10071      * having no way to know whether it's already in VMS format, might send it
10072      * through tovmsspec again, thus double escaping.
10073      */
10074     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10075     dd->pat.dsc$a_pointer = dd->pattern;
10076     dd->pat.dsc$w_length = strlen(dd->pattern);
10077     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10078     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10079 #if defined(USE_ITHREADS)
10080     Newx(dd->mutex,1,perl_mutex);
10081     MUTEX_INIT( (perl_mutex *) dd->mutex );
10082 #else
10083     dd->mutex = NULL;
10084 #endif
10085
10086     return dd;
10087 }  /* end of opendir() */
10088 /*}}}*/
10089
10090 /*
10091  *  Set the flag to indicate we want versions or not.
10092  */
10093 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10094 void
10095 vmsreaddirversions(DIR *dd, int flag)
10096 {
10097     if (flag)
10098         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10099     else
10100         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10101 }
10102 /*}}}*/
10103
10104 /*
10105  *  Free up an opened directory.
10106  */
10107 /*{{{ void closedir(DIR *dd)*/
10108 void
10109 Perl_closedir(DIR *dd)
10110 {
10111     int sts;
10112
10113     sts = lib$find_file_end(&dd->context);
10114     Safefree(dd->pattern);
10115 #if defined(USE_ITHREADS)
10116     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10117     Safefree(dd->mutex);
10118 #endif
10119     Safefree(dd);
10120 }
10121 /*}}}*/
10122
10123 /*
10124  *  Collect all the version numbers for the current file.
10125  */
10126 static void
10127 collectversions(pTHX_ DIR *dd)
10128 {
10129     struct dsc$descriptor_s     pat;
10130     struct dsc$descriptor_s     res;
10131     struct dirent *e;
10132     char *p, *text, *buff;
10133     int i;
10134     unsigned long context, tmpsts;
10135
10136     /* Convenient shorthand. */
10137     e = &dd->entry;
10138
10139     /* Add the version wildcard, ignoring the "*.*" put on before */
10140     i = strlen(dd->pattern);
10141     Newx(text,i + e->d_namlen + 3,char);
10142     my_strlcpy(text, dd->pattern, i + 1);
10143     sprintf(&text[i - 3], "%s;*", e->d_name);
10144
10145     /* Set up the pattern descriptor. */
10146     pat.dsc$a_pointer = text;
10147     pat.dsc$w_length = i + e->d_namlen - 1;
10148     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10149     pat.dsc$b_class = DSC$K_CLASS_S;
10150
10151     /* Set up result descriptor. */
10152     Newx(buff, VMS_MAXRSS, char);
10153     res.dsc$a_pointer = buff;
10154     res.dsc$w_length = VMS_MAXRSS - 1;
10155     res.dsc$b_dtype = DSC$K_DTYPE_T;
10156     res.dsc$b_class = DSC$K_CLASS_S;
10157
10158     /* Read files, collecting versions. */
10159     for (context = 0, e->vms_verscount = 0;
10160          e->vms_verscount < VERSIZE(e);
10161          e->vms_verscount++) {
10162         unsigned long rsts;
10163         unsigned long flags = 0;
10164
10165 #ifdef VMS_LONGNAME_SUPPORT
10166         flags = LIB$M_FIL_LONG_NAMES;
10167 #endif
10168         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10169         if (tmpsts == RMS$_NMF || context == 0) break;
10170         _ckvmssts(tmpsts);
10171         buff[VMS_MAXRSS - 1] = '\0';
10172         if ((p = strchr(buff, ';')))
10173             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10174         else
10175             e->vms_versions[e->vms_verscount] = -1;
10176     }
10177
10178     _ckvmssts(lib$find_file_end(&context));
10179     Safefree(text);
10180     Safefree(buff);
10181
10182 }  /* end of collectversions() */
10183
10184 /*
10185  *  Read the next entry from the directory.
10186  */
10187 /*{{{ struct dirent *readdir(DIR *dd)*/
10188 struct dirent *
10189 Perl_readdir(pTHX_ DIR *dd)
10190 {
10191     struct dsc$descriptor_s     res;
10192     char *p, *buff;
10193     unsigned long int tmpsts;
10194     unsigned long rsts;
10195     unsigned long flags = 0;
10196     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10197     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10198
10199     /* Set up result descriptor, and get next file. */
10200     Newx(buff, VMS_MAXRSS, char);
10201     res.dsc$a_pointer = buff;
10202     res.dsc$w_length = VMS_MAXRSS - 1;
10203     res.dsc$b_dtype = DSC$K_DTYPE_T;
10204     res.dsc$b_class = DSC$K_CLASS_S;
10205
10206 #ifdef VMS_LONGNAME_SUPPORT
10207     flags = LIB$M_FIL_LONG_NAMES;
10208 #endif
10209
10210     tmpsts = lib$find_file
10211         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10212     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10213     if (!(tmpsts & 1)) {
10214       set_vaxc_errno(tmpsts);
10215       switch (tmpsts) {
10216         case RMS$_PRV:
10217           set_errno(EACCES); break;
10218         case RMS$_DEV:
10219           set_errno(ENODEV); break;
10220         case RMS$_DIR:
10221           set_errno(ENOTDIR); break;
10222         case RMS$_FNF: case RMS$_DNF:
10223           set_errno(ENOENT); break;
10224         default:
10225           set_errno(EVMSERR);
10226       }
10227       Safefree(buff);
10228       return NULL;
10229     }
10230     dd->count++;
10231     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10232     buff[res.dsc$w_length] = '\0';
10233     p = buff + res.dsc$w_length;
10234     while (--p >= buff) if (!isspace(*p)) break;
10235     *p = '\0';
10236     if (!decc_efs_case_preserve) {
10237       for (p = buff; *p; p++) *p = _tolower(*p);
10238     }
10239
10240     /* Skip any directory component and just copy the name. */
10241     sts = vms_split_path
10242        (buff,
10243         &v_spec,
10244         &v_len,
10245         &r_spec,
10246         &r_len,
10247         &d_spec,
10248         &d_len,
10249         &n_spec,
10250         &n_len,
10251         &e_spec,
10252         &e_len,
10253         &vs_spec,
10254         &vs_len);
10255
10256     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10257
10258         /* In Unix report mode, remove the ".dir;1" from the name */
10259         /* if it is a real directory. */
10260         if (decc_filename_unix_report || decc_efs_charset) {
10261             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10262                 Stat_t statbuf;
10263                 int ret_sts;
10264
10265                 ret_sts = flex_lstat(buff, &statbuf);
10266                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10267                     e_len = 0;
10268                     e_spec[0] = 0;
10269                 }
10270             }
10271         }
10272
10273         /* Drop NULL extensions on UNIX file specification */
10274         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10275             e_len = 0;
10276             e_spec[0] = '\0';
10277         }
10278     }
10279
10280     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10281     dd->entry.d_name[n_len + e_len] = '\0';
10282     dd->entry.d_namlen = strlen(dd->entry.d_name);
10283
10284     /* Convert the filename to UNIX format if needed */
10285     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10286
10287         /* Translate the encoded characters. */
10288         /* Fixme: Unicode handling could result in embedded 0 characters */
10289         if (strchr(dd->entry.d_name, '^') != NULL) {
10290             char new_name[256];
10291             char * q;
10292             p = dd->entry.d_name;
10293             q = new_name;
10294             while (*p != 0) {
10295                 int inchars_read, outchars_added;
10296                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10297                 p += inchars_read;
10298                 q += outchars_added;
10299                 /* fix-me */
10300                 /* if outchars_added > 1, then this is a wide file specification */
10301                 /* Wide file specifications need to be passed in Perl */
10302                 /* counted strings apparently with a Unicode flag */
10303             }
10304             *q = 0;
10305             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10306         }
10307     }
10308
10309     dd->entry.vms_verscount = 0;
10310     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10311     Safefree(buff);
10312     return &dd->entry;
10313
10314 }  /* end of readdir() */
10315 /*}}}*/
10316
10317 /*
10318  *  Read the next entry from the directory -- thread-safe version.
10319  */
10320 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10321 int
10322 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10323 {
10324     int retval;
10325
10326     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10327
10328     entry = readdir(dd);
10329     *result = entry;
10330     retval = ( *result == NULL ? errno : 0 );
10331
10332     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10333
10334     return retval;
10335
10336 }  /* end of readdir_r() */
10337 /*}}}*/
10338
10339 /*
10340  *  Return something that can be used in a seekdir later.
10341  */
10342 /*{{{ long telldir(DIR *dd)*/
10343 long
10344 Perl_telldir(DIR *dd)
10345 {
10346     return dd->count;
10347 }
10348 /*}}}*/
10349
10350 /*
10351  *  Return to a spot where we used to be.  Brute force.
10352  */
10353 /*{{{ void seekdir(DIR *dd,long count)*/
10354 void
10355 Perl_seekdir(pTHX_ DIR *dd, long count)
10356 {
10357     int old_flags;
10358
10359     /* If we haven't done anything yet... */
10360     if (dd->count == 0)
10361         return;
10362
10363     /* Remember some state, and clear it. */
10364     old_flags = dd->flags;
10365     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10366     _ckvmssts(lib$find_file_end(&dd->context));
10367     dd->context = 0;
10368
10369     /* The increment is in readdir(). */
10370     for (dd->count = 0; dd->count < count; )
10371         readdir(dd);
10372
10373     dd->flags = old_flags;
10374
10375 }  /* end of seekdir() */
10376 /*}}}*/
10377
10378 /* VMS subprocess management
10379  *
10380  * my_vfork() - just a vfork(), after setting a flag to record that
10381  * the current script is trying a Unix-style fork/exec.
10382  *
10383  * vms_do_aexec() and vms_do_exec() are called in response to the
10384  * perl 'exec' function.  If this follows a vfork call, then they
10385  * call out the regular perl routines in doio.c which do an
10386  * execvp (for those who really want to try this under VMS).
10387  * Otherwise, they do exactly what the perl docs say exec should
10388  * do - terminate the current script and invoke a new command
10389  * (See below for notes on command syntax.)
10390  *
10391  * do_aspawn() and do_spawn() implement the VMS side of the perl
10392  * 'system' function.
10393  *
10394  * Note on command arguments to perl 'exec' and 'system': When handled
10395  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10396  * are concatenated to form a DCL command string.  If the first non-numeric
10397  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10398  * the command string is handed off to DCL directly.  Otherwise,
10399  * the first token of the command is taken as the filespec of an image
10400  * to run.  The filespec is expanded using a default type of '.EXE' and
10401  * the process defaults for device, directory, etc., and if found, the resultant
10402  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10403  * the command string as parameters.  This is perhaps a bit complicated,
10404  * but I hope it will form a happy medium between what VMS folks expect
10405  * from lib$spawn and what Unix folks expect from exec.
10406  */
10407
10408 static int vfork_called;
10409
10410 /*{{{int my_vfork(void)*/
10411 int
10412 my_vfork(void)
10413 {
10414   vfork_called++;
10415   return vfork();
10416 }
10417 /*}}}*/
10418
10419
10420 static void
10421 vms_execfree(struct dsc$descriptor_s *vmscmd)
10422 {
10423   if (vmscmd) {
10424       if (vmscmd->dsc$a_pointer) {
10425           PerlMem_free(vmscmd->dsc$a_pointer);
10426       }
10427       PerlMem_free(vmscmd);
10428   }
10429 }
10430
10431 static char *
10432 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10433 {
10434   char *junk, *tmps = NULL;
10435   register size_t cmdlen = 0;
10436   size_t rlen;
10437   register SV **idx;
10438   STRLEN n_a;
10439
10440   idx = mark;
10441   if (really) {
10442     tmps = SvPV(really,rlen);
10443     if (*tmps) {
10444       cmdlen += rlen + 1;
10445       idx++;
10446     }
10447   }
10448
10449   for (idx++; idx <= sp; idx++) {
10450     if (*idx) {
10451       junk = SvPVx(*idx,rlen);
10452       cmdlen += rlen ? rlen + 1 : 0;
10453     }
10454   }
10455   Newx(PL_Cmd, cmdlen+1, char);
10456
10457   if (tmps && *tmps) {
10458     my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10459     mark++;
10460   }
10461   else *PL_Cmd = '\0';
10462   while (++mark <= sp) {
10463     if (*mark) {
10464       char *s = SvPVx(*mark,n_a);
10465       if (!*s) continue;
10466       if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10467       my_strlcat(PL_Cmd, s, cmdlen+1);
10468     }
10469   }
10470   return PL_Cmd;
10471
10472 }  /* end of setup_argstr() */
10473
10474
10475 static unsigned long int
10476 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10477                    struct dsc$descriptor_s **pvmscmd)
10478 {
10479   char * vmsspec;
10480   char * resspec;
10481   char image_name[NAM$C_MAXRSS+1];
10482   char image_argv[NAM$C_MAXRSS+1];
10483   $DESCRIPTOR(defdsc,".EXE");
10484   $DESCRIPTOR(defdsc2,".");
10485   struct dsc$descriptor_s resdsc;
10486   struct dsc$descriptor_s *vmscmd;
10487   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10488   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10489   register char *s, *rest, *cp, *wordbreak;
10490   char * cmd;
10491   int cmdlen;
10492   register int isdcl;
10493
10494   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10495   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10496
10497   /* vmsspec is a DCL command buffer, not just a filename */
10498   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10499   if (vmsspec == NULL)
10500       _ckvmssts_noperl(SS$_INSFMEM);
10501
10502   resspec = PerlMem_malloc(VMS_MAXRSS);
10503   if (resspec == NULL)
10504       _ckvmssts_noperl(SS$_INSFMEM);
10505
10506   /* Make a copy for modification */
10507   cmdlen = strlen(incmd);
10508   cmd = PerlMem_malloc(cmdlen+1);
10509   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10510   my_strlcpy(cmd, incmd, cmdlen + 1);
10511   image_name[0] = 0;
10512   image_argv[0] = 0;
10513
10514   resdsc.dsc$a_pointer = resspec;
10515   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10516   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10517   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10518
10519   vmscmd->dsc$a_pointer = NULL;
10520   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10521   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10522   vmscmd->dsc$w_length = 0;
10523   if (pvmscmd) *pvmscmd = vmscmd;
10524
10525   if (suggest_quote) *suggest_quote = 0;
10526
10527   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10528     PerlMem_free(cmd);
10529     PerlMem_free(vmsspec);
10530     PerlMem_free(resspec);
10531     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10532   }
10533
10534   s = cmd;
10535
10536   while (*s && isspace(*s)) s++;
10537
10538   if (*s == '@' || *s == '$') {
10539     vmsspec[0] = *s;  rest = s + 1;
10540     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10541   }
10542   else { cp = vmsspec; rest = s; }
10543   if (*rest == '.' || *rest == '/') {
10544     char *cp2;
10545     for (cp2 = resspec;
10546          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10547          rest++, cp2++) *cp2 = *rest;
10548     *cp2 = '\0';
10549     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10550       s = vmsspec;
10551
10552       /* When a UNIX spec with no file type is translated to VMS, */
10553       /* A trailing '.' is appended under ODS-5 rules.            */
10554       /* Here we do not want that trailing "." as it prevents     */
10555       /* Looking for a implied ".exe" type. */
10556       if (decc_efs_charset) {
10557           int i;
10558           i = strlen(vmsspec);
10559           if (vmsspec[i-1] == '.') {
10560               vmsspec[i-1] = '\0';
10561           }
10562       }
10563
10564       if (*rest) {
10565         for (cp2 = vmsspec + strlen(vmsspec);
10566              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10567              rest++, cp2++) *cp2 = *rest;
10568         *cp2 = '\0';
10569       }
10570     }
10571   }
10572   /* Intuit whether verb (first word of cmd) is a DCL command:
10573    *   - if first nonspace char is '@', it's a DCL indirection
10574    * otherwise
10575    *   - if verb contains a filespec separator, it's not a DCL command
10576    *   - if it doesn't, caller tells us whether to default to a DCL
10577    *     command, or to a local image unless told it's DCL (by leading '$')
10578    */
10579   if (*s == '@') {
10580       isdcl = 1;
10581       if (suggest_quote) *suggest_quote = 1;
10582   } else {
10583     register char *filespec = strpbrk(s,":<[.;");
10584     rest = wordbreak = strpbrk(s," \"\t/");
10585     if (!wordbreak) wordbreak = s + strlen(s);
10586     if (*s == '$') check_img = 0;
10587     if (filespec && (filespec < wordbreak)) isdcl = 0;
10588     else isdcl = !check_img;
10589   }
10590
10591   if (!isdcl) {
10592     int rsts;
10593     imgdsc.dsc$a_pointer = s;
10594     imgdsc.dsc$w_length = wordbreak - s;
10595     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10596     if (!(retsts&1)) {
10597         _ckvmssts_noperl(lib$find_file_end(&cxt));
10598         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10599       if (!(retsts & 1) && *s == '$') {
10600         _ckvmssts_noperl(lib$find_file_end(&cxt));
10601         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10602         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10603         if (!(retsts&1)) {
10604           _ckvmssts_noperl(lib$find_file_end(&cxt));
10605           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10606         }
10607       }
10608     }
10609     _ckvmssts_noperl(lib$find_file_end(&cxt));
10610
10611     if (retsts & 1) {
10612       FILE *fp;
10613       s = resspec;
10614       while (*s && !isspace(*s)) s++;
10615       *s = '\0';
10616
10617       /* check that it's really not DCL with no file extension */
10618       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10619       if (fp) {
10620         char b[256] = {0,0,0,0};
10621         read(fileno(fp), b, 256);
10622         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10623         if (isdcl) {
10624           int shebang_len;
10625
10626           /* Check for script */
10627           shebang_len = 0;
10628           if ((b[0] == '#') && (b[1] == '!'))
10629              shebang_len = 2;
10630 #ifdef ALTERNATE_SHEBANG
10631           else {
10632             shebang_len = strlen(ALTERNATE_SHEBANG);
10633             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10634               char * perlstr;
10635                 perlstr = strstr("perl",b);
10636                 if (perlstr == NULL)
10637                   shebang_len = 0;
10638             }
10639             else
10640               shebang_len = 0;
10641           }
10642 #endif
10643
10644           if (shebang_len > 0) {
10645           int i;
10646           int j;
10647           char tmpspec[NAM$C_MAXRSS + 1];
10648
10649             i = shebang_len;
10650              /* Image is following after white space */
10651             /*--------------------------------------*/
10652             while (isprint(b[i]) && isspace(b[i]))
10653                 i++;
10654
10655             j = 0;
10656             while (isprint(b[i]) && !isspace(b[i])) {
10657                 tmpspec[j++] = b[i++];
10658                 if (j >= NAM$C_MAXRSS)
10659                    break;
10660             }
10661             tmpspec[j] = '\0';
10662
10663              /* There may be some default parameters to the image */
10664             /*---------------------------------------------------*/
10665             j = 0;
10666             while (isprint(b[i])) {
10667                 image_argv[j++] = b[i++];
10668                 if (j >= NAM$C_MAXRSS)
10669                    break;
10670             }
10671             while ((j > 0) && !isprint(image_argv[j-1]))
10672                 j--;
10673             image_argv[j] = 0;
10674
10675             /* It will need to be converted to VMS format and validated */
10676             if (tmpspec[0] != '\0') {
10677               char * iname;
10678
10679                /* Try to find the exact program requested to be run */
10680               /*---------------------------------------------------*/
10681               iname = int_rmsexpand
10682                  (tmpspec, image_name, ".exe",
10683                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10684               if (iname != NULL) {
10685                 if (cando_by_name_int
10686                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10687                   /* MCR prefix needed */
10688                   isdcl = 0;
10689                 }
10690                 else {
10691                    /* Try again with a null type */
10692                   /*----------------------------*/
10693                   iname = int_rmsexpand
10694                     (tmpspec, image_name, ".",
10695                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10696                   if (iname != NULL) {
10697                     if (cando_by_name_int
10698                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10699                       /* MCR prefix needed */
10700                       isdcl = 0;
10701                     }
10702                   }
10703                 }
10704
10705                  /* Did we find the image to run the script? */
10706                 /*------------------------------------------*/
10707                 if (isdcl) {
10708                   char *tchr;
10709
10710                    /* Assume DCL or foreign command exists */
10711                   /*--------------------------------------*/
10712                   tchr = strrchr(tmpspec, '/');
10713                   if (tchr != NULL) {
10714                     tchr++;
10715                   }
10716                   else {
10717                     tchr = tmpspec;
10718                   }
10719                   my_strlcpy(image_name, tchr, sizeof(image_name));
10720                 }
10721               }
10722             }
10723           }
10724         }
10725         fclose(fp);
10726       }
10727       if (check_img && isdcl) {
10728           PerlMem_free(cmd);
10729           PerlMem_free(resspec);
10730           PerlMem_free(vmsspec);
10731           return RMS$_FNF;
10732       }
10733
10734       if (cando_by_name(S_IXUSR,0,resspec)) {
10735         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10736         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10737         if (!isdcl) {
10738             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10739             if (image_name[0] != 0) {
10740                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10741                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10742             }
10743         } else if (image_name[0] != 0) {
10744             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10745             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10746         } else {
10747             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10748         }
10749         if (suggest_quote) *suggest_quote = 1;
10750
10751         /* If there is an image name, use original command */
10752         if (image_name[0] == 0)
10753             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10754         else {
10755             rest = cmd;
10756             while (*rest && isspace(*rest)) rest++;
10757         }
10758
10759         if (image_argv[0] != 0) {
10760           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10761           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10762         }
10763         if (rest) {
10764            int rest_len;
10765            int vmscmd_len;
10766
10767            rest_len = strlen(rest);
10768            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10769            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10770               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10771            else
10772              retsts = CLI$_BUFOVF;
10773         }
10774         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10775         PerlMem_free(cmd);
10776         PerlMem_free(vmsspec);
10777         PerlMem_free(resspec);
10778         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10779       }
10780       else
10781         retsts = RMS$_PRV;
10782     }
10783   }
10784   /* It's either a DCL command or we couldn't find a suitable image */
10785   vmscmd->dsc$w_length = strlen(cmd);
10786
10787   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10788   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10789
10790   PerlMem_free(cmd);
10791   PerlMem_free(resspec);
10792   PerlMem_free(vmsspec);
10793
10794   /* check if it's a symbol (for quoting purposes) */
10795   if (suggest_quote && !*suggest_quote) {
10796     int iss;
10797     char equiv[LNM$C_NAMLENGTH];
10798     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10799     eqvdsc.dsc$a_pointer = equiv;
10800
10801     iss = lib$get_symbol(vmscmd,&eqvdsc);
10802     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10803   }
10804   if (!(retsts & 1)) {
10805     /* just hand off status values likely to be due to user error */
10806     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10807         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10808        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10809     else { _ckvmssts_noperl(retsts); }
10810   }
10811
10812   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10813
10814 }  /* end of setup_cmddsc() */
10815
10816
10817 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10818 bool
10819 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10820 {
10821 bool exec_sts;
10822 char * cmd;
10823
10824   if (sp > mark) {
10825     if (vfork_called) {           /* this follows a vfork - act Unixish */
10826       vfork_called--;
10827       if (vfork_called < 0) {
10828         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10829         vfork_called = 0;
10830       }
10831       else return do_aexec(really,mark,sp);
10832     }
10833                                            /* no vfork - act VMSish */
10834     cmd = setup_argstr(aTHX_ really,mark,sp);
10835     exec_sts = vms_do_exec(cmd);
10836     Safefree(cmd);  /* Clean up from setup_argstr() */
10837     return exec_sts;
10838   }
10839
10840   return FALSE;
10841 }  /* end of vms_do_aexec() */
10842 /*}}}*/
10843
10844 /* {{{bool vms_do_exec(char *cmd) */
10845 bool
10846 Perl_vms_do_exec(pTHX_ const char *cmd)
10847 {
10848   struct dsc$descriptor_s *vmscmd;
10849
10850   if (vfork_called) {             /* this follows a vfork - act Unixish */
10851     vfork_called--;
10852     if (vfork_called < 0) {
10853       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10854       vfork_called = 0;
10855     }
10856     else return do_exec(cmd);
10857   }
10858
10859   {                               /* no vfork - act VMSish */
10860     unsigned long int retsts;
10861
10862     TAINT_ENV();
10863     TAINT_PROPER("exec");
10864     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10865       retsts = lib$do_command(vmscmd);
10866
10867     switch (retsts) {
10868       case RMS$_FNF: case RMS$_DNF:
10869         set_errno(ENOENT); break;
10870       case RMS$_DIR:
10871         set_errno(ENOTDIR); break;
10872       case RMS$_DEV:
10873         set_errno(ENODEV); break;
10874       case RMS$_PRV:
10875         set_errno(EACCES); break;
10876       case RMS$_SYN:
10877         set_errno(EINVAL); break;
10878       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10879         set_errno(E2BIG); break;
10880       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10881         _ckvmssts_noperl(retsts); /* fall through */
10882       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10883         set_errno(EVMSERR);
10884     }
10885     set_vaxc_errno(retsts);
10886     if (ckWARN(WARN_EXEC)) {
10887       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10888              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10889     }
10890     vms_execfree(vmscmd);
10891   }
10892
10893   return FALSE;
10894
10895 }  /* end of vms_do_exec() */
10896 /*}}}*/
10897
10898 int do_spawn2(pTHX_ const char *, int);
10899
10900 int
10901 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10902 {
10903 unsigned long int sts;
10904 char * cmd;
10905 int flags = 0;
10906
10907   if (sp > mark) {
10908
10909     /* We'll copy the (undocumented?) Win32 behavior and allow a
10910      * numeric first argument.  But the only value we'll support
10911      * through do_aspawn is a value of 1, which means spawn without
10912      * waiting for completion -- other values are ignored.
10913      */
10914     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10915         ++mark;
10916         flags = SvIVx(*mark);
10917     }
10918
10919     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10920         flags = CLI$M_NOWAIT;
10921     else
10922         flags = 0;
10923
10924     cmd = setup_argstr(aTHX_ really, mark, sp);
10925     sts = do_spawn2(aTHX_ cmd, flags);
10926     /* pp_sys will clean up cmd */
10927     return sts;
10928   }
10929   return SS$_ABORT;
10930 }  /* end of do_aspawn() */
10931 /*}}}*/
10932
10933
10934 /* {{{int do_spawn(char* cmd) */
10935 int
10936 Perl_do_spawn(pTHX_ char* cmd)
10937 {
10938     PERL_ARGS_ASSERT_DO_SPAWN;
10939
10940     return do_spawn2(aTHX_ cmd, 0);
10941 }
10942 /*}}}*/
10943
10944 /* {{{int do_spawn_nowait(char* cmd) */
10945 int
10946 Perl_do_spawn_nowait(pTHX_ char* cmd)
10947 {
10948     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10949
10950     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10951 }
10952 /*}}}*/
10953
10954 /* {{{int do_spawn2(char *cmd) */
10955 int
10956 do_spawn2(pTHX_ const char *cmd, int flags)
10957 {
10958   unsigned long int sts, substs;
10959
10960   /* The caller of this routine expects to Safefree(PL_Cmd) */
10961   Newx(PL_Cmd,10,char);
10962
10963   TAINT_ENV();
10964   TAINT_PROPER("spawn");
10965   if (!cmd || !*cmd) {
10966     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10967     if (!(sts & 1)) {
10968       switch (sts) {
10969         case RMS$_FNF:  case RMS$_DNF:
10970           set_errno(ENOENT); break;
10971         case RMS$_DIR:
10972           set_errno(ENOTDIR); break;
10973         case RMS$_DEV:
10974           set_errno(ENODEV); break;
10975         case RMS$_PRV:
10976           set_errno(EACCES); break;
10977         case RMS$_SYN:
10978           set_errno(EINVAL); break;
10979         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10980           set_errno(E2BIG); break;
10981         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10982           _ckvmssts_noperl(sts); /* fall through */
10983         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10984           set_errno(EVMSERR);
10985       }
10986       set_vaxc_errno(sts);
10987       if (ckWARN(WARN_EXEC)) {
10988         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10989                     Strerror(errno));
10990       }
10991     }
10992     sts = substs;
10993   }
10994   else {
10995     char mode[3];
10996     PerlIO * fp;
10997     if (flags & CLI$M_NOWAIT)
10998         strcpy(mode, "n");
10999     else
11000         strcpy(mode, "nW");
11001
11002     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11003     if (fp != NULL)
11004       my_pclose(fp);
11005     /* sts will be the pid in the nowait case */
11006   }
11007   return sts;
11008 }  /* end of do_spawn2() */
11009 /*}}}*/
11010
11011
11012 static unsigned int *sockflags, sockflagsize;
11013
11014 /*
11015  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11016  * routines found in some versions of the CRTL can't deal with sockets.
11017  * We don't shim the other file open routines since a socket isn't
11018  * likely to be opened by a name.
11019  */
11020 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11021 FILE *my_fdopen(int fd, const char *mode)
11022 {
11023   FILE *fp = fdopen(fd, mode);
11024
11025   if (fp) {
11026     unsigned int fdoff = fd / sizeof(unsigned int);
11027     Stat_t sbuf; /* native stat; we don't need flex_stat */
11028     if (!sockflagsize || fdoff > sockflagsize) {
11029       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11030       else           Newx  (sockflags,fdoff+2,unsigned int);
11031       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11032       sockflagsize = fdoff + 2;
11033     }
11034     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11035       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11036   }
11037   return fp;
11038
11039 }
11040 /*}}}*/
11041
11042
11043 /*
11044  * Clear the corresponding bit when the (possibly) socket stream is closed.
11045  * There still a small hole: we miss an implicit close which might occur
11046  * via freopen().  >> Todo
11047  */
11048 /*{{{ int my_fclose(FILE *fp)*/
11049 int my_fclose(FILE *fp) {
11050   if (fp) {
11051     unsigned int fd = fileno(fp);
11052     unsigned int fdoff = fd / sizeof(unsigned int);
11053
11054     if (sockflagsize && fdoff < sockflagsize)
11055       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11056   }
11057   return fclose(fp);
11058 }
11059 /*}}}*/
11060
11061
11062 /*
11063  * A simple fwrite replacement which outputs itmsz*nitm chars without
11064  * introducing record boundaries every itmsz chars.
11065  * We are using fputs, which depends on a terminating null.  We may
11066  * well be writing binary data, so we need to accommodate not only
11067  * data with nulls sprinkled in the middle but also data with no null
11068  * byte at the end.
11069  */
11070 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11071 int
11072 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11073 {
11074   register char *cp, *end, *cpd;
11075   char *data;
11076   register unsigned int fd = fileno(dest);
11077   register unsigned int fdoff = fd / sizeof(unsigned int);
11078   int retval;
11079   int bufsize = itmsz * nitm + 1;
11080
11081   if (fdoff < sockflagsize &&
11082       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11083     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11084     return nitm;
11085   }
11086
11087   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11088   memcpy( data, src, itmsz*nitm );
11089   data[itmsz*nitm] = '\0';
11090
11091   end = data + itmsz * nitm;
11092   retval = (int) nitm; /* on success return # items written */
11093
11094   cpd = data;
11095   while (cpd <= end) {
11096     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11097     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11098     if (cp < end)
11099       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11100     cpd = cp + 1;
11101   }
11102
11103   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11104   return retval;
11105
11106 }  /* end of my_fwrite() */
11107 /*}}}*/
11108
11109 /*{{{ int my_flush(FILE *fp)*/
11110 int
11111 Perl_my_flush(pTHX_ FILE *fp)
11112 {
11113     int res;
11114     if ((res = fflush(fp)) == 0 && fp) {
11115 #ifdef VMS_DO_SOCKETS
11116         Stat_t s;
11117         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11118 #endif
11119             res = fsync(fileno(fp));
11120     }
11121 /*
11122  * If the flush succeeded but set end-of-file, we need to clear
11123  * the error because our caller may check ferror().  BTW, this
11124  * probably means we just flushed an empty file.
11125  */
11126     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11127
11128     return res;
11129 }
11130 /*}}}*/
11131
11132 /* fgetname() is not returning the correct file specifications when
11133  * decc_filename_unix_report mode is active.  So we have to have it
11134  * aways return filenames in VMS mode and convert it ourselves.
11135  */
11136
11137 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11138 char *
11139 Perl_my_fgetname(FILE *fp, char * buf) {
11140     char * retname;
11141     char * vms_name;
11142
11143     retname = fgetname(fp, buf, 1);
11144
11145     /* If we are in VMS mode, then we are done */
11146     if (!decc_filename_unix_report || (retname == NULL)) {
11147        return retname;
11148     }
11149
11150     /* Convert this to Unix format */
11151     vms_name = PerlMem_malloc(VMS_MAXRSS);
11152     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11153     retname = int_tounixspec(vms_name, buf, NULL);
11154     PerlMem_free(vms_name);
11155
11156     return retname;
11157 }
11158 /*}}}*/
11159
11160 /*
11161  * Here are replacements for the following Unix routines in the VMS environment:
11162  *      getpwuid    Get information for a particular UIC or UID
11163  *      getpwnam    Get information for a named user
11164  *      getpwent    Get information for each user in the rights database
11165  *      setpwent    Reset search to the start of the rights database
11166  *      endpwent    Finish searching for users in the rights database
11167  *
11168  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11169  * (defined in pwd.h), which contains the following fields:-
11170  *      struct passwd {
11171  *              char        *pw_name;    Username (in lower case)
11172  *              char        *pw_passwd;  Hashed password
11173  *              unsigned int pw_uid;     UIC
11174  *              unsigned int pw_gid;     UIC group  number
11175  *              char        *pw_unixdir; Default device/directory (VMS-style)
11176  *              char        *pw_gecos;   Owner name
11177  *              char        *pw_dir;     Default device/directory (Unix-style)
11178  *              char        *pw_shell;   Default CLI name (eg. DCL)
11179  *      };
11180  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11181  *
11182  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11183  * not the UIC member number (eg. what's returned by getuid()),
11184  * getpwuid() can accept either as input (if uid is specified, the caller's
11185  * UIC group is used), though it won't recognise gid=0.
11186  *
11187  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11188  * information about other users in your group or in other groups, respectively.
11189  * If the required privilege is not available, then these routines fill only
11190  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11191  * string).
11192  *
11193  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11194  */
11195
11196 /* sizes of various UAF record fields */
11197 #define UAI$S_USERNAME 12
11198 #define UAI$S_IDENT    31
11199 #define UAI$S_OWNER    31
11200 #define UAI$S_DEFDEV   31
11201 #define UAI$S_DEFDIR   63
11202 #define UAI$S_DEFCLI   31
11203 #define UAI$S_PWD       8
11204
11205 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11206                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11207                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11208
11209 static char __empty[]= "";
11210 static struct passwd __passwd_empty=
11211     {(char *) __empty, (char *) __empty, 0, 0,
11212      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11213 static int contxt= 0;
11214 static struct passwd __pwdcache;
11215 static char __pw_namecache[UAI$S_IDENT+1];
11216
11217 /*
11218  * This routine does most of the work extracting the user information.
11219  */
11220 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11221 {
11222     static struct {
11223         unsigned char length;
11224         char pw_gecos[UAI$S_OWNER+1];
11225     } owner;
11226     static union uicdef uic;
11227     static struct {
11228         unsigned char length;
11229         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11230     } defdev;
11231     static struct {
11232         unsigned char length;
11233         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11234     } defdir;
11235     static struct {
11236         unsigned char length;
11237         char pw_shell[UAI$S_DEFCLI+1];
11238     } defcli;
11239     static char pw_passwd[UAI$S_PWD+1];
11240
11241     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11242     struct dsc$descriptor_s name_desc;
11243     unsigned long int sts;
11244
11245     static struct itmlst_3 itmlst[]= {
11246         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11247         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11248         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11249         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11250         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11251         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11252         {0,                0,           NULL,    NULL}};
11253
11254     name_desc.dsc$w_length=  strlen(name);
11255     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11256     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11257     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11258
11259 /*  Note that sys$getuai returns many fields as counted strings. */
11260     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11261     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11262       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11263     }
11264     else { _ckvmssts(sts); }
11265     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11266
11267     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11268     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11269     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11270     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11271     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11272     owner.pw_gecos[lowner]=            '\0';
11273     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11274     defcli.pw_shell[ldefcli]=          '\0';
11275     if (valid_uic(uic)) {
11276         pwd->pw_uid= uic.uic$l_uic;
11277         pwd->pw_gid= uic.uic$v_group;
11278     }
11279     else
11280       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11281     pwd->pw_passwd=  pw_passwd;
11282     pwd->pw_gecos=   owner.pw_gecos;
11283     pwd->pw_dir=     defdev.pw_dir;
11284     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11285     pwd->pw_shell=   defcli.pw_shell;
11286     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11287         int ldir;
11288         ldir= strlen(pwd->pw_unixdir) - 1;
11289         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11290     }
11291     else
11292         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11293     if (!decc_efs_case_preserve)
11294         __mystrtolower(pwd->pw_unixdir);
11295     return 1;
11296 }
11297
11298 /*
11299  * Get information for a named user.
11300 */
11301 /*{{{struct passwd *getpwnam(char *name)*/
11302 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11303 {
11304     struct dsc$descriptor_s name_desc;
11305     union uicdef uic;
11306     unsigned long int sts;
11307
11308     __pwdcache = __passwd_empty;
11309     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11310       /* We still may be able to determine pw_uid and pw_gid */
11311       name_desc.dsc$w_length=  strlen(name);
11312       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11313       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11314       name_desc.dsc$a_pointer= (char *) name;
11315       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11316         __pwdcache.pw_uid= uic.uic$l_uic;
11317         __pwdcache.pw_gid= uic.uic$v_group;
11318       }
11319       else {
11320         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11321           set_vaxc_errno(sts);
11322           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11323           return NULL;
11324         }
11325         else { _ckvmssts(sts); }
11326       }
11327     }
11328     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11329     __pwdcache.pw_name= __pw_namecache;
11330     return &__pwdcache;
11331 }  /* end of my_getpwnam() */
11332 /*}}}*/
11333
11334 /*
11335  * Get information for a particular UIC or UID.
11336  * Called by my_getpwent with uid=-1 to list all users.
11337 */
11338 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11339 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11340 {
11341     const $DESCRIPTOR(name_desc,__pw_namecache);
11342     unsigned short lname;
11343     union uicdef uic;
11344     unsigned long int status;
11345
11346     if (uid == (unsigned int) -1) {
11347       do {
11348         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11349         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11350           set_vaxc_errno(status);
11351           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11352           my_endpwent();
11353           return NULL;
11354         }
11355         else { _ckvmssts(status); }
11356       } while (!valid_uic (uic));
11357     }
11358     else {
11359       uic.uic$l_uic= uid;
11360       if (!uic.uic$v_group)
11361         uic.uic$v_group= PerlProc_getgid();
11362       if (valid_uic(uic))
11363         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11364       else status = SS$_IVIDENT;
11365       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11366           status == RMS$_PRV) {
11367         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11368         return NULL;
11369       }
11370       else { _ckvmssts(status); }
11371     }
11372     __pw_namecache[lname]= '\0';
11373     __mystrtolower(__pw_namecache);
11374
11375     __pwdcache = __passwd_empty;
11376     __pwdcache.pw_name = __pw_namecache;
11377
11378 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11379     The identifier's value is usually the UIC, but it doesn't have to be,
11380     so if we can, we let fillpasswd update this. */
11381     __pwdcache.pw_uid =  uic.uic$l_uic;
11382     __pwdcache.pw_gid =  uic.uic$v_group;
11383
11384     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11385     return &__pwdcache;
11386
11387 }  /* end of my_getpwuid() */
11388 /*}}}*/
11389
11390 /*
11391  * Get information for next user.
11392 */
11393 /*{{{struct passwd *my_getpwent()*/
11394 struct passwd *Perl_my_getpwent(pTHX)
11395 {
11396     return (my_getpwuid((unsigned int) -1));
11397 }
11398 /*}}}*/
11399
11400 /*
11401  * Finish searching rights database for users.
11402 */
11403 /*{{{void my_endpwent()*/
11404 void Perl_my_endpwent(pTHX)
11405 {
11406     if (contxt) {
11407       _ckvmssts(sys$finish_rdb(&contxt));
11408       contxt= 0;
11409     }
11410 }
11411 /*}}}*/
11412
11413 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11414  * my_utime(), and flex_stat(), all of which operate on UTC unless
11415  * VMSISH_TIMES is true.
11416  */
11417 /* method used to handle UTC conversions:
11418  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11419  */
11420 static int gmtime_emulation_type;
11421 /* number of secs to add to UTC POSIX-style time to get local time */
11422 static long int utc_offset_secs;
11423
11424 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11425  * in vmsish.h.  #undef them here so we can call the CRTL routines
11426  * directly.
11427  */
11428 #undef gmtime
11429 #undef localtime
11430 #undef time
11431
11432
11433 static time_t toutc_dst(time_t loc) {
11434   struct tm *rsltmp;
11435
11436   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11437   loc -= utc_offset_secs;
11438   if (rsltmp->tm_isdst) loc -= 3600;
11439   return loc;
11440 }
11441 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11442        ((gmtime_emulation_type || my_time(NULL)), \
11443        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11444        ((secs) - utc_offset_secs))))
11445
11446 static time_t toloc_dst(time_t utc) {
11447   struct tm *rsltmp;
11448
11449   utc += utc_offset_secs;
11450   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11451   if (rsltmp->tm_isdst) utc += 3600;
11452   return utc;
11453 }
11454 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11455        ((gmtime_emulation_type || my_time(NULL)), \
11456        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11457        ((secs) + utc_offset_secs))))
11458
11459 /* my_time(), my_localtime(), my_gmtime()
11460  * By default traffic in UTC time values, using CRTL gmtime() or
11461  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11462  * Note: We need to use these functions even when the CRTL has working
11463  * UTC support, since they also handle C<use vmsish qw(times);>
11464  *
11465  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11466  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11467  */
11468
11469 /*{{{time_t my_time(time_t *timep)*/
11470 time_t Perl_my_time(pTHX_ time_t *timep)
11471 {
11472   time_t when;
11473   struct tm *tm_p;
11474
11475   if (gmtime_emulation_type == 0) {
11476     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11477                               /* results of calls to gmtime() and localtime() */
11478                               /* for same &base */
11479
11480     gmtime_emulation_type++;
11481     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11482       char off[LNM$C_NAMLENGTH+1];;
11483
11484       gmtime_emulation_type++;
11485       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11486         gmtime_emulation_type++;
11487         utc_offset_secs = 0;
11488         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11489       }
11490       else { utc_offset_secs = atol(off); }
11491     }
11492     else { /* We've got a working gmtime() */
11493       struct tm gmt, local;
11494
11495       gmt = *tm_p;
11496       tm_p = localtime(&base);
11497       local = *tm_p;
11498       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11499       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11500       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11501       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11502     }
11503   }
11504
11505   when = time(NULL);
11506 # ifdef VMSISH_TIME
11507   if (VMSISH_TIME) when = _toloc(when);
11508 # endif
11509   if (timep != NULL) *timep = when;
11510   return when;
11511
11512 }  /* end of my_time() */
11513 /*}}}*/
11514
11515
11516 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11517 struct tm *
11518 Perl_my_gmtime(pTHX_ const time_t *timep)
11519 {
11520   time_t when;
11521   struct tm *rsltmp;
11522
11523   if (timep == NULL) {
11524     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11525     return NULL;
11526   }
11527   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11528
11529   when = *timep;
11530 # ifdef VMSISH_TIME
11531   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11532 #  endif
11533   return gmtime(&when);
11534 }  /* end of my_gmtime() */
11535 /*}}}*/
11536
11537
11538 /*{{{struct tm *my_localtime(const time_t *timep)*/
11539 struct tm *
11540 Perl_my_localtime(pTHX_ const time_t *timep)
11541 {
11542   time_t when, whenutc;
11543   struct tm *rsltmp;
11544   int dst, offset;
11545
11546   if (timep == NULL) {
11547     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11548     return NULL;
11549   }
11550   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11551   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11552
11553   when = *timep;
11554 # ifdef VMSISH_TIME
11555   if (VMSISH_TIME) when = _toutc(when);
11556 # endif
11557   /* CRTL localtime() wants UTC as input, does tz correction itself */
11558   return localtime(&when);
11559
11560   /* CRTL localtime() wants local time as input, so does no tz correction */
11561   rsltmp = localtime(&when);
11562   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11563   return rsltmp;
11564
11565 } /*  end of my_localtime() */
11566 /*}}}*/
11567
11568 /* Reset definitions for later calls */
11569 #define gmtime(t)    my_gmtime(t)
11570 #define localtime(t) my_localtime(t)
11571 #define time(t)      my_time(t)
11572
11573
11574 /* my_utime - update modification/access time of a file
11575  *
11576  * VMS 7.3 and later implementation
11577  * Only the UTC translation is home-grown. The rest is handled by the
11578  * CRTL utime(), which will take into account the relevant feature
11579  * logicals and ODS-5 volume characteristics for true access times.
11580  *
11581  * pre VMS 7.3 implementation:
11582  * The calling sequence is identical to POSIX utime(), but under
11583  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11584  * not maintain access times.  Restrictions differ from the POSIX
11585  * definition in that the time can be changed as long as the
11586  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11587  * no separate checks are made to insure that the caller is the
11588  * owner of the file or has special privs enabled.
11589  * Code here is based on Joe Meadows' FILE utility.
11590  *
11591  */
11592
11593 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11594  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11595  * in 100 ns intervals.
11596  */
11597 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11598
11599 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11600 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11601 {
11602 #if __CRTL_VER >= 70300000
11603   struct utimbuf utc_utimes, *utc_utimesp;
11604
11605   if (utimes != NULL) {
11606     utc_utimes.actime = utimes->actime;
11607     utc_utimes.modtime = utimes->modtime;
11608 # ifdef VMSISH_TIME
11609     /* If input was local; convert to UTC for sys svc */
11610     if (VMSISH_TIME) {
11611       utc_utimes.actime = _toutc(utimes->actime);
11612       utc_utimes.modtime = _toutc(utimes->modtime);
11613     }
11614 # endif
11615     utc_utimesp = &utc_utimes;
11616   }
11617   else {
11618     utc_utimesp = NULL;
11619   }
11620
11621   return utime(file, utc_utimesp);
11622
11623 #else /* __CRTL_VER < 70300000 */
11624
11625   register int i;
11626   int sts;
11627   long int bintime[2], len = 2, lowbit, unixtime,
11628            secscale = 10000000; /* seconds --> 100 ns intervals */
11629   unsigned long int chan, iosb[2], retsts;
11630   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11631   struct FAB myfab = cc$rms_fab;
11632   struct NAM mynam = cc$rms_nam;
11633 #if defined (__DECC) && defined (__VAX)
11634   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11635    * at least through VMS V6.1, which causes a type-conversion warning.
11636    */
11637 #  pragma message save
11638 #  pragma message disable cvtdiftypes
11639 #endif
11640   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11641   struct fibdef myfib;
11642 #if defined (__DECC) && defined (__VAX)
11643   /* This should be right after the declaration of myatr, but due
11644    * to a bug in VAX DEC C, this takes effect a statement early.
11645    */
11646 #  pragma message restore
11647 #endif
11648   /* cast ok for read only parameter */
11649   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11650                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11651                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11652
11653   if (file == NULL || *file == '\0') {
11654     SETERRNO(ENOENT, LIB$_INVARG);
11655     return -1;
11656   }
11657
11658   /* Convert to VMS format ensuring that it will fit in 255 characters */
11659   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11660       SETERRNO(ENOENT, LIB$_INVARG);
11661       return -1;
11662   }
11663   if (utimes != NULL) {
11664     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11665      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11666      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11667      * as input, we force the sign bit to be clear by shifting unixtime right
11668      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11669      */
11670     lowbit = (utimes->modtime & 1) ? secscale : 0;
11671     unixtime = (long int) utimes->modtime;
11672 #   ifdef VMSISH_TIME
11673     /* If input was UTC; convert to local for sys svc */
11674     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11675 #   endif
11676     unixtime >>= 1;  secscale <<= 1;
11677     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11678     if (!(retsts & 1)) {
11679       SETERRNO(EVMSERR, retsts);
11680       return -1;
11681     }
11682     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11683     if (!(retsts & 1)) {
11684       SETERRNO(EVMSERR, retsts);
11685       return -1;
11686     }
11687   }
11688   else {
11689     /* Just get the current time in VMS format directly */
11690     retsts = sys$gettim(bintime);
11691     if (!(retsts & 1)) {
11692       SETERRNO(EVMSERR, retsts);
11693       return -1;
11694     }
11695   }
11696
11697   myfab.fab$l_fna = vmsspec;
11698   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11699   myfab.fab$l_nam = &mynam;
11700   mynam.nam$l_esa = esa;
11701   mynam.nam$b_ess = (unsigned char) sizeof esa;
11702   mynam.nam$l_rsa = rsa;
11703   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11704   if (decc_efs_case_preserve)
11705       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11706
11707   /* Look for the file to be affected, letting RMS parse the file
11708    * specification for us as well.  I have set errno using only
11709    * values documented in the utime() man page for VMS POSIX.
11710    */
11711   retsts = sys$parse(&myfab,0,0);
11712   if (!(retsts & 1)) {
11713     set_vaxc_errno(retsts);
11714     if      (retsts == RMS$_PRV) set_errno(EACCES);
11715     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11716     else                         set_errno(EVMSERR);
11717     return -1;
11718   }
11719   retsts = sys$search(&myfab,0,0);
11720   if (!(retsts & 1)) {
11721     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11722     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11723     set_vaxc_errno(retsts);
11724     if      (retsts == RMS$_PRV) set_errno(EACCES);
11725     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11726     else                         set_errno(EVMSERR);
11727     return -1;
11728   }
11729
11730   devdsc.dsc$w_length = mynam.nam$b_dev;
11731   /* cast ok for read only parameter */
11732   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11733
11734   retsts = sys$assign(&devdsc,&chan,0,0);
11735   if (!(retsts & 1)) {
11736     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11737     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11738     set_vaxc_errno(retsts);
11739     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11740     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11741     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11742     else                               set_errno(EVMSERR);
11743     return -1;
11744   }
11745
11746   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11747   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11748
11749   memset((void *) &myfib, 0, sizeof myfib);
11750 #if defined(__DECC) || defined(__DECCXX)
11751   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11752   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11753   /* This prevents the revision time of the file being reset to the current
11754    * time as a result of our IO$_MODIFY $QIO. */
11755   myfib.fib$l_acctl = FIB$M_NORECORD;
11756 #else
11757   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11758   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11759   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11760 #endif
11761   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11762   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11763   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11764   _ckvmssts(sys$dassgn(chan));
11765   if (retsts & 1) retsts = iosb[0];
11766   if (!(retsts & 1)) {
11767     set_vaxc_errno(retsts);
11768     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11769     else                      set_errno(EVMSERR);
11770     return -1;
11771   }
11772
11773   return 0;
11774
11775 #endif /* #if __CRTL_VER >= 70300000 */
11776
11777 }  /* end of my_utime() */
11778 /*}}}*/
11779
11780 /*
11781  * flex_stat, flex_lstat, flex_fstat
11782  * basic stat, but gets it right when asked to stat
11783  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11784  */
11785
11786 #ifndef _USE_STD_STAT
11787 /* encode_dev packs a VMS device name string into an integer to allow
11788  * simple comparisons. This can be used, for example, to check whether two
11789  * files are located on the same device, by comparing their encoded device
11790  * names. Even a string comparison would not do, because stat() reuses the
11791  * device name buffer for each call; so without encode_dev, it would be
11792  * necessary to save the buffer and use strcmp (this would mean a number of
11793  * changes to the standard Perl code, to say nothing of what a Perl script
11794  * would have to do.
11795  *
11796  * The device lock id, if it exists, should be unique (unless perhaps compared
11797  * with lock ids transferred from other nodes). We have a lock id if the disk is
11798  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11799  * device names. Thus we use the lock id in preference, and only if that isn't
11800  * available, do we try to pack the device name into an integer (flagged by
11801  * the sign bit (LOCKID_MASK) being set).
11802  *
11803  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11804  * name and its encoded form, but it seems very unlikely that we will find
11805  * two files on different disks that share the same encoded device names,
11806  * and even more remote that they will share the same file id (if the test
11807  * is to check for the same file).
11808  *
11809  * A better method might be to use sys$device_scan on the first call, and to
11810  * search for the device, returning an index into the cached array.
11811  * The number returned would be more intelligible.
11812  * This is probably not worth it, and anyway would take quite a bit longer
11813  * on the first call.
11814  */
11815 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11816 static mydev_t encode_dev (pTHX_ const char *dev)
11817 {
11818   int i;
11819   unsigned long int f;
11820   mydev_t enc;
11821   char c;
11822   const char *q;
11823
11824   if (!dev || !dev[0]) return 0;
11825
11826 #if LOCKID_MASK
11827   {
11828     struct dsc$descriptor_s dev_desc;
11829     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11830
11831     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11832        can try that first. */
11833     dev_desc.dsc$w_length =  strlen (dev);
11834     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11835     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11836     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11837     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11838     if (!$VMS_STATUS_SUCCESS(status)) {
11839       switch (status) {
11840         case SS$_NOSUCHDEV:
11841           SETERRNO(ENODEV, status);
11842           return 0;
11843         default:
11844           _ckvmssts(status);
11845       }
11846     }
11847     if (lockid) return (lockid & ~LOCKID_MASK);
11848   }
11849 #endif
11850
11851   /* Otherwise we try to encode the device name */
11852   enc = 0;
11853   f = 1;
11854   i = 0;
11855   for (q = dev + strlen(dev); q--; q >= dev) {
11856     if (*q == ':')
11857         break;
11858     if (isdigit (*q))
11859       c= (*q) - '0';
11860     else if (isalpha (toupper (*q)))
11861       c= toupper (*q) - 'A' + (char)10;
11862     else
11863       continue; /* Skip '$'s */
11864     i++;
11865     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11866     if (i>1) f *= 36;
11867     enc += f * (unsigned long int) c;
11868   }
11869   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11870
11871 }  /* end of encode_dev() */
11872 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11873         device_no = encode_dev(aTHX_ devname)
11874 #else
11875 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11876         device_no = new_dev_no
11877 #endif
11878
11879 static int
11880 is_null_device(const char *name)
11881 {
11882   if (decc_bug_devnull != 0) {
11883     if (strncmp("/dev/null", name, 9) == 0)
11884       return 1;
11885   }
11886     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11887        The underscore prefix, controller letter, and unit number are
11888        independently optional; for our purposes, the colon punctuation
11889        is not.  The colon can be trailed by optional directory and/or
11890        filename, but two consecutive colons indicates a nodename rather
11891        than a device.  [pr]  */
11892   if (*name == '_') ++name;
11893   if (tolower(*name++) != 'n') return 0;
11894   if (tolower(*name++) != 'l') return 0;
11895   if (tolower(*name) == 'a') ++name;
11896   if (*name == '0') ++name;
11897   return (*name++ == ':') && (*name != ':');
11898 }
11899
11900 static int
11901 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11902
11903 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11904
11905 static I32
11906 Perl_cando_by_name_int
11907    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11908 {
11909   char usrname[L_cuserid];
11910   struct dsc$descriptor_s usrdsc =
11911          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11912   char *vmsname = NULL, *fileified = NULL;
11913   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11914   unsigned short int retlen, trnlnm_iter_count;
11915   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11916   union prvdef curprv;
11917   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11918          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11919          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11920   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11921          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11922          {0,0,0,0}};
11923   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11924          {0,0,0,0}};
11925   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11926   Stat_t st;
11927   static int profile_context = -1;
11928
11929   if (!fname || !*fname) return FALSE;
11930
11931   /* Make sure we expand logical names, since sys$check_access doesn't */
11932   fileified = PerlMem_malloc(VMS_MAXRSS);
11933   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11934   if (!strpbrk(fname,"/]>:")) {
11935       my_strlcpy(fileified, fname, VMS_MAXRSS);
11936       trnlnm_iter_count = 0;
11937       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11938         trnlnm_iter_count++;
11939         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11940       }
11941       fname = fileified;
11942   }
11943
11944   vmsname = PerlMem_malloc(VMS_MAXRSS);
11945   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11946   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11947     /* Don't know if already in VMS format, so make sure */
11948     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11949       PerlMem_free(fileified);
11950       PerlMem_free(vmsname);
11951       return FALSE;
11952     }
11953   }
11954   else {
11955     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11956   }
11957
11958   /* sys$check_access needs a file spec, not a directory spec.
11959    * flex_stat now will handle a null thread context during startup.
11960    */
11961
11962   retlen = namdsc.dsc$w_length = strlen(vmsname);
11963   if (vmsname[retlen-1] == ']'
11964       || vmsname[retlen-1] == '>'
11965       || vmsname[retlen-1] == ':'
11966       || (!flex_stat_int(vmsname, &st, 1) &&
11967           S_ISDIR(st.st_mode))) {
11968
11969       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11970         PerlMem_free(fileified);
11971         PerlMem_free(vmsname);
11972         return FALSE;
11973       }
11974       fname = fileified;
11975   }
11976   else {
11977       fname = vmsname;
11978   }
11979
11980   retlen = namdsc.dsc$w_length = strlen(fname);
11981   namdsc.dsc$a_pointer = (char *)fname;
11982
11983   switch (bit) {
11984     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11985       access = ARM$M_EXECUTE;
11986       flags = CHP$M_READ;
11987       break;
11988     case S_IRUSR: case S_IRGRP: case S_IROTH:
11989       access = ARM$M_READ;
11990       flags = CHP$M_READ | CHP$M_USEREADALL;
11991       break;
11992     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11993       access = ARM$M_WRITE;
11994       flags = CHP$M_READ | CHP$M_WRITE;
11995       break;
11996     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11997       access = ARM$M_DELETE;
11998       flags = CHP$M_READ | CHP$M_WRITE;
11999       break;
12000     default:
12001       if (fileified != NULL)
12002         PerlMem_free(fileified);
12003       if (vmsname != NULL)
12004         PerlMem_free(vmsname);
12005       return FALSE;
12006   }
12007
12008   /* Before we call $check_access, create a user profile with the current
12009    * process privs since otherwise it just uses the default privs from the
12010    * UAF and might give false positives or negatives.  This only works on
12011    * VMS versions v6.0 and later since that's when sys$create_user_profile
12012    * became available.
12013    */
12014
12015   /* get current process privs and username */
12016   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12017   _ckvmssts_noperl(iosb[0]);
12018
12019   /* find out the space required for the profile */
12020   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12021                                     &usrprodsc.dsc$w_length,&profile_context));
12022
12023   /* allocate space for the profile and get it filled in */
12024   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12025   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12026   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12027                                     &usrprodsc.dsc$w_length,&profile_context));
12028
12029   /* use the profile to check access to the file; free profile & analyze results */
12030   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12031   PerlMem_free(usrprodsc.dsc$a_pointer);
12032   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12033
12034   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12035       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12036       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12037     set_vaxc_errno(retsts);
12038     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12039     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12040     else set_errno(ENOENT);
12041     if (fileified != NULL)
12042       PerlMem_free(fileified);
12043     if (vmsname != NULL)
12044       PerlMem_free(vmsname);
12045     return FALSE;
12046   }
12047   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12048     if (fileified != NULL)
12049       PerlMem_free(fileified);
12050     if (vmsname != NULL)
12051       PerlMem_free(vmsname);
12052     return TRUE;
12053   }
12054   _ckvmssts_noperl(retsts);
12055
12056   if (fileified != NULL)
12057     PerlMem_free(fileified);
12058   if (vmsname != NULL)
12059     PerlMem_free(vmsname);
12060   return FALSE;  /* Should never get here */
12061
12062 }
12063
12064 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12065 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12066  * subset of the applicable information.
12067  */
12068 bool
12069 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12070 {
12071   return cando_by_name_int
12072         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12073 }  /* end of cando() */
12074 /*}}}*/
12075
12076
12077 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12078 I32
12079 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12080 {
12081    return cando_by_name_int(bit, effective, fname, 0);
12082
12083 }  /* end of cando_by_name() */
12084 /*}}}*/
12085
12086
12087 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12088 int
12089 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12090 {
12091   if (!fstat(fd, &statbufp->crtl_stat)) {
12092     char *cptr;
12093     char *vms_filename;
12094     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12095     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12096
12097     /* Save name for cando by name in VMS format */
12098     cptr = getname(fd, vms_filename, 1);
12099
12100     /* This should not happen, but just in case */
12101     if (cptr == NULL) {
12102         statbufp->st_devnam[0] = 0;
12103     }
12104     else {
12105         /* Make sure that the saved name fits in 255 characters */
12106         cptr = int_rmsexpand_vms
12107                        (vms_filename,
12108                         statbufp->st_devnam,
12109                         0);
12110         if (cptr == NULL)
12111             statbufp->st_devnam[0] = 0;
12112     }
12113     PerlMem_free(vms_filename);
12114
12115     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12116     VMS_DEVICE_ENCODE
12117         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12118
12119 #   ifdef VMSISH_TIME
12120     if (VMSISH_TIME) {
12121       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12122       statbufp->st_atime = _toloc(statbufp->st_atime);
12123       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12124     }
12125 #   endif
12126     return 0;
12127   }
12128   return -1;
12129
12130 }  /* end of flex_fstat() */
12131 /*}}}*/
12132
12133 static int
12134 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12135 {
12136     char *temp_fspec = NULL;
12137     char *fileified = NULL;
12138     const char *save_spec;
12139     char *ret_spec;
12140     int retval = -1;
12141     char efs_hack = 0;
12142     char already_fileified = 0;
12143     dSAVEDERRNO;
12144
12145     if (!fspec) {
12146         errno = EINVAL;
12147         return retval;
12148     }
12149
12150     if (decc_bug_devnull != 0) {
12151       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12152         memset(statbufp,0,sizeof *statbufp);
12153         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12154         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12155         statbufp->st_uid = 0x00010001;
12156         statbufp->st_gid = 0x0001;
12157         time((time_t *)&statbufp->st_mtime);
12158         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12159         return 0;
12160       }
12161     }
12162
12163     SAVE_ERRNO;
12164
12165 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12166   /*
12167    * If we are in POSIX filespec mode, accept the filename as is.
12168    */
12169   if (decc_posix_compliant_pathnames == 0) {
12170 #endif
12171
12172     /* Try for a simple stat first.  If fspec contains a filename without
12173      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12174      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12175      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12176      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12177      * the file with null type, specify this by calling flex_stat() with
12178      * a '.' at the end of fspec.
12179      */
12180
12181     if (lstat_flag == 0)
12182         retval = stat(fspec, &statbufp->crtl_stat);
12183     else
12184         retval = lstat(fspec, &statbufp->crtl_stat);
12185
12186     if (!retval) {
12187         save_spec = fspec;
12188     }
12189     else {
12190         /* In the odd case where we have write but not read access
12191          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12192          */
12193         fileified = PerlMem_malloc(VMS_MAXRSS);
12194         if (fileified == NULL)
12195               _ckvmssts_noperl(SS$_INSFMEM);
12196
12197         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12198         if (ret_spec != NULL) {
12199             if (lstat_flag == 0)
12200                 retval = stat(fileified, &statbufp->crtl_stat);
12201             else
12202                 retval = lstat(fileified, &statbufp->crtl_stat);
12203             save_spec = fileified;
12204             already_fileified = 1;
12205         }
12206     }
12207
12208     if (retval && vms_bug_stat_filename) {
12209
12210         temp_fspec = PerlMem_malloc(VMS_MAXRSS);
12211         if (temp_fspec == NULL)
12212             _ckvmssts_noperl(SS$_INSFMEM);
12213
12214         /* We should try again as a vmsified file specification. */
12215
12216         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12217         if (ret_spec != NULL) {
12218             if (lstat_flag == 0)
12219                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12220             else
12221                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12222             save_spec = temp_fspec;
12223         }
12224     }
12225
12226     if (retval) {
12227         /* Last chance - allow multiple dots without EFS CHARSET */
12228         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12229          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12230          * enable it if it isn't already.
12231          */
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, 1);
12235 #endif
12236         if (lstat_flag == 0)
12237             retval = stat(fspec, &statbufp->crtl_stat);
12238         else
12239             retval = lstat(fspec, &statbufp->crtl_stat);
12240         save_spec = fspec;
12241 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12242         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12243             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12244             efs_hack = 1;
12245         }
12246 #endif
12247     }
12248
12249 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12250   } else {
12251     if (lstat_flag == 0)
12252       retval = stat(temp_fspec, &statbufp->crtl_stat);
12253     else
12254       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12255       save_spec = temp_fspec;
12256   }
12257 #endif
12258
12259 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12260   /* As you were... */
12261   if (!decc_efs_charset)
12262     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12263 #endif
12264
12265     if (!retval) {
12266       char *cptr;
12267       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12268
12269       /* If this is an lstat, do not follow the link */
12270       if (lstat_flag)
12271         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12272
12273 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12274       /* If we used the efs_hack above, we must also use it here for */
12275       /* perl_cando to work */
12276       if (efs_hack && (decc_efs_charset_index > 0)) {
12277           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12278       }
12279 #endif
12280
12281       /* If we've got a directory, save a fileified, expanded version of it
12282        * in st_devnam.  If not a directory, just an expanded version.
12283        */
12284       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12285           fileified = PerlMem_malloc(VMS_MAXRSS);
12286           if (fileified == NULL)
12287               _ckvmssts_noperl(SS$_INSFMEM);
12288
12289           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12290           if (cptr != NULL)
12291               save_spec = fileified;
12292       }
12293
12294       cptr = int_rmsexpand(save_spec,
12295                            statbufp->st_devnam,
12296                            NULL,
12297                            rmsex_flags,
12298                            0,
12299                            0);
12300
12301 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12302       if (efs_hack && (decc_efs_charset_index > 0)) {
12303           decc$feature_set_value(decc_efs_charset, 1, 0);
12304       }
12305 #endif
12306
12307       /* Fix me: If this is NULL then stat found a file, and we could */
12308       /* not convert the specification to VMS - Should never happen */
12309       if (cptr == NULL)
12310         statbufp->st_devnam[0] = 0;
12311
12312       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12313       VMS_DEVICE_ENCODE
12314         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12315 #     ifdef VMSISH_TIME
12316       if (VMSISH_TIME) {
12317         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12318         statbufp->st_atime = _toloc(statbufp->st_atime);
12319         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12320       }
12321 #     endif
12322     }
12323     /* If we were successful, leave errno where we found it */
12324     if (retval == 0) RESTORE_ERRNO;
12325     if (temp_fspec)
12326         PerlMem_free(temp_fspec);
12327     if (fileified)
12328         PerlMem_free(fileified);
12329     return retval;
12330
12331 }  /* end of flex_stat_int() */
12332
12333
12334 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12335 int
12336 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12337 {
12338    return flex_stat_int(fspec, statbufp, 0);
12339 }
12340 /*}}}*/
12341
12342 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12343 int
12344 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12345 {
12346    return flex_stat_int(fspec, statbufp, 1);
12347 }
12348 /*}}}*/
12349
12350
12351 /*{{{char *my_getlogin()*/
12352 /* VMS cuserid == Unix getlogin, except calling sequence */
12353 char *
12354 my_getlogin(void)
12355 {
12356     static char user[L_cuserid];
12357     return cuserid(user);
12358 }
12359 /*}}}*/
12360
12361
12362 /*  rmscopy - copy a file using VMS RMS routines
12363  *
12364  *  Copies contents and attributes of spec_in to spec_out, except owner
12365  *  and protection information.  Name and type of spec_in are used as
12366  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12367  *  should try to propagate timestamps from the input file to the output file.
12368  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12369  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12370  *  propagated to the output file at creation iff the output file specification
12371  *  did not contain an explicit name or type, and the revision date is always
12372  *  updated at the end of the copy operation.  If it is greater than 0, then
12373  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12374  *  other than the revision date should be propagated, and bit 1 indicates
12375  *  that the revision date should be propagated.
12376  *
12377  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12378  *
12379  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12380  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12381  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12382  * as part of the Perl standard distribution under the terms of the
12383  * GNU General Public License or the Perl Artistic License.  Copies
12384  * of each may be found in the Perl standard distribution.
12385  */ /* FIXME */
12386 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12387 int
12388 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12389 {
12390     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12391          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12392     unsigned long int sts;
12393     int dna_len;
12394     struct FAB fab_in, fab_out;
12395     struct RAB rab_in, rab_out;
12396     rms_setup_nam(nam);
12397     rms_setup_nam(nam_out);
12398     struct XABDAT xabdat;
12399     struct XABFHC xabfhc;
12400     struct XABRDT xabrdt;
12401     struct XABSUM xabsum;
12402
12403     vmsin = PerlMem_malloc(VMS_MAXRSS);
12404     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12405     vmsout = PerlMem_malloc(VMS_MAXRSS);
12406     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12407     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12408         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12409       PerlMem_free(vmsin);
12410       PerlMem_free(vmsout);
12411       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12412       return 0;
12413     }
12414
12415     esa = PerlMem_malloc(VMS_MAXRSS);
12416     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12417     esal = NULL;
12418 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12419     esal = PerlMem_malloc(VMS_MAXRSS);
12420     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12421 #endif
12422     fab_in = cc$rms_fab;
12423     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12424     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12425     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12426     fab_in.fab$l_fop = FAB$M_SQO;
12427     rms_bind_fab_nam(fab_in, nam);
12428     fab_in.fab$l_xab = (void *) &xabdat;
12429
12430     rsa = PerlMem_malloc(VMS_MAXRSS);
12431     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12432     rsal = NULL;
12433 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12434     rsal = PerlMem_malloc(VMS_MAXRSS);
12435     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12436 #endif
12437     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12438     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12439     rms_nam_esl(nam) = 0;
12440     rms_nam_rsl(nam) = 0;
12441     rms_nam_esll(nam) = 0;
12442     rms_nam_rsll(nam) = 0;
12443 #ifdef NAM$M_NO_SHORT_UPCASE
12444     if (decc_efs_case_preserve)
12445         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12446 #endif
12447
12448     xabdat = cc$rms_xabdat;        /* To get creation date */
12449     xabdat.xab$l_nxt = (void *) &xabfhc;
12450
12451     xabfhc = cc$rms_xabfhc;        /* To get record length */
12452     xabfhc.xab$l_nxt = (void *) &xabsum;
12453
12454     xabsum = cc$rms_xabsum;        /* To get key and area information */
12455
12456     if (!((sts = sys$open(&fab_in)) & 1)) {
12457       PerlMem_free(vmsin);
12458       PerlMem_free(vmsout);
12459       PerlMem_free(esa);
12460       if (esal != NULL)
12461         PerlMem_free(esal);
12462       PerlMem_free(rsa);
12463       if (rsal != NULL)
12464         PerlMem_free(rsal);
12465       set_vaxc_errno(sts);
12466       switch (sts) {
12467         case RMS$_FNF: case RMS$_DNF:
12468           set_errno(ENOENT); break;
12469         case RMS$_DIR:
12470           set_errno(ENOTDIR); break;
12471         case RMS$_DEV:
12472           set_errno(ENODEV); break;
12473         case RMS$_SYN:
12474           set_errno(EINVAL); break;
12475         case RMS$_PRV:
12476           set_errno(EACCES); break;
12477         default:
12478           set_errno(EVMSERR);
12479       }
12480       return 0;
12481     }
12482
12483     nam_out = nam;
12484     fab_out = fab_in;
12485     fab_out.fab$w_ifi = 0;
12486     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12487     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12488     fab_out.fab$l_fop = FAB$M_SQO;
12489     rms_bind_fab_nam(fab_out, nam_out);
12490     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12491     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12492     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12493     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12494     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12495     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12496     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12497     esal_out = NULL;
12498     rsal_out = NULL;
12499 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12500     esal_out = PerlMem_malloc(VMS_MAXRSS);
12501     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12502     rsal_out = PerlMem_malloc(VMS_MAXRSS);
12503     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12504 #endif
12505     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12506     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12507
12508     if (preserve_dates == 0) {  /* Act like DCL COPY */
12509       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12510       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12511       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12512         PerlMem_free(vmsin);
12513         PerlMem_free(vmsout);
12514         PerlMem_free(esa);
12515         if (esal != NULL)
12516             PerlMem_free(esal);
12517         PerlMem_free(rsa);
12518         if (rsal != NULL)
12519             PerlMem_free(rsal);
12520         PerlMem_free(esa_out);
12521         if (esal_out != NULL)
12522             PerlMem_free(esal_out);
12523         PerlMem_free(rsa_out);
12524         if (rsal_out != NULL)
12525             PerlMem_free(rsal_out);
12526         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12527         set_vaxc_errno(sts);
12528         return 0;
12529       }
12530       fab_out.fab$l_xab = (void *) &xabdat;
12531       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12532         preserve_dates = 1;
12533     }
12534     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12535       preserve_dates =0;      /* bitmask from this point forward   */
12536
12537     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12538     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12539       PerlMem_free(vmsin);
12540       PerlMem_free(vmsout);
12541       PerlMem_free(esa);
12542       if (esal != NULL)
12543           PerlMem_free(esal);
12544       PerlMem_free(rsa);
12545       if (rsal != NULL)
12546           PerlMem_free(rsal);
12547       PerlMem_free(esa_out);
12548       if (esal_out != NULL)
12549           PerlMem_free(esal_out);
12550       PerlMem_free(rsa_out);
12551       if (rsal_out != NULL)
12552           PerlMem_free(rsal_out);
12553       set_vaxc_errno(sts);
12554       switch (sts) {
12555         case RMS$_DNF:
12556           set_errno(ENOENT); break;
12557         case RMS$_DIR:
12558           set_errno(ENOTDIR); break;
12559         case RMS$_DEV:
12560           set_errno(ENODEV); break;
12561         case RMS$_SYN:
12562           set_errno(EINVAL); break;
12563         case RMS$_PRV:
12564           set_errno(EACCES); break;
12565         default:
12566           set_errno(EVMSERR);
12567       }
12568       return 0;
12569     }
12570     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12571     if (preserve_dates & 2) {
12572       /* sys$close() will process xabrdt, not xabdat */
12573       xabrdt = cc$rms_xabrdt;
12574 #ifndef __GNUC__
12575       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12576 #else
12577       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12578        * is unsigned long[2], while DECC & VAXC use a struct */
12579       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12580 #endif
12581       fab_out.fab$l_xab = (void *) &xabrdt;
12582     }
12583
12584     ubf = PerlMem_malloc(32256);
12585     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12586     rab_in = cc$rms_rab;
12587     rab_in.rab$l_fab = &fab_in;
12588     rab_in.rab$l_rop = RAB$M_BIO;
12589     rab_in.rab$l_ubf = ubf;
12590     rab_in.rab$w_usz = 32256;
12591     if (!((sts = sys$connect(&rab_in)) & 1)) {
12592       sys$close(&fab_in); sys$close(&fab_out);
12593       PerlMem_free(vmsin);
12594       PerlMem_free(vmsout);
12595       PerlMem_free(ubf);
12596       PerlMem_free(esa);
12597       if (esal != NULL)
12598           PerlMem_free(esal);
12599       PerlMem_free(rsa);
12600       if (rsal != NULL)
12601           PerlMem_free(rsal);
12602       PerlMem_free(esa_out);
12603       if (esal_out != NULL)
12604           PerlMem_free(esal_out);
12605       PerlMem_free(rsa_out);
12606       if (rsal_out != NULL)
12607           PerlMem_free(rsal_out);
12608       set_errno(EVMSERR); set_vaxc_errno(sts);
12609       return 0;
12610     }
12611
12612     rab_out = cc$rms_rab;
12613     rab_out.rab$l_fab = &fab_out;
12614     rab_out.rab$l_rbf = ubf;
12615     if (!((sts = sys$connect(&rab_out)) & 1)) {
12616       sys$close(&fab_in); sys$close(&fab_out);
12617       PerlMem_free(vmsin);
12618       PerlMem_free(vmsout);
12619       PerlMem_free(ubf);
12620       PerlMem_free(esa);
12621       if (esal != NULL)
12622           PerlMem_free(esal);
12623       PerlMem_free(rsa);
12624       if (rsal != NULL)
12625           PerlMem_free(rsal);
12626       PerlMem_free(esa_out);
12627       if (esal_out != NULL)
12628           PerlMem_free(esal_out);
12629       PerlMem_free(rsa_out);
12630       if (rsal_out != NULL)
12631           PerlMem_free(rsal_out);
12632       set_errno(EVMSERR); set_vaxc_errno(sts);
12633       return 0;
12634     }
12635
12636     while ((sts = sys$read(&rab_in))) {  /* always true  */
12637       if (sts == RMS$_EOF) break;
12638       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12639       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12640         sys$close(&fab_in); sys$close(&fab_out);
12641         PerlMem_free(vmsin);
12642         PerlMem_free(vmsout);
12643         PerlMem_free(ubf);
12644         PerlMem_free(esa);
12645         if (esal != NULL)
12646             PerlMem_free(esal);
12647         PerlMem_free(rsa);
12648         if (rsal != NULL)
12649             PerlMem_free(rsal);
12650         PerlMem_free(esa_out);
12651         if (esal_out != NULL)
12652             PerlMem_free(esal_out);
12653         PerlMem_free(rsa_out);
12654         if (rsal_out != NULL)
12655             PerlMem_free(rsal_out);
12656         set_errno(EVMSERR); set_vaxc_errno(sts);
12657         return 0;
12658       }
12659     }
12660
12661
12662     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12663     sys$close(&fab_in);  sys$close(&fab_out);
12664     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12665
12666     PerlMem_free(vmsin);
12667     PerlMem_free(vmsout);
12668     PerlMem_free(ubf);
12669     PerlMem_free(esa);
12670     if (esal != NULL)
12671         PerlMem_free(esal);
12672     PerlMem_free(rsa);
12673     if (rsal != NULL)
12674         PerlMem_free(rsal);
12675     PerlMem_free(esa_out);
12676     if (esal_out != NULL)
12677         PerlMem_free(esal_out);
12678     PerlMem_free(rsa_out);
12679     if (rsal_out != NULL)
12680         PerlMem_free(rsal_out);
12681
12682     if (!(sts & 1)) {
12683       set_errno(EVMSERR); set_vaxc_errno(sts);
12684       return 0;
12685     }
12686
12687     return 1;
12688
12689 }  /* end of rmscopy() */
12690 /*}}}*/
12691
12692
12693 /***  The following glue provides 'hooks' to make some of the routines
12694  * from this file available from Perl.  These routines are sufficiently
12695  * basic, and are required sufficiently early in the build process,
12696  * that's it's nice to have them available to miniperl as well as the
12697  * full Perl, so they're set up here instead of in an extension.  The
12698  * Perl code which handles importation of these names into a given
12699  * package lives in [.VMS]Filespec.pm in @INC.
12700  */
12701
12702 void
12703 rmsexpand_fromperl(pTHX_ CV *cv)
12704 {
12705   dXSARGS;
12706   char *fspec, *defspec = NULL, *rslt;
12707   STRLEN n_a;
12708   int fs_utf8, dfs_utf8;
12709
12710   fs_utf8 = 0;
12711   dfs_utf8 = 0;
12712   if (!items || items > 2)
12713     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12714   fspec = SvPV(ST(0),n_a);
12715   fs_utf8 = SvUTF8(ST(0));
12716   if (!fspec || !*fspec) XSRETURN_UNDEF;
12717   if (items == 2) {
12718     defspec = SvPV(ST(1),n_a);
12719     dfs_utf8 = SvUTF8(ST(1));
12720   }
12721   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12722   ST(0) = sv_newmortal();
12723   if (rslt != NULL) {
12724     sv_usepvn(ST(0),rslt,strlen(rslt));
12725     if (fs_utf8) {
12726         SvUTF8_on(ST(0));
12727     }
12728   }
12729   XSRETURN(1);
12730 }
12731
12732 void
12733 vmsify_fromperl(pTHX_ CV *cv)
12734 {
12735   dXSARGS;
12736   char *vmsified;
12737   STRLEN n_a;
12738   int utf8_fl;
12739
12740   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12741   utf8_fl = SvUTF8(ST(0));
12742   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12743   ST(0) = sv_newmortal();
12744   if (vmsified != NULL) {
12745     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12746     if (utf8_fl) {
12747         SvUTF8_on(ST(0));
12748     }
12749   }
12750   XSRETURN(1);
12751 }
12752
12753 void
12754 unixify_fromperl(pTHX_ CV *cv)
12755 {
12756   dXSARGS;
12757   char *unixified;
12758   STRLEN n_a;
12759   int utf8_fl;
12760
12761   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12762   utf8_fl = SvUTF8(ST(0));
12763   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12764   ST(0) = sv_newmortal();
12765   if (unixified != NULL) {
12766     sv_usepvn(ST(0),unixified,strlen(unixified));
12767     if (utf8_fl) {
12768         SvUTF8_on(ST(0));
12769     }
12770   }
12771   XSRETURN(1);
12772 }
12773
12774 void
12775 fileify_fromperl(pTHX_ CV *cv)
12776 {
12777   dXSARGS;
12778   char *fileified;
12779   STRLEN n_a;
12780   int utf8_fl;
12781
12782   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12783   utf8_fl = SvUTF8(ST(0));
12784   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12785   ST(0) = sv_newmortal();
12786   if (fileified != NULL) {
12787     sv_usepvn(ST(0),fileified,strlen(fileified));
12788     if (utf8_fl) {
12789         SvUTF8_on(ST(0));
12790     }
12791   }
12792   XSRETURN(1);
12793 }
12794
12795 void
12796 pathify_fromperl(pTHX_ CV *cv)
12797 {
12798   dXSARGS;
12799   char *pathified;
12800   STRLEN n_a;
12801   int utf8_fl;
12802
12803   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12804   utf8_fl = SvUTF8(ST(0));
12805   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12806   ST(0) = sv_newmortal();
12807   if (pathified != NULL) {
12808     sv_usepvn(ST(0),pathified,strlen(pathified));
12809     if (utf8_fl) {
12810         SvUTF8_on(ST(0));
12811     }
12812   }
12813   XSRETURN(1);
12814 }
12815
12816 void
12817 vmspath_fromperl(pTHX_ CV *cv)
12818 {
12819   dXSARGS;
12820   char *vmspath;
12821   STRLEN n_a;
12822   int utf8_fl;
12823
12824   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12825   utf8_fl = SvUTF8(ST(0));
12826   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12827   ST(0) = sv_newmortal();
12828   if (vmspath != NULL) {
12829     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12830     if (utf8_fl) {
12831         SvUTF8_on(ST(0));
12832     }
12833   }
12834   XSRETURN(1);
12835 }
12836
12837 void
12838 unixpath_fromperl(pTHX_ CV *cv)
12839 {
12840   dXSARGS;
12841   char *unixpath;
12842   STRLEN n_a;
12843   int utf8_fl;
12844
12845   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12846   utf8_fl = SvUTF8(ST(0));
12847   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12848   ST(0) = sv_newmortal();
12849   if (unixpath != NULL) {
12850     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12851     if (utf8_fl) {
12852         SvUTF8_on(ST(0));
12853     }
12854   }
12855   XSRETURN(1);
12856 }
12857
12858 void
12859 candelete_fromperl(pTHX_ CV *cv)
12860 {
12861   dXSARGS;
12862   char *fspec, *fsp;
12863   SV *mysv;
12864   IO *io;
12865   STRLEN n_a;
12866
12867   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12868
12869   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12870   Newx(fspec, VMS_MAXRSS, char);
12871   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12872   if (isGV_with_GP(mysv)) {
12873     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12874       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12875       ST(0) = &PL_sv_no;
12876       Safefree(fspec);
12877       XSRETURN(1);
12878     }
12879     fsp = fspec;
12880   }
12881   else {
12882     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12883       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12884       ST(0) = &PL_sv_no;
12885       Safefree(fspec);
12886       XSRETURN(1);
12887     }
12888   }
12889
12890   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12891   Safefree(fspec);
12892   XSRETURN(1);
12893 }
12894
12895 void
12896 rmscopy_fromperl(pTHX_ CV *cv)
12897 {
12898   dXSARGS;
12899   char *inspec, *outspec, *inp, *outp;
12900   int date_flag;
12901   SV *mysv;
12902   IO *io;
12903   STRLEN n_a;
12904
12905   if (items < 2 || items > 3)
12906     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12907
12908   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12909   Newx(inspec, VMS_MAXRSS, char);
12910   if (isGV_with_GP(mysv)) {
12911     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12912       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12913       ST(0) = sv_2mortal(newSViv(0));
12914       Safefree(inspec);
12915       XSRETURN(1);
12916     }
12917     inp = inspec;
12918   }
12919   else {
12920     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12921       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12922       ST(0) = sv_2mortal(newSViv(0));
12923       Safefree(inspec);
12924       XSRETURN(1);
12925     }
12926   }
12927   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12928   Newx(outspec, VMS_MAXRSS, char);
12929   if (isGV_with_GP(mysv)) {
12930     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12931       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12932       ST(0) = sv_2mortal(newSViv(0));
12933       Safefree(inspec);
12934       Safefree(outspec);
12935       XSRETURN(1);
12936     }
12937     outp = outspec;
12938   }
12939   else {
12940     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12941       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12942       ST(0) = sv_2mortal(newSViv(0));
12943       Safefree(inspec);
12944       Safefree(outspec);
12945       XSRETURN(1);
12946     }
12947   }
12948   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12949
12950   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12951   Safefree(inspec);
12952   Safefree(outspec);
12953   XSRETURN(1);
12954 }
12955
12956 /* The mod2fname is limited to shorter filenames by design, so it should
12957  * not be modified to support longer EFS pathnames
12958  */
12959 void
12960 mod2fname(pTHX_ CV *cv)
12961 {
12962   dXSARGS;
12963   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12964        workbuff[NAM$C_MAXRSS*1 + 1];
12965   int counter, num_entries;
12966   /* ODS-5 ups this, but we want to be consistent, so... */
12967   int max_name_len = 39;
12968   AV *in_array = (AV *)SvRV(ST(0));
12969
12970   num_entries = av_len(in_array);
12971
12972   /* All the names start with PL_. */
12973   strcpy(ultimate_name, "PL_");
12974
12975   /* Clean up our working buffer */
12976   Zero(work_name, sizeof(work_name), char);
12977
12978   /* Run through the entries and build up a working name */
12979   for(counter = 0; counter <= num_entries; counter++) {
12980     /* If it's not the first name then tack on a __ */
12981     if (counter) {
12982       my_strlcat(work_name, "__", sizeof(work_name));
12983     }
12984     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12985   }
12986
12987   /* Check to see if we actually have to bother...*/
12988   if (strlen(work_name) + 3 <= max_name_len) {
12989     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12990   } else {
12991     /* It's too darned big, so we need to go strip. We use the same */
12992     /* algorithm as xsubpp does. First, strip out doubled __ */
12993     char *source, *dest, last;
12994     dest = workbuff;
12995     last = 0;
12996     for (source = work_name; *source; source++) {
12997       if (last == *source && last == '_') {
12998         continue;
12999       }
13000       *dest++ = *source;
13001       last = *source;
13002     }
13003     /* Go put it back */
13004     my_strlcpy(work_name, workbuff, sizeof(work_name));
13005     /* Is it still too big? */
13006     if (strlen(work_name) + 3 > max_name_len) {
13007       /* Strip duplicate letters */
13008       last = 0;
13009       dest = workbuff;
13010       for (source = work_name; *source; source++) {
13011         if (last == toupper(*source)) {
13012         continue;
13013         }
13014         *dest++ = *source;
13015         last = toupper(*source);
13016       }
13017       my_strlcpy(work_name, workbuff, sizeof(work_name));
13018     }
13019
13020     /* Is it *still* too big? */
13021     if (strlen(work_name) + 3 > max_name_len) {
13022       /* Too bad, we truncate */
13023       work_name[max_name_len - 2] = 0;
13024     }
13025     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
13026   }
13027
13028   /* Okay, return it */
13029   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13030   XSRETURN(1);
13031 }
13032
13033 void
13034 hushexit_fromperl(pTHX_ CV *cv)
13035 {
13036     dXSARGS;
13037
13038     if (items > 0) {
13039         VMSISH_HUSHED = SvTRUE(ST(0));
13040     }
13041     ST(0) = boolSV(VMSISH_HUSHED);
13042     XSRETURN(1);
13043 }
13044
13045
13046 PerlIO *
13047 Perl_vms_start_glob
13048    (pTHX_ SV *tmpglob,
13049     IO *io)
13050 {
13051     PerlIO *fp;
13052     struct vs_str_st *rslt;
13053     char *vmsspec;
13054     char *rstr;
13055     char *begin, *cp;
13056     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13057     PerlIO *tmpfp;
13058     STRLEN i;
13059     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13060     struct dsc$descriptor_vs rsdsc;
13061     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13062     unsigned long hasver = 0, isunix = 0;
13063     unsigned long int lff_flags = 0;
13064     int rms_sts;
13065     int vms_old_glob = 1;
13066
13067     if (!SvOK(tmpglob)) {
13068         SETERRNO(ENOENT,RMS$_FNF);
13069         return NULL;
13070     }
13071
13072     vms_old_glob = !decc_filename_unix_report;
13073
13074 #ifdef VMS_LONGNAME_SUPPORT
13075     lff_flags = LIB$M_FIL_LONG_NAMES;
13076 #endif
13077     /* The Newx macro will not allow me to assign a smaller array
13078      * to the rslt pointer, so we will assign it to the begin char pointer
13079      * and then copy the value into the rslt pointer.
13080      */
13081     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13082     rslt = (struct vs_str_st *)begin;
13083     rslt->length = 0;
13084     rstr = &rslt->str[0];
13085     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13086     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13087     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13088     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13089
13090     Newx(vmsspec, VMS_MAXRSS, char);
13091
13092         /* We could find out if there's an explicit dev/dir or version
13093            by peeking into lib$find_file's internal context at
13094            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13095            but that's unsupported, so I don't want to do it now and
13096            have it bite someone in the future. */
13097         /* Fix-me: vms_split_path() is the only way to do this, the
13098            existing method will fail with many legal EFS or UNIX specifications
13099          */
13100
13101     cp = SvPV(tmpglob,i);
13102
13103     for (; i; i--) {
13104         if (cp[i] == ';') hasver = 1;
13105         if (cp[i] == '.') {
13106             if (sts) hasver = 1;
13107             else sts = 1;
13108         }
13109         if (cp[i] == '/') {
13110             hasdir = isunix = 1;
13111             break;
13112         }
13113         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13114             hasdir = 1;
13115             break;
13116         }
13117     }
13118
13119     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13120     if ((hasdir == 0) && decc_filename_unix_report) {
13121         isunix = 1;
13122     }
13123
13124     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13125         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13126         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13127         int wildstar = 0;
13128         int wildquery = 0;
13129         int found = 0;
13130         Stat_t st;
13131         int stat_sts;
13132         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13133         if (!stat_sts && S_ISDIR(st.st_mode)) {
13134             char * vms_dir;
13135             const char * fname;
13136             STRLEN fname_len;
13137
13138             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13139             /* path delimiter of ':>]', if so, then the old behavior has */
13140             /* obviously been specifically requested */
13141
13142             fname = SvPVX_const(tmpglob);
13143             fname_len = strlen(fname);
13144             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13145             if (vms_old_glob || (vms_dir != NULL)) {
13146                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13147                                             SvPVX(tmpglob),vmsspec,NULL);
13148                 ok = (wilddsc.dsc$a_pointer != NULL);
13149                 /* maybe passed 'foo' rather than '[.foo]', thus not
13150                    detected above */
13151                 hasdir = 1;
13152             } else {
13153                 /* Operate just on the directory, the special stat/fstat for */
13154                 /* leaves the fileified  specification in the st_devnam */
13155                 /* member. */
13156                 wilddsc.dsc$a_pointer = st.st_devnam;
13157                 ok = 1;
13158             }
13159         }
13160         else {
13161             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13162             ok = (wilddsc.dsc$a_pointer != NULL);
13163         }
13164         if (ok)
13165             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13166
13167         /* If not extended character set, replace ? with % */
13168         /* With extended character set, ? is a wildcard single character */
13169         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13170             if (*cp == '?') {
13171                 wildquery = 1;
13172                 if (!decc_efs_charset)
13173                     *cp = '%';
13174             } else if (*cp == '%') {
13175                 wildquery = 1;
13176             } else if (*cp == '*') {
13177                 wildstar = 1;
13178             }
13179         }
13180
13181         if (ok) {
13182             wv_sts = vms_split_path(
13183                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13184                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13185                 &wvs_spec, &wvs_len);
13186         } else {
13187             wn_spec = NULL;
13188             wn_len = 0;
13189             we_spec = NULL;
13190             we_len = 0;
13191         }
13192
13193         sts = SS$_NORMAL;
13194         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13195          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13196          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13197          int valid_find;
13198
13199             valid_find = 0;
13200             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13201                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13202             if (!$VMS_STATUS_SUCCESS(sts))
13203                 break;
13204
13205             /* with varying string, 1st word of buffer contains result length */
13206             rstr[rslt->length] = '\0';
13207
13208              /* Find where all the components are */
13209              v_sts = vms_split_path
13210                        (rstr,
13211                         &v_spec,
13212                         &v_len,
13213                         &r_spec,
13214                         &r_len,
13215                         &d_spec,
13216                         &d_len,
13217                         &n_spec,
13218                         &n_len,
13219                         &e_spec,
13220                         &e_len,
13221                         &vs_spec,
13222                         &vs_len);
13223
13224             /* If no version on input, truncate the version on output */
13225             if (!hasver && (vs_len > 0)) {
13226                 *vs_spec = '\0';
13227                 vs_len = 0;
13228             }
13229
13230             if (isunix) {
13231
13232                 /* In Unix report mode, remove the ".dir;1" from the name */
13233                 /* if it is a real directory */
13234                 if (decc_filename_unix_report || decc_efs_charset) {
13235                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13236                         Stat_t statbuf;
13237                         int ret_sts;
13238
13239                         ret_sts = flex_lstat(rstr, &statbuf);
13240                         if ((ret_sts == 0) &&
13241                             S_ISDIR(statbuf.st_mode)) {
13242                             e_len = 0;
13243                             e_spec[0] = 0;
13244                         }
13245                     }
13246                 }
13247
13248                 /* No version & a null extension on UNIX handling */
13249                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13250                     e_len = 0;
13251                     *e_spec = '\0';
13252                 }
13253             }
13254
13255             if (!decc_efs_case_preserve) {
13256                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13257             }
13258
13259             /* Find File treats a Null extension as return all extensions */
13260             /* This is contrary to Perl expectations */
13261
13262             if (wildstar || wildquery || vms_old_glob) {
13263                 /* really need to see if the returned file name matched */
13264                 /* but for now will assume that it matches */
13265                 valid_find = 1;
13266             } else {
13267                 /* Exact Match requested */
13268                 /* How are directories handled? - like a file */
13269                 if ((e_len == we_len) && (n_len == wn_len)) {
13270                     int t1;
13271                     t1 = e_len;
13272                     if (t1 > 0)
13273                         t1 = strncmp(e_spec, we_spec, e_len);
13274                     if (t1 == 0) {
13275                        t1 = n_len;
13276                        if (t1 > 0)
13277                            t1 = strncmp(n_spec, we_spec, n_len);
13278                        if (t1 == 0)
13279                            valid_find = 1;
13280                     }
13281                 }
13282             }
13283
13284             if (valid_find) {
13285                 found++;
13286
13287                 if (hasdir) {
13288                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13289                     begin = rstr;
13290                 }
13291                 else {
13292                     /* Start with the name */
13293                     begin = n_spec;
13294                 }
13295                 strcat(begin,"\n");
13296                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13297             }
13298         }
13299         if (cxt) (void)lib$find_file_end(&cxt);
13300
13301         if (!found) {
13302             /* Be POSIXish: return the input pattern when no matches */
13303             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13304             strcat(rstr,"\n");
13305             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13306         }
13307
13308         if (ok && sts != RMS$_NMF &&
13309             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13310         if (!ok) {
13311             if (!(sts & 1)) {
13312                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13313             }
13314             PerlIO_close(tmpfp);
13315             fp = NULL;
13316         }
13317         else {
13318             PerlIO_rewind(tmpfp);
13319             IoTYPE(io) = IoTYPE_RDONLY;
13320             IoIFP(io) = fp = tmpfp;
13321             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13322         }
13323     }
13324     Safefree(vmsspec);
13325     Safefree(rslt);
13326     return fp;
13327 }
13328
13329
13330 static char *
13331 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13332                    int *utf8_fl);
13333
13334 void
13335 unixrealpath_fromperl(pTHX_ CV *cv)
13336 {
13337     dXSARGS;
13338     char *fspec, *rslt_spec, *rslt;
13339     STRLEN n_a;
13340
13341     if (!items || items != 1)
13342         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13343
13344     fspec = SvPV(ST(0),n_a);
13345     if (!fspec || !*fspec) XSRETURN_UNDEF;
13346
13347     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13348     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13349
13350     ST(0) = sv_newmortal();
13351     if (rslt != NULL)
13352         sv_usepvn(ST(0),rslt,strlen(rslt));
13353     else
13354         Safefree(rslt_spec);
13355         XSRETURN(1);
13356 }
13357
13358 static char *
13359 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13360                    int *utf8_fl);
13361
13362 void
13363 vmsrealpath_fromperl(pTHX_ CV *cv)
13364 {
13365     dXSARGS;
13366     char *fspec, *rslt_spec, *rslt;
13367     STRLEN n_a;
13368
13369     if (!items || items != 1)
13370         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13371
13372     fspec = SvPV(ST(0),n_a);
13373     if (!fspec || !*fspec) XSRETURN_UNDEF;
13374
13375     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13376     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13377
13378     ST(0) = sv_newmortal();
13379     if (rslt != NULL)
13380         sv_usepvn(ST(0),rslt,strlen(rslt));
13381     else
13382         Safefree(rslt_spec);
13383         XSRETURN(1);
13384 }
13385
13386 #ifdef HAS_SYMLINK
13387 /*
13388  * A thin wrapper around decc$symlink to make sure we follow the
13389  * standard and do not create a symlink with a zero-length name.
13390  *
13391  * Also in ODS-2 mode, existing tests assume that the link target
13392  * will be converted to UNIX format.
13393  */
13394 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13395 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13396   if (!link_name || !*link_name) {
13397     SETERRNO(ENOENT, SS$_NOSUCHFILE);
13398     return -1;
13399   }
13400
13401   if (decc_efs_charset) {
13402       return symlink(contents, link_name);
13403   } else {
13404       int sts;
13405       char * utarget;
13406
13407       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13408       /* because in order to work, the symlink target must be in UNIX format */
13409
13410       /* As symbolic links can hold things other than files, we will only do */
13411       /* the conversion in in ODS-2 mode */
13412
13413       utarget = PerlMem_malloc(VMS_MAXRSS + 1);
13414       if (int_tounixspec(contents, utarget, NULL) == NULL) {
13415
13416           /* This should not fail, as an untranslatable filename */
13417           /* should be passed through */
13418           utarget = (char *)contents;
13419       }
13420       sts = symlink(utarget, link_name);
13421       PerlMem_free(utarget);
13422       return sts;
13423   }
13424
13425 }
13426 /*}}}*/
13427
13428 #endif /* HAS_SYMLINK */
13429
13430 int do_vms_case_tolerant(void);
13431
13432 void
13433 case_tolerant_process_fromperl(pTHX_ CV *cv)
13434 {
13435   dXSARGS;
13436   ST(0) = boolSV(do_vms_case_tolerant());
13437   XSRETURN(1);
13438 }
13439
13440 #ifdef USE_ITHREADS
13441
13442 void
13443 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13444                           struct interp_intern *dst)
13445 {
13446     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13447
13448     memcpy(dst,src,sizeof(struct interp_intern));
13449 }
13450
13451 #endif
13452
13453 void
13454 Perl_sys_intern_clear(pTHX)
13455 {
13456 }
13457
13458 void
13459 Perl_sys_intern_init(pTHX)
13460 {
13461     unsigned int ix = RAND_MAX;
13462     double x;
13463
13464     VMSISH_HUSHED = 0;
13465
13466     MY_POSIX_EXIT = vms_posix_exit;
13467
13468     x = (float)ix;
13469     MY_INV_RAND_MAX = 1./x;
13470 }
13471
13472 void
13473 init_os_extras(void)
13474 {
13475   dTHX;
13476   char* file = __FILE__;
13477   if (decc_disable_to_vms_logname_translation) {
13478     no_translate_barewords = TRUE;
13479   } else {
13480     no_translate_barewords = FALSE;
13481   }
13482
13483   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13484   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13485   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13486   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13487   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13488   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13489   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13490   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13491   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13492   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13493   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13494   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13495   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13496   newXSproto("VMS::Filespec::case_tolerant_process",
13497       case_tolerant_process_fromperl,file,"");
13498
13499   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13500
13501   return;
13502 }
13503
13504 #if __CRTL_VER == 80200000
13505 /* This missed getting in to the DECC SDK for 8.2 */
13506 char *realpath(const char *file_name, char * resolved_name, ...);
13507 #endif
13508
13509 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13510 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13511  * The perl fallback routine to provide realpath() is not as efficient
13512  * on OpenVMS.
13513  */
13514
13515 /* Hack, use old stat() as fastest way of getting ino_t and device */
13516 int decc$stat(const char *name, void * statbuf);
13517 #if !defined(__VAX) && __CRTL_VER >= 80200000
13518 int decc$lstat(const char *name, void * statbuf);
13519 #else
13520 #define decc$lstat decc$stat
13521 #endif
13522
13523
13524 /* Realpath is fragile.  In 8.3 it does not work if the feature
13525  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13526  * links are implemented in RMS, not the CRTL. It also can fail if the
13527  * user does not have read/execute access to some of the directories.
13528  * So in order for Do What I Mean mode to work, if realpath() fails,
13529  * fall back to looking up the filename by the device name and FID.
13530  */
13531
13532 int vms_fid_to_name(char * outname, int outlen,
13533                     const char * name, int lstat_flag, mode_t * mode)
13534 {
13535 #pragma message save
13536 #pragma message disable MISALGNDSTRCT
13537 #pragma message disable MISALGNDMEM
13538 #pragma member_alignment save
13539 #pragma nomember_alignment
13540 struct statbuf_t {
13541     char           * st_dev;
13542     unsigned short st_ino[3];
13543     unsigned short old_st_mode;
13544     unsigned long  padl[30];  /* plenty of room */
13545 } statbuf;
13546 #pragma message restore
13547 #pragma member_alignment restore
13548
13549     int sts;
13550     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13551     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13552     char *fileified;
13553     char *temp_fspec;
13554     char *ret_spec;
13555
13556     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13557      * unexpected answers
13558      */
13559
13560     fileified = PerlMem_malloc(VMS_MAXRSS);
13561     if (fileified == NULL)
13562         _ckvmssts_noperl(SS$_INSFMEM);
13563
13564     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
13565     if (temp_fspec == NULL)
13566         _ckvmssts_noperl(SS$_INSFMEM);
13567
13568     sts = -1;
13569     /* First need to try as a directory */
13570     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13571     if (ret_spec != NULL) {
13572         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13573         if (ret_spec != NULL) {
13574             if (lstat_flag == 0)
13575                 sts = decc$stat(fileified, &statbuf);
13576             else
13577                 sts = decc$lstat(fileified, &statbuf);
13578         }
13579     }
13580
13581     /* Then as a VMS file spec */
13582     if (sts != 0) {
13583         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13584         if (ret_spec != NULL) {
13585             if (lstat_flag == 0) {
13586                 sts = decc$stat(temp_fspec, &statbuf);
13587             } else {
13588                 sts = decc$lstat(temp_fspec, &statbuf);
13589             }
13590         }
13591     }
13592
13593     if (sts) {
13594         /* Next try - allow multiple dots with out EFS CHARSET */
13595         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13596          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13597          * enable it if it isn't already.
13598          */
13599 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13600         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13601             decc$feature_set_value(decc_efs_charset_index, 1, 1);
13602 #endif
13603         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13604         if (lstat_flag == 0) {
13605             sts = decc$stat(name, &statbuf);
13606         } else {
13607             sts = decc$lstat(name, &statbuf);
13608         }
13609 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13610         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13611             decc$feature_set_value(decc_efs_charset_index, 1, 0);
13612 #endif
13613     }
13614
13615
13616     /* and then because the Perl Unix to VMS conversion is not perfect */
13617     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13618     /* characters from filenames so we need to try it as-is */
13619     if (sts) {
13620         if (lstat_flag == 0) {
13621             sts = decc$stat(name, &statbuf);
13622         } else {
13623             sts = decc$lstat(name, &statbuf);
13624         }
13625     }
13626
13627     if (sts == 0) {
13628         int vms_sts;
13629
13630         dvidsc.dsc$a_pointer=statbuf.st_dev;
13631         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13632
13633         specdsc.dsc$a_pointer = outname;
13634         specdsc.dsc$w_length = outlen-1;
13635
13636         vms_sts = lib$fid_to_name
13637             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13638         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13639             outname[specdsc.dsc$w_length] = 0;
13640
13641             /* Return the mode */
13642             if (mode) {
13643                 *mode = statbuf.old_st_mode;
13644             }
13645         }
13646     }
13647     PerlMem_free(temp_fspec);
13648     PerlMem_free(fileified);
13649     return sts;
13650 }
13651
13652
13653
13654 static char *
13655 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13656                    int *utf8_fl)
13657 {
13658     char * rslt = NULL;
13659
13660 #ifdef HAS_SYMLINK
13661     if (decc_posix_compliant_pathnames > 0 ) {
13662         /* realpath currently only works if posix compliant pathnames are
13663          * enabled.  It may start working when they are not, but in that
13664          * case we still want the fallback behavior for backwards compatibility
13665          */
13666         rslt = realpath(filespec, outbuf);
13667     }
13668 #endif
13669
13670     if (rslt == NULL) {
13671         char * vms_spec;
13672         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13673         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13674         mode_t my_mode;
13675
13676         /* Fall back to fid_to_name */
13677
13678         Newx(vms_spec, VMS_MAXRSS + 1, char);
13679
13680         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13681         if (sts == 0) {
13682
13683
13684             /* Now need to trim the version off */
13685             sts = vms_split_path
13686                   (vms_spec,
13687                    &v_spec,
13688                    &v_len,
13689                    &r_spec,
13690                    &r_len,
13691                    &d_spec,
13692                    &d_len,
13693                    &n_spec,
13694                    &n_len,
13695                    &e_spec,
13696                    &e_len,
13697                    &vs_spec,
13698                    &vs_len);
13699
13700
13701                 if (sts == 0) {
13702                     int haslower = 0;
13703                     const char *cp;
13704
13705                     /* Trim off the version */
13706                     int file_len = v_len + r_len + d_len + n_len + e_len;
13707                     vms_spec[file_len] = 0;
13708
13709                     /* Trim off the .DIR if this is a directory */
13710                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13711                         if (S_ISDIR(my_mode)) {
13712                             e_len = 0;
13713                             e_spec[0] = 0;
13714                         }
13715                     }
13716
13717                     /* Drop NULL extensions on UNIX file specification */
13718                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
13719                         e_len = 0;
13720                         e_spec[0] = '\0';
13721                     }
13722
13723                     /* The result is expected to be in UNIX format */
13724                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13725
13726                     /* Downcase if input had any lower case letters and
13727                      * case preservation is not in effect.
13728                      */
13729                     if (!decc_efs_case_preserve) {
13730                         for (cp = filespec; *cp; cp++)
13731                             if (islower(*cp)) { haslower = 1; break; }
13732
13733                         if (haslower) __mystrtolower(rslt);
13734                     }
13735                 }
13736         } else {
13737
13738             /* Now for some hacks to deal with backwards and forward */
13739             /* compatibility */
13740             if (!decc_efs_charset) {
13741
13742                 /* 1. ODS-2 mode wants to do a syntax only translation */
13743                 rslt = int_rmsexpand(filespec, outbuf,
13744                                     NULL, 0, NULL, utf8_fl);
13745
13746             } else {
13747                 if (decc_filename_unix_report) {
13748                     char * dir_name;
13749                     char * vms_dir_name;
13750                     char * file_name;
13751
13752                     /* 2. ODS-5 / UNIX report mode should return a failure */
13753                     /*    if the parent directory also does not exist */
13754                     /*    Otherwise, get the real path for the parent */
13755                     /*    and add the child to it. */
13756
13757                     /* basename / dirname only available for VMS 7.0+ */
13758                     /* So we may need to implement them as common routines */
13759
13760                     Newx(dir_name, VMS_MAXRSS + 1, char);
13761                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13762                     dir_name[0] = '\0';
13763                     file_name = NULL;
13764
13765                     /* First try a VMS parse */
13766                     sts = vms_split_path
13767                           (filespec,
13768                            &v_spec,
13769                            &v_len,
13770                            &r_spec,
13771                            &r_len,
13772                            &d_spec,
13773                            &d_len,
13774                            &n_spec,
13775                            &n_len,
13776                            &e_spec,
13777                            &e_len,
13778                            &vs_spec,
13779                            &vs_len);
13780
13781                     if (sts == 0) {
13782                         /* This is VMS */
13783
13784                         int dir_len = v_len + r_len + d_len + n_len;
13785                         if (dir_len > 0) {
13786                            memcpy(dir_name, filespec, dir_len);
13787                            dir_name[dir_len] = '\0';
13788                            file_name = (char *)&filespec[dir_len + 1];
13789                         }
13790                     } else {
13791                         /* This must be UNIX */
13792                         char * tchar;
13793
13794                         tchar = strrchr(filespec, '/');
13795
13796                         if (tchar != NULL) {
13797                             int dir_len = tchar - filespec;
13798                             memcpy(dir_name, filespec, dir_len);
13799                             dir_name[dir_len] = '\0';
13800                             file_name = (char *) &filespec[dir_len + 1];
13801                         }
13802                     }
13803
13804                     /* Dir name is defaulted */
13805                     if (dir_name[0] == 0) {
13806                         dir_name[0] = '.';
13807                         dir_name[1] = '\0';
13808                     }
13809
13810                     /* Need realpath for the directory */
13811                     sts = vms_fid_to_name(vms_dir_name,
13812                                           VMS_MAXRSS + 1,
13813                                           dir_name, 0, NULL);
13814
13815                     if (sts == 0) {
13816                         /* Now need to pathify it. */
13817                         char *tdir = int_pathify_dirspec(vms_dir_name,
13818                                                          outbuf);
13819
13820                         /* And now add the original filespec to it */
13821                         if (file_name != NULL) {
13822                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13823                         }
13824                         return outbuf;
13825                     }
13826                     Safefree(vms_dir_name);
13827                     Safefree(dir_name);
13828                 }
13829             }
13830         }
13831         Safefree(vms_spec);
13832     }
13833     return rslt;
13834 }
13835
13836 static char *
13837 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13838                    int *utf8_fl)
13839 {
13840     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13841     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13842
13843     /* Fall back to fid_to_name */
13844
13845     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13846     if (sts != 0) {
13847         return NULL;
13848     }
13849     else {
13850
13851
13852         /* Now need to trim the version off */
13853         sts = vms_split_path
13854                   (outbuf,
13855                    &v_spec,
13856                    &v_len,
13857                    &r_spec,
13858                    &r_len,
13859                    &d_spec,
13860                    &d_len,
13861                    &n_spec,
13862                    &n_len,
13863                    &e_spec,
13864                    &e_len,
13865                    &vs_spec,
13866                    &vs_len);
13867
13868
13869         if (sts == 0) {
13870             int haslower = 0;
13871             const char *cp;
13872
13873             /* Trim off the version */
13874             int file_len = v_len + r_len + d_len + n_len + e_len;
13875             outbuf[file_len] = 0;
13876
13877             /* Downcase if input had any lower case letters and
13878              * case preservation is not in effect.
13879              */
13880             if (!decc_efs_case_preserve) {
13881                 for (cp = filespec; *cp; cp++)
13882                     if (islower(*cp)) { haslower = 1; break; }
13883
13884                 if (haslower) __mystrtolower(outbuf);
13885             }
13886         }
13887     }
13888     return outbuf;
13889 }
13890
13891
13892 /*}}}*/
13893 /* External entry points */
13894 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13895 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13896
13897 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13898 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13899
13900 /* case_tolerant */
13901
13902 /*{{{int do_vms_case_tolerant(void)*/
13903 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13904  * controlled by a process setting.
13905  */
13906 int do_vms_case_tolerant(void)
13907 {
13908     return vms_process_case_tolerant;
13909 }
13910 /*}}}*/
13911 /* External entry points */
13912 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13913 int Perl_vms_case_tolerant(void)
13914 { return do_vms_case_tolerant(); }
13915 #else
13916 int Perl_vms_case_tolerant(void)
13917 { return vms_process_case_tolerant; }
13918 #endif
13919
13920
13921  /* Start of DECC RTL Feature handling */
13922
13923
13924 /* C RTL Feature settings */
13925
13926 static int set_features
13927    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
13928     int (* cli_routine)(void),  /* Not documented */
13929     void *image_info)           /* Not documented */
13930 {
13931     int status;
13932     int s;
13933     char val_str[10];
13934 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13935     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13936     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13937     unsigned long case_perm;
13938     unsigned long case_image;
13939 #endif
13940
13941     /* Allow an exception to bring Perl into the VMS debugger */
13942     vms_debug_on_exception = 0;
13943     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13944     if ($VMS_STATUS_SUCCESS(status)) {
13945        val_str[0] = _toupper(val_str[0]);
13946        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13947          vms_debug_on_exception = 1;
13948        else
13949          vms_debug_on_exception = 0;
13950     }
13951
13952     /* Debug unix/vms file translation routines */
13953     vms_debug_fileify = 0;
13954     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13955     if ($VMS_STATUS_SUCCESS(status)) {
13956         val_str[0] = _toupper(val_str[0]);
13957         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13958             vms_debug_fileify = 1;
13959         else
13960             vms_debug_fileify = 0;
13961     }
13962
13963
13964     /* Historically PERL has been doing vmsify / stat differently than */
13965     /* the CRTL.  In particular, under some conditions the CRTL will   */
13966     /* remove some illegal characters like spaces from filenames       */
13967     /* resulting in some differences.  The stat()/lstat() wrapper has  */
13968     /* been reporting such file names as invalid and fails to stat them */
13969     /* fixing this bug so that stat()/lstat() accept these like the     */
13970     /* CRTL does will result in several tests failing.                  */
13971     /* This should really be fixed, but for now, set up a feature to    */
13972     /* enable it so that the impact can be studied.                     */
13973     vms_bug_stat_filename = 0;
13974     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13975     if ($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_bug_stat_filename = 1;
13979         else
13980             vms_bug_stat_filename = 0;
13981     }
13982
13983
13984     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13985     vms_vtf7_filenames = 0;
13986     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13987     if ($VMS_STATUS_SUCCESS(status)) {
13988        val_str[0] = _toupper(val_str[0]);
13989        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13990          vms_vtf7_filenames = 1;
13991        else
13992          vms_vtf7_filenames = 0;
13993     }
13994
13995     /* unlink all versions on unlink() or rename() */
13996     vms_unlink_all_versions = 0;
13997     status = simple_trnlnm
13998         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13999     if ($VMS_STATUS_SUCCESS(status)) {
14000        val_str[0] = _toupper(val_str[0]);
14001        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14002          vms_unlink_all_versions = 1;
14003        else
14004          vms_unlink_all_versions = 0;
14005     }
14006
14007     /* Dectect running under GNV Bash or other UNIX like shell */
14008 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14009     gnv_unix_shell = 0;
14010     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14011     if ($VMS_STATUS_SUCCESS(status)) {
14012          gnv_unix_shell = 1;
14013          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14014          set_feature_default("DECC$EFS_CHARSET", 1);
14015          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14016          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14017          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14018          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14019          vms_unlink_all_versions = 1;
14020          vms_posix_exit = 1;
14021     }
14022 #endif
14023
14024     /* hacks to see if known bugs are still present for testing */
14025
14026     /* PCP mode requires creating /dev/null special device file */
14027     decc_bug_devnull = 0;
14028     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14029     if ($VMS_STATUS_SUCCESS(status)) {
14030        val_str[0] = _toupper(val_str[0]);
14031        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14032           decc_bug_devnull = 1;
14033        else
14034           decc_bug_devnull = 0;
14035     }
14036
14037     /* UNIX directory names with no paths are broken in a lot of places */
14038     decc_dir_barename = 1;
14039     status = simple_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14040     if ($VMS_STATUS_SUCCESS(status)) {
14041       val_str[0] = _toupper(val_str[0]);
14042       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14043         decc_dir_barename = 1;
14044       else
14045         decc_dir_barename = 0;
14046     }
14047
14048 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14049     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14050     if (s >= 0) {
14051         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14052         if (decc_disable_to_vms_logname_translation < 0)
14053             decc_disable_to_vms_logname_translation = 0;
14054     }
14055
14056     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14057     if (s >= 0) {
14058         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14059         if (decc_efs_case_preserve < 0)
14060             decc_efs_case_preserve = 0;
14061     }
14062
14063     s = decc$feature_get_index("DECC$EFS_CHARSET");
14064     decc_efs_charset_index = s;
14065     if (s >= 0) {
14066         decc_efs_charset = decc$feature_get_value(s, 1);
14067         if (decc_efs_charset < 0)
14068             decc_efs_charset = 0;
14069     }
14070
14071     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14072     if (s >= 0) {
14073         decc_filename_unix_report = decc$feature_get_value(s, 1);
14074         if (decc_filename_unix_report > 0) {
14075             decc_filename_unix_report = 1;
14076             vms_posix_exit = 1;
14077         }
14078         else
14079             decc_filename_unix_report = 0;
14080     }
14081
14082     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14083     if (s >= 0) {
14084         decc_filename_unix_only = decc$feature_get_value(s, 1);
14085         if (decc_filename_unix_only > 0) {
14086             decc_filename_unix_only = 1;
14087         }
14088         else {
14089             decc_filename_unix_only = 0;
14090         }
14091     }
14092
14093     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14094     if (s >= 0) {
14095         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14096         if (decc_filename_unix_no_version < 0)
14097             decc_filename_unix_no_version = 0;
14098     }
14099
14100     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14101     if (s >= 0) {
14102         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14103         if (decc_readdir_dropdotnotype < 0)
14104             decc_readdir_dropdotnotype = 0;
14105     }
14106
14107 #if __CRTL_VER >= 80200000
14108     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14109     if (s >= 0) {
14110         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14111         if (decc_posix_compliant_pathnames < 0)
14112             decc_posix_compliant_pathnames = 0;
14113         if (decc_posix_compliant_pathnames > 4)
14114             decc_posix_compliant_pathnames = 0;
14115     }
14116
14117 #endif
14118 #else
14119     status = simple_trnlnm
14120         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14121     if ($VMS_STATUS_SUCCESS(status)) {
14122         val_str[0] = _toupper(val_str[0]);
14123         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14124            decc_disable_to_vms_logname_translation = 1;
14125         }
14126     }
14127
14128 #ifndef __VAX
14129     status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14130     if ($VMS_STATUS_SUCCESS(status)) {
14131         val_str[0] = _toupper(val_str[0]);
14132         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14133            decc_efs_case_preserve = 1;
14134         }
14135     }
14136 #endif
14137
14138     status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14139     if ($VMS_STATUS_SUCCESS(status)) {
14140         val_str[0] = _toupper(val_str[0]);
14141         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14142            decc_filename_unix_report = 1;
14143         }
14144     }
14145     status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14146     if ($VMS_STATUS_SUCCESS(status)) {
14147         val_str[0] = _toupper(val_str[0]);
14148         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14149            decc_filename_unix_only = 1;
14150            decc_filename_unix_report = 1;
14151         }
14152     }
14153     status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14154     if ($VMS_STATUS_SUCCESS(status)) {
14155         val_str[0] = _toupper(val_str[0]);
14156         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14157            decc_filename_unix_no_version = 1;
14158         }
14159     }
14160     status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", 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_readdir_dropdotnotype = 1;
14165         }
14166     }
14167 #endif
14168
14169 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14170
14171      /* Report true case tolerance */
14172     /*----------------------------*/
14173     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14174     if (!$VMS_STATUS_SUCCESS(status))
14175         case_perm = PPROP$K_CASE_BLIND;
14176     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14177     if (!$VMS_STATUS_SUCCESS(status))
14178         case_image = PPROP$K_CASE_BLIND;
14179     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14180         (case_image == PPROP$K_CASE_SENSITIVE))
14181         vms_process_case_tolerant = 0;
14182
14183 #endif
14184
14185     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14186     /* for strict backward compatibility */
14187     status = simple_trnlnm
14188         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14189     if ($VMS_STATUS_SUCCESS(status)) {
14190        val_str[0] = _toupper(val_str[0]);
14191        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14192          vms_posix_exit = 1;
14193        else
14194          vms_posix_exit = 0;
14195     }
14196
14197
14198     /* CRTL can be initialized past this point, but not before. */
14199 /*    DECC$CRTL_INIT(); */
14200
14201     return SS$_NORMAL;
14202 }
14203
14204 #ifdef __DECC
14205 #pragma nostandard
14206 #pragma extern_model save
14207 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14208         const __align (LONGWORD) int spare[8] = {0};
14209
14210 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14211 #if __DECC_VER >= 60560002
14212 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14213 #else
14214 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14215 #endif
14216 #endif /* __DECC */
14217
14218 const long vms_cc_features = (const long)set_features;
14219
14220 /*
14221 ** Force a reference to LIB$INITIALIZE to ensure it
14222 ** exists in the image.
14223 */
14224 #define lib$initialize LIB$INITIALIZE
14225 int lib$initialize(void);
14226 #ifdef __DECC
14227 #pragma extern_model strict_refdef
14228 #endif
14229     int lib_init_ref = (int) lib$initialize;
14230
14231 #ifdef __DECC
14232 #pragma extern_model restore
14233 #pragma standard
14234 #endif
14235
14236 /*  End of vms.c */