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 #if defined(__DECC) || defined(__DECCXX)
 178 #pragma member_alignment save
 179 #pragma nomember_alignment longword
 180 #pragma message save
 181 #pragma message disable misalgndmem
 182 #endif
 183 struct itmlst_3 {
 184   unsigned short int buflen;
 185   unsigned short int itmcode;
 186   void *bufadr;
 187   unsigned short int *retlen;
 188 };
 189
 190 struct filescan_itmlst_2 {
 191     unsigned short length;
 192     unsigned short itmcode;
 193     char * component;
 194 };
 195
 196 struct vs_str_st {
 197     unsigned short length;
 198     char str[VMS_MAXRSS];
 199     unsigned short pad; /* for longword struct alignment */
 200 };
 201
 202 #if defined(__DECC) || defined(__DECCXX)
 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     return 0;
 596 }
 597
 598
 599 /* This handles the expansion of a '^' prefix to the proper character
 600  * in a UNIX file specification.
 601  *
 602  * The output count variable contains the number of characters added
 603  * to the output string.
 604  *
 605  * The return value is the number of characters read from the input
 606  * string
 607  */
 608 static int copy_expand_vms_filename_escape
 609   (char *outspec, const char *inspec, int *output_cnt)
 610 {
 611 int count;
 612 int scnt;
 613
 614     count = 0;
 615     *output_cnt = 0;
 616     if (*inspec == '^') {
 617         inspec++;
 618         switch (*inspec) {
 619         /* Spaces and non-trailing dots should just be passed through,
 620          * but eat the escape character.
 621          */
 622         case '.':
 623             *outspec = *inspec;
 624             count += 2;
 625             (*output_cnt)++;
 626             break;
 627         case '_': /* space */
 628             *outspec = ' ';
 629             count += 2;
 630             (*output_cnt)++;
 631             break;
 632         case '^':
 633             /* Hmm.  Better leave the escape escaped. */
 634             outspec[0] = '^';
 635             outspec[1] = '^';
 636             count += 2;
 637             (*output_cnt) += 2;
 638             break;
 639         case 'U': /* Unicode - FIX-ME this is wrong. */
 640             inspec++;
 641             count++;
 642             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 643             if (scnt == 4) {
 644                 unsigned int c1, c2;
 645                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 646                 outspec[0] = c1 & 0xff;
 647                 outspec[1] = c2 & 0xff;
 648                 if (scnt > 1) {
 649                     (*output_cnt) += 2;
 650                     count += 4;
 651                 }
 652             }
 653             else {
 654                 /* Error - do best we can to continue */
 655                 *outspec = 'U';
 656                 outspec++;
 657                 (*output_cnt++);
 658                 *outspec = *inspec;
 659                 count++;
 660                 (*output_cnt++);
 661             }
 662             break;
 663         default:
 664             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 665             if (scnt == 2) {
 666                 /* Hex encoded */
 667                 unsigned int c1;
 668                 scnt = sscanf(inspec, "%2x", &c1);
 669                 outspec[0] = c1 & 0xff;
 670                 if (scnt > 0) {
 671                     (*output_cnt++);
 672                     count += 2;
 673                 }
 674             }
 675             else {
 676                 *outspec = *inspec;
 677                 count++;
 678                 (*output_cnt++);
 679             }
 680         }
 681     }
 682     else {
 683         *outspec = *inspec;
 684         count++;
 685         (*output_cnt)++;
 686     }
 687     return count;
 688 }
 689
 690 /* vms_split_path - Verify that the input file specification is a
 691  * VMS format file specification, and provide pointers to the components of
 692  * it.  With EFS format filenames, this is virtually the only way to
 693  * parse a VMS path specification into components.
 694  *
 695  * If the sum of the components do not add up to the length of the
 696  * string, then the passed file specification is probably a UNIX style
 697  * path.
 698  */
 699 static int vms_split_path
 700    (const char * path,
 701     char * * volume,
 702     int * vol_len,
 703     char * * root,
 704     int * root_len,
 705     char * * dir,
 706     int * dir_len,
 707     char * * name,
 708     int * name_len,
 709     char * * ext,
 710     int * ext_len,
 711     char * * version,
 712     int * ver_len)
 713 {
 714 struct dsc$descriptor path_desc;
 715 int status;
 716 unsigned long flags;
 717 int ret_stat;
 718 struct filescan_itmlst_2 item_list[9];
 719 const int filespec = 0;
 720 const int nodespec = 1;
 721 const int devspec = 2;
 722 const int rootspec = 3;
 723 const int dirspec = 4;
 724 const int namespec = 5;
 725 const int typespec = 6;
 726 const int verspec = 7;
 727
 728     /* Assume the worst for an easy exit */
 729     ret_stat = -1;
 730     *volume = NULL;
 731     *vol_len = 0;
 732     *root = NULL;
 733     *root_len = 0;
 734     *dir = NULL;
 735     *name = NULL;
 736     *name_len = 0;
 737     *ext = NULL;
 738     *ext_len = 0;
 739     *version = NULL;
 740     *ver_len = 0;
 741
 742     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 743     path_desc.dsc$w_length = strlen(path);
 744     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 745     path_desc.dsc$b_class = DSC$K_CLASS_S;
 746
 747     /* Get the total length, if it is shorter than the string passed
 748      * then this was probably not a VMS formatted file specification
 749      */
 750     item_list[filespec].itmcode = FSCN$_FILESPEC;
 751     item_list[filespec].length = 0;
 752     item_list[filespec].component = NULL;
 753
 754     /* If the node is present, then it gets considered as part of the
 755      * volume name to hopefully make things simple.
 756      */
 757     item_list[nodespec].itmcode = FSCN$_NODE;
 758     item_list[nodespec].length = 0;
 759     item_list[nodespec].component = NULL;
 760
 761     item_list[devspec].itmcode = FSCN$_DEVICE;
 762     item_list[devspec].length = 0;
 763     item_list[devspec].component = NULL;
 764
 765     /* root is a special case,  adding it to either the directory or
 766      * the device components will probably complicate things for the
 767      * callers of this routine, so leave it separate.
 768      */
 769     item_list[rootspec].itmcode = FSCN$_ROOT;
 770     item_list[rootspec].length = 0;
 771     item_list[rootspec].component = NULL;
 772
 773     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 774     item_list[dirspec].length = 0;
 775     item_list[dirspec].component = NULL;
 776
 777     item_list[namespec].itmcode = FSCN$_NAME;
 778     item_list[namespec].length = 0;
 779     item_list[namespec].component = NULL;
 780
 781     item_list[typespec].itmcode = FSCN$_TYPE;
 782     item_list[typespec].length = 0;
 783     item_list[typespec].component = NULL;
 784
 785     item_list[verspec].itmcode = FSCN$_VERSION;
 786     item_list[verspec].length = 0;
 787     item_list[verspec].component = NULL;
 788
 789     item_list[8].itmcode = 0;
 790     item_list[8].length = 0;
 791     item_list[8].component = NULL;
 792
 793     status = sys$filescan
 794        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 795         &flags, NULL, NULL);
 796     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 797
 798     /* If we parsed it successfully these two lengths should be the same */
 799     if (path_desc.dsc$w_length != item_list[filespec].length)
 800         return ret_stat;
 801
 802     /* If we got here, then it is a VMS file specification */
 803     ret_stat = 0;
 804
 805     /* set the volume name */
 806     if (item_list[nodespec].length > 0) {
 807         *volume = item_list[nodespec].component;
 808         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 809     }
 810     else {
 811         *volume = item_list[devspec].component;
 812         *vol_len = item_list[devspec].length;
 813     }
 814
 815     *root = item_list[rootspec].component;
 816     *root_len = item_list[rootspec].length;
 817
 818     *dir = item_list[dirspec].component;
 819     *dir_len = item_list[dirspec].length;
 820
 821     /* Now fun with versions and EFS file specifications
 822      * The parser can not tell the difference when a "." is a version
 823      * delimiter or a part of the file specification.
 824      */
 825     if ((decc_efs_charset) &&
 826         (item_list[verspec].length > 0) &&
 827         (item_list[verspec].component[0] == '.')) {
 828         *name = item_list[namespec].component;
 829         *name_len = item_list[namespec].length + item_list[typespec].length;
 830         *ext = item_list[verspec].component;
 831         *ext_len = item_list[verspec].length;
 832         *version = NULL;
 833         *ver_len = 0;
 834     }
 835     else {
 836         *name = item_list[namespec].component;
 837         *name_len = item_list[namespec].length;
 838         *ext = item_list[typespec].component;
 839         *ext_len = item_list[typespec].length;
 840         *version = item_list[verspec].component;
 841         *ver_len = item_list[verspec].length;
 842     }
 843     return ret_stat;
 844 }
 845
 846 /* Routine to determine if the file specification ends with .dir */
 847 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 848
 849     /* e_len must be 4, and version must be <= 2 characters */
 850     if (e_len != 4 || vs_len > 2)
 851         return 0;
 852
 853     /* If a version number is present, it needs to be one */
 854     if ((vs_len == 2) && (vs_spec[1] != '1'))
 855         return 0;
 856
 857     /* Look for the DIR on the extension */
 858     if (vms_process_case_tolerant) {
 859         if ((toupper(e_spec[1]) == 'D') &&
 860             (toupper(e_spec[2]) == 'I') &&
 861             (toupper(e_spec[3]) == 'R')) {
 862             return 1;
 863         }
 864     } else {
 865         /* Directory extensions are supposed to be in upper case only */
 866         /* I would not be surprised if this rule can not be enforced */
 867         /* if and when someone fully debugs the case sensitive mode */
 868         if ((e_spec[1] == 'D') &&
 869             (e_spec[2] == 'I') &&
 870             (e_spec[3] == 'R')) {
 871             return 1;
 872         }
 873     }
 874     return 0;
 875 }
 876
 877
 878 /* my_maxidx
 879  * Routine to retrieve the maximum equivalence index for an input
 880  * logical name.  Some calls to this routine have no knowledge if
 881  * the variable is a logical or not.  So on error we return a max
 882  * index of zero.
 883  */
 884 /*{{{int my_maxidx(const char *lnm) */
 885 static int
 886 my_maxidx(const char *lnm)
 887 {
 888     int status;
 889     int midx;
 890     int attr = LNM$M_CASE_BLIND;
 891     struct dsc$descriptor lnmdsc;
 892     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 893                                 {0, 0, 0, 0}};
 894
 895     lnmdsc.dsc$w_length = strlen(lnm);
 896     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 897     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 898     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 899
 900     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 901     if ((status & 1) == 0)
 902        midx = 0;
 903
 904     return (midx);
 905 }
 906 /*}}}*/
 907
 908 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 909 int
 910 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 911   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 912 {
 913     const char *cp1;
 914     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 915     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 916     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 917     int midx;
 918     unsigned char acmode;
 919     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 920                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 921     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 922                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 923                                  {0, 0, 0, 0}};
 924     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 925 #if defined(PERL_IMPLICIT_CONTEXT)
 926     pTHX = NULL;
 927     if (PL_curinterp) {
 928       aTHX = PERL_GET_INTERP;
 929     } else {
 930       aTHX = NULL;
 931     }
 932 #endif
 933
 934     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 935       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 936     }
 937     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 938       *cp2 = _toupper(*cp1);
 939       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 940         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 941         return 0;
 942       }
 943     }
 944     lnmdsc.dsc$w_length = cp1 - lnm;
 945     lnmdsc.dsc$a_pointer = uplnm;
 946     uplnm[lnmdsc.dsc$w_length] = '\0';
 947     secure = flags & PERL__TRNENV_SECURE;
 948     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 949     if (!tabvec || !*tabvec) tabvec = env_tables;
 950
 951     for (curtab = 0; tabvec[curtab]; curtab++) {
 952       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 953         if (!ivenv && !secure) {
 954           char *eq;
 955           int i;
 956           if (!environ) {
 957             ivenv = 1;
 958 #if defined(PERL_IMPLICIT_CONTEXT)
 959             if (aTHX == NULL) {
 960                 fprintf(stderr,
 961                     "Can't read CRTL environ\n");
 962             } else
 963 #endif
 964                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 965             continue;
 966           }
 967           retsts = SS$_NOLOGNAM;
 968           for (i = 0; environ[i]; i++) {
 969             if ((eq = strchr(environ[i],'=')) &&
 970                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 971                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 972               eq++;
 973               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 974               if (!eqvlen) continue;
 975               retsts = SS$_NORMAL;
 976               break;
 977             }
 978           }
 979           if (retsts != SS$_NOLOGNAM) break;
 980         }
 981       }
 982       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 983                !str$case_blind_compare(&tmpdsc,&clisym)) {
 984         if (!ivsym && !secure) {
 985           unsigned short int deflen = LNM$C_NAMLENGTH;
 986           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 987           /* dynamic dsc to accommodate possible long value */
 988           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 989           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 990           if (retsts & 1) {
 991             if (eqvlen > MAX_DCL_SYMBOL) {
 992               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 993               eqvlen = MAX_DCL_SYMBOL;
 994               /* Special hack--we might be called before the interpreter's */
 995               /* fully initialized, in which case either thr or PL_curcop */
 996               /* might be bogus. We have to check, since ckWARN needs them */
 997               /* both to be valid if running threaded */
 998 #if defined(PERL_IMPLICIT_CONTEXT)
 999               if (aTHX == NULL) {
1000                   fprintf(stderr,
1001                      "Value of CLI symbol \"%s\" too long",lnm);
1002               } else
1003 #endif
1004                 if (ckWARN(WARN_MISC)) {
1005                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1006                 }
1007             }
1008             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1009           }
1010           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1011           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1012           if (retsts == LIB$_NOSUCHSYM) continue;
1013           break;
1014         }
1015       }
1016       else if (!ivlnm) {
1017         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1018           midx = my_maxidx(lnm);
1019           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1020             lnmlst[1].bufadr = cp2;
1021             eqvlen = 0;
1022             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1023             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1024             if (retsts == SS$_NOLOGNAM) break;
1025             /* PPFs have a prefix */
1026             if (
1027 #if INTSIZE == 4
1028                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1029 #endif
1030                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1031                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1032                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1033                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1034                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1035               memmove(eqv,eqv+4,eqvlen-4);
1036               eqvlen -= 4;
1037             }
1038             cp2 += eqvlen;
1039             *cp2 = '\0';
1040           }
1041           if ((retsts == SS$_IVLOGNAM) ||
1042               (retsts == SS$_NOLOGNAM)) { continue; }
1043         }
1044         else {
1045           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1046           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1047           if (retsts == SS$_NOLOGNAM) continue;
1048           eqv[eqvlen] = '\0';
1049         }
1050         eqvlen = strlen(eqv);
1051         break;
1052       }
1053     }
1054     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1055     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1056              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1057              retsts == SS$_NOLOGNAM) {
1058       set_errno(EINVAL);  set_vaxc_errno(retsts);
1059     }
1060     else _ckvmssts_noperl(retsts);
1061     return 0;
1062 }  /* end of vmstrnenv */
1063 /*}}}*/
1064
1065 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1066 /* Define as a function so we can access statics. */
1067 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1068 {
1069     int flags = 0;
1070
1071 #if defined(PERL_IMPLICIT_CONTEXT)
1072     if (aTHX != NULL)
1073 #endif
1074 #ifdef SECURE_INTERNAL_GETENV
1075         flags = (PL_curinterp ? PL_tainting : will_taint) ?
1076                  PERL__TRNENV_SECURE : 0;
1077 #endif
1078
1079     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1080 }
1081 /*}}}*/
1082
1083 /* my_getenv
1084  * Note: Uses Perl temp to store result so char * can be returned to
1085  * caller; this pointer will be invalidated at next Perl statement
1086  * transition.
1087  * We define this as a function rather than a macro in terms of my_getenv_len()
1088  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1089  * allocate SVs).
1090  */
1091 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1092 char *
1093 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1094 {
1095     const char *cp1;
1096     static char *__my_getenv_eqv = NULL;
1097     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1098     unsigned long int idx = 0;
1099     int success, secure, saverr, savvmserr;
1100     int midx, flags;
1101     SV *tmpsv;
1102
1103     midx = my_maxidx(lnm) + 1;
1104
1105     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1106       /* Set up a temporary buffer for the return value; Perl will
1107        * clean it up at the next statement transition */
1108       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1109       if (!tmpsv) return NULL;
1110       eqv = SvPVX(tmpsv);
1111     }
1112     else {
1113       /* Assume no interpreter ==> single thread */
1114       if (__my_getenv_eqv != NULL) {
1115         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1116       }
1117       else {
1118         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1119       }
1120       eqv = __my_getenv_eqv;
1121     }
1122
1123     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1124     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1125       int len;
1126       getcwd(eqv,LNM$C_NAMLENGTH);
1127
1128       len = strlen(eqv);
1129
1130       /* Get rid of "000000/ in rooted filespecs */
1131       if (len > 7) {
1132         char * zeros;
1133         zeros = strstr(eqv, "/000000/");
1134         if (zeros != NULL) {
1135           int mlen;
1136           mlen = len - (zeros - eqv) - 7;
1137           memmove(zeros, &zeros[7], mlen);
1138           len = len - 7;
1139           eqv[len] = '\0';
1140         }
1141       }
1142       return eqv;
1143     }
1144     else {
1145       /* Impose security constraints only if tainting */
1146       if (sys) {
1147         /* Impose security constraints only if tainting */
1148         secure = PL_curinterp ? PL_tainting : will_taint;
1149         saverr = errno;  savvmserr = vaxc$errno;
1150       }
1151       else {
1152         secure = 0;
1153       }
1154
1155       flags =
1156 #ifdef SECURE_INTERNAL_GETENV
1157               secure ? PERL__TRNENV_SECURE : 0
1158 #else
1159               0
1160 #endif
1161       ;
1162
1163       /* For the getenv interface we combine all the equivalence names
1164        * of a search list logical into one value to acquire a maximum
1165        * value length of 255*128 (assuming %ENV is using logicals).
1166        */
1167       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1168
1169       /* If the name contains a semicolon-delimited index, parse it
1170        * off and make sure we only retrieve the equivalence name for
1171        * that index.  */
1172       if ((cp2 = strchr(lnm,';')) != NULL) {
1173         my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1174         idx = strtoul(cp2+1,NULL,0);
1175         lnm = uplnm;
1176         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1177       }
1178
1179       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1180
1181       /* Discard NOLOGNAM on internal calls since we're often looking
1182        * for an optional name, and this "error" often shows up as the
1183        * (bogus) exit status for a die() call later on.  */
1184       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1185       return success ? eqv : NULL;
1186     }
1187
1188 }  /* end of my_getenv() */
1189 /*}}}*/
1190
1191
1192 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1193 char *
1194 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1195 {
1196     const char *cp1;
1197     char *buf, *cp2;
1198     unsigned long idx = 0;
1199     int midx, flags;
1200     static char *__my_getenv_len_eqv = NULL;
1201     int secure, saverr, savvmserr;
1202     SV *tmpsv;
1203
1204     midx = my_maxidx(lnm) + 1;
1205
1206     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1207       /* Set up a temporary buffer for the return value; Perl will
1208        * clean it up at the next statement transition */
1209       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1210       if (!tmpsv) return NULL;
1211       buf = SvPVX(tmpsv);
1212     }
1213     else {
1214       /* Assume no interpreter ==> single thread */
1215       if (__my_getenv_len_eqv != NULL) {
1216         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1217       }
1218       else {
1219         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1220       }
1221       buf = __my_getenv_len_eqv;
1222     }
1223
1224     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1225     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1226     char * zeros;
1227
1228       getcwd(buf,LNM$C_NAMLENGTH);
1229       *len = strlen(buf);
1230
1231       /* Get rid of "000000/ in rooted filespecs */
1232       if (*len > 7) {
1233       zeros = strstr(buf, "/000000/");
1234       if (zeros != NULL) {
1235         int mlen;
1236         mlen = *len - (zeros - buf) - 7;
1237         memmove(zeros, &zeros[7], mlen);
1238         *len = *len - 7;
1239         buf[*len] = '\0';
1240         }
1241       }
1242       return buf;
1243     }
1244     else {
1245       if (sys) {
1246         /* Impose security constraints only if tainting */
1247         secure = PL_curinterp ? PL_tainting : will_taint;
1248         saverr = errno;  savvmserr = vaxc$errno;
1249       }
1250       else {
1251         secure = 0;
1252       }
1253
1254       flags =
1255 #ifdef SECURE_INTERNAL_GETENV
1256               secure ? PERL__TRNENV_SECURE : 0
1257 #else
1258               0
1259 #endif
1260       ;
1261
1262       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1263
1264       if ((cp2 = strchr(lnm,';')) != NULL) {
1265         my_strlcpy(buf, lnm, cp2 - lnm + 1);
1266         idx = strtoul(cp2+1,NULL,0);
1267         lnm = buf;
1268         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1269       }
1270
1271       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1272
1273       /* Get rid of "000000/ in rooted filespecs */
1274       if (*len > 7) {
1275       char * zeros;
1276         zeros = strstr(buf, "/000000/");
1277         if (zeros != NULL) {
1278           int mlen;
1279           mlen = *len - (zeros - buf) - 7;
1280           memmove(zeros, &zeros[7], mlen);
1281           *len = *len - 7;
1282           buf[*len] = '\0';
1283         }
1284       }
1285
1286       /* Discard NOLOGNAM on internal calls since we're often looking
1287        * for an optional name, and this "error" often shows up as the
1288        * (bogus) exit status for a die() call later on.  */
1289       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1290       return *len ? buf : NULL;
1291     }
1292
1293 }  /* end of my_getenv_len() */
1294 /*}}}*/
1295
1296 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1297
1298 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1299
1300 /*{{{ void prime_env_iter() */
1301 void
1302 prime_env_iter(void)
1303 /* Fill the %ENV associative array with all logical names we can
1304  * find, in preparation for iterating over it.
1305  */
1306 {
1307   static int primed = 0;
1308   HV *seenhv = NULL, *envhv;
1309   SV *sv = NULL;
1310   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1311   unsigned short int chan;
1312 #ifndef CLI$M_TRUSTED
1313 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1314 #endif
1315   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1316   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1317   long int i;
1318   bool have_sym = FALSE, have_lnm = FALSE;
1319   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1320   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1321   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1322   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1323   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1324 #if defined(PERL_IMPLICIT_CONTEXT)
1325   pTHX;
1326 #endif
1327 #if defined(USE_ITHREADS)
1328   static perl_mutex primenv_mutex;
1329   MUTEX_INIT(&primenv_mutex);
1330 #endif
1331
1332 #if defined(PERL_IMPLICIT_CONTEXT)
1333     /* We jump through these hoops because we can be called at */
1334     /* platform-specific initialization time, which is before anything is */
1335     /* set up--we can't even do a plain dTHX since that relies on the */
1336     /* interpreter structure to be initialized */
1337     if (PL_curinterp) {
1338       aTHX = PERL_GET_INTERP;
1339     } else {
1340       /* we never get here because the NULL pointer will cause the */
1341       /* several of the routines called by this routine to access violate */
1342
1343       /* This routine is only called by hv.c/hv_iterinit which has a */
1344       /* context, so the real fix may be to pass it through instead of */
1345       /* the hoops above */
1346       aTHX = NULL;
1347     }
1348 #endif
1349
1350   if (primed || !PL_envgv) return;
1351   MUTEX_LOCK(&primenv_mutex);
1352   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1353   envhv = GvHVn(PL_envgv);
1354   /* Perform a dummy fetch as an lval to insure that the hash table is
1355    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1356   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1357
1358   for (i = 0; env_tables[i]; i++) {
1359      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1360          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1361      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1362   }
1363   if (have_sym || have_lnm) {
1364     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1365     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1366     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1367     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1368   }
1369
1370   for (i--; i >= 0; i--) {
1371     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1372       char *start;
1373       int j;
1374       for (j = 0; environ[j]; j++) {
1375         if (!(start = strchr(environ[j],'='))) {
1376           if (ckWARN(WARN_INTERNAL))
1377             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1378         }
1379         else {
1380           start++;
1381           sv = newSVpv(start,0);
1382           SvTAINTED_on(sv);
1383           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1384         }
1385       }
1386       continue;
1387     }
1388     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1389              !str$case_blind_compare(&tmpdsc,&clisym)) {
1390       my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1391       cmddsc.dsc$w_length = 20;
1392       if (env_tables[i]->dsc$w_length == 12 &&
1393           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1394           !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local  *", sizeof(cmd)-12);
1395       flags = defflags | CLI$M_NOLOGNAM;
1396     }
1397     else {
1398       my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1399       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1400         my_strlcat(cmd," /Table=", sizeof(cmd));
1401         cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, env_tables[i]->dsc$w_length + 1);
1402       }
1403       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1404       flags = defflags | CLI$M_NOCLISYM;
1405     }
1406
1407     /* Create a new subprocess to execute each command, to exclude the
1408      * remote possibility that someone could subvert a mbx or file used
1409      * to write multiple commands to a single subprocess.
1410      */
1411     do {
1412       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1413                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1414       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1415       defflags &= ~CLI$M_TRUSTED;
1416     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1417     _ckvmssts(retsts);
1418     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1419     if (seenhv) SvREFCNT_dec(seenhv);
1420     seenhv = newHV();
1421     while (1) {
1422       char *cp1, *cp2, *key;
1423       unsigned long int sts, iosb[2], retlen, keylen;
1424       U32 hash;
1425
1426       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1427       if (sts & 1) sts = iosb[0] & 0xffff;
1428       if (sts == SS$_ENDOFFILE) {
1429         int wakect = 0;
1430         while (substs == 0) { sys$hiber(); wakect++;}
1431         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1432         _ckvmssts(substs);
1433         break;
1434       }
1435       _ckvmssts(sts);
1436       retlen = iosb[0] >> 16;
1437       if (!retlen) continue;  /* blank line */
1438       buf[retlen] = '\0';
1439       if (iosb[1] != subpid) {
1440         if (iosb[1]) {
1441           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1442         }
1443         continue;
1444       }
1445       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1446         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1447
1448       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1449       if (*cp1 == '(' || /* Logical name table name */
1450           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1451       if (*cp1 == '"') cp1++;
1452       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1453       key = cp1;  keylen = cp2 - cp1;
1454       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1455       while (*cp2 && *cp2 != '=') cp2++;
1456       while (*cp2 && *cp2 == '=') cp2++;
1457       while (*cp2 && *cp2 == ' ') cp2++;
1458       if (*cp2 == '"') {  /* String translation; may embed "" */
1459         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1460         cp2++;  cp1--; /* Skip "" surrounding translation */
1461       }
1462       else {  /* Numeric translation */
1463         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1464         cp1--;  /* stop on last non-space char */
1465       }
1466       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1467         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1468         continue;
1469       }
1470       PERL_HASH(hash,key,keylen);
1471
1472       if (cp1 == cp2 && *cp2 == '.') {
1473         /* A single dot usually means an unprintable character, such as a null
1474          * to indicate a zero-length value.  Get the actual value to make sure.
1475          */
1476         char lnm[LNM$C_NAMLENGTH+1];
1477         char eqv[MAX_DCL_SYMBOL+1];
1478         int trnlen;
1479         strncpy(lnm, key, keylen);
1480         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1481         sv = newSVpvn(eqv, strlen(eqv));
1482       }
1483       else {
1484         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1485       }
1486
1487       SvTAINTED_on(sv);
1488       hv_store(envhv,key,keylen,sv,hash);
1489       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1490     }
1491     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1492       /* get the PPFs for this process, not the subprocess */
1493       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1494       char eqv[LNM$C_NAMLENGTH+1];
1495       int trnlen, i;
1496       for (i = 0; ppfs[i]; i++) {
1497         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1498         sv = newSVpv(eqv,trnlen);
1499         SvTAINTED_on(sv);
1500         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1501       }
1502     }
1503   }
1504   primed = 1;
1505   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1506   if (buf) Safefree(buf);
1507   if (seenhv) SvREFCNT_dec(seenhv);
1508   MUTEX_UNLOCK(&primenv_mutex);
1509   return;
1510
1511 }  /* end of prime_env_iter */
1512 /*}}}*/
1513
1514
1515 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1516 /* Define or delete an element in the same "environment" as
1517  * vmstrnenv().  If an element is to be deleted, it's removed from
1518  * the first place it's found.  If it's to be set, it's set in the
1519  * place designated by the first element of the table vector.
1520  * Like setenv() returns 0 for success, non-zero on error.
1521  */
1522 int
1523 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1524 {
1525     const char *cp1;
1526     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1527     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1528     int nseg = 0, j;
1529     unsigned long int retsts, usermode = PSL$C_USER;
1530     struct itmlst_3 *ile, *ilist;
1531     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1532                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1533                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1534     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1535     $DESCRIPTOR(local,"_LOCAL");
1536
1537     if (!lnm) {
1538         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1539         return SS$_IVLOGNAM;
1540     }
1541
1542     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1543       *cp2 = _toupper(*cp1);
1544       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1545         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1546         return SS$_IVLOGNAM;
1547       }
1548     }
1549     lnmdsc.dsc$w_length = cp1 - lnm;
1550     if (!tabvec || !*tabvec) tabvec = env_tables;
1551
1552     if (!eqv) {  /* we're deleting n element */
1553       for (curtab = 0; tabvec[curtab]; curtab++) {
1554         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1555         int i;
1556           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1557             if ((cp1 = strchr(environ[i],'=')) &&
1558                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1559                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1560 #ifdef HAS_SETENV
1561               return setenv(lnm,"",1) ? vaxc$errno : 0;
1562             }
1563           }
1564           ivenv = 1; retsts = SS$_NOLOGNAM;
1565 #else
1566               if (ckWARN(WARN_INTERNAL))
1567                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1568               ivenv = 1; retsts = SS$_NOSUCHPGM;
1569               break;
1570             }
1571           }
1572 #endif
1573         }
1574         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1575                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1576           unsigned int symtype;
1577           if (tabvec[curtab]->dsc$w_length == 12 &&
1578               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1579               !str$case_blind_compare(&tmpdsc,&local))
1580             symtype = LIB$K_CLI_LOCAL_SYM;
1581           else symtype = LIB$K_CLI_GLOBAL_SYM;
1582           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1583           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1584           if (retsts == LIB$_NOSUCHSYM) continue;
1585           break;
1586         }
1587         else if (!ivlnm) {
1588           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1589           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1590           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1591           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1592           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1593         }
1594       }
1595     }
1596     else {  /* we're defining a value */
1597       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1598 #ifdef HAS_SETENV
1599         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1600 #else
1601         if (ckWARN(WARN_INTERNAL))
1602           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1603         retsts = SS$_NOSUCHPGM;
1604 #endif
1605       }
1606       else {
1607         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1608         eqvdsc.dsc$w_length  = strlen(eqv);
1609         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1610             !str$case_blind_compare(&tmpdsc,&clisym)) {
1611           unsigned int symtype;
1612           if (tabvec[0]->dsc$w_length == 12 &&
1613               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1614                !str$case_blind_compare(&tmpdsc,&local))
1615             symtype = LIB$K_CLI_LOCAL_SYM;
1616           else symtype = LIB$K_CLI_GLOBAL_SYM;
1617           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1618         }
1619         else {
1620           if (!*eqv) eqvdsc.dsc$w_length = 1;
1621           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1622
1623             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1624             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1625               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1626                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1627               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1628               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1629             }
1630
1631             Newx(ilist,nseg+1,struct itmlst_3);
1632             ile = ilist;
1633             if (!ile) {
1634               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1635               return SS$_INSFMEM;
1636             }
1637             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1638
1639             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1640               ile->itmcode = LNM$_STRING;
1641               ile->bufadr = c;
1642               if ((j+1) == nseg) {
1643                 ile->buflen = strlen(c);
1644                 /* in case we are truncating one that's too long */
1645                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1646               }
1647               else {
1648                 ile->buflen = LNM$C_NAMLENGTH;
1649               }
1650             }
1651
1652             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1653             Safefree (ilist);
1654           }
1655           else {
1656             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1657           }
1658         }
1659       }
1660     }
1661     if (!(retsts & 1)) {
1662       switch (retsts) {
1663         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1664         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1665           set_errno(EVMSERR); break;
1666         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1667         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1668           set_errno(EINVAL); break;
1669         case SS$_NOPRIV:
1670           set_errno(EACCES); break;
1671         default:
1672           _ckvmssts(retsts);
1673           set_errno(EVMSERR);
1674        }
1675        set_vaxc_errno(retsts);
1676        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1677     }
1678     else {
1679       /* We reset error values on success because Perl does an hv_fetch()
1680        * before each hv_store(), and if the thing we're setting didn't
1681        * previously exist, we've got a leftover error message.  (Of course,
1682        * this fails in the face of
1683        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1684        * in that the error reported in $! isn't spurious,
1685        * but it's right more often than not.)
1686        */
1687       set_errno(0); set_vaxc_errno(retsts);
1688       return 0;
1689     }
1690
1691 }  /* end of vmssetenv() */
1692 /*}}}*/
1693
1694 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1695 /* This has to be a function since there's a prototype for it in proto.h */
1696 void
1697 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1698 {
1699     if (lnm && *lnm) {
1700       int len = strlen(lnm);
1701       if  (len == 7) {
1702         char uplnm[8];
1703         int i;
1704         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1705         if (!strcmp(uplnm,"DEFAULT")) {
1706           if (eqv && *eqv) my_chdir(eqv);
1707           return;
1708         }
1709     }
1710   }
1711   (void) vmssetenv(lnm,eqv,NULL);
1712 }
1713 /*}}}*/
1714
1715 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1716 /*  vmssetuserlnm
1717  *  sets a user-mode logical in the process logical name table
1718  *  used for redirection of sys$error
1719  *
1720  *  Fix-me: The pTHX is not needed for this routine, however doio.c
1721  *          is calling it with one instead of using a macro.
1722  *          A macro needs to be added to vmsish.h and doio.c updated to use it.
1723  *
1724  */
1725 void
1726 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1727 {
1728     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1729     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1730     unsigned long int iss, attr = LNM$M_CONFINE;
1731     unsigned char acmode = PSL$C_USER;
1732     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1733                                  {0, 0, 0, 0}};
1734     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1735     d_name.dsc$w_length = strlen(name);
1736
1737     lnmlst[0].buflen = strlen(eqv);
1738     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1739
1740     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1741     if (!(iss&1)) lib$signal(iss);
1742 }
1743 /*}}}*/
1744
1745
1746 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1747 /* my_crypt - VMS password hashing
1748  * my_crypt() provides an interface compatible with the Unix crypt()
1749  * C library function, and uses sys$hash_password() to perform VMS
1750  * password hashing.  The quadword hashed password value is returned
1751  * as a NUL-terminated 8 character string.  my_crypt() does not change
1752  * the case of its string arguments; in order to match the behavior
1753  * of LOGINOUT et al., alphabetic characters in both arguments must
1754  *  be upcased by the caller.
1755  *
1756  * - fix me to call ACM services when available
1757  */
1758 char *
1759 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1760 {
1761 #   ifndef UAI$C_PREFERRED_ALGORITHM
1762 #     define UAI$C_PREFERRED_ALGORITHM 127
1763 #   endif
1764     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1765     unsigned short int salt = 0;
1766     unsigned long int sts;
1767     struct const_dsc {
1768         unsigned short int dsc$w_length;
1769         unsigned char      dsc$b_type;
1770         unsigned char      dsc$b_class;
1771         const char *       dsc$a_pointer;
1772     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1773        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1774     struct itmlst_3 uailst[3] = {
1775         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1776         { sizeof salt, UAI$_SALT,    &salt, 0},
1777         { 0,           0,            NULL,  NULL}};
1778     static char hash[9];
1779
1780     usrdsc.dsc$w_length = strlen(usrname);
1781     usrdsc.dsc$a_pointer = usrname;
1782     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1783       switch (sts) {
1784         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1785           set_errno(EACCES);
1786           break;
1787         case RMS$_RNF:
1788           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1789           break;
1790         default:
1791           set_errno(EVMSERR);
1792       }
1793       set_vaxc_errno(sts);
1794       if (sts != RMS$_RNF) return NULL;
1795     }
1796
1797     txtdsc.dsc$w_length = strlen(textpasswd);
1798     txtdsc.dsc$a_pointer = textpasswd;
1799     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1800       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1801     }
1802
1803     return (char *) hash;
1804
1805 }  /* end of my_crypt() */
1806 /*}}}*/
1807
1808
1809 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1810 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1811 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1812
1813 /* fixup barenames that are directories for internal use.
1814  * There have been problems with the consistent handling of UNIX
1815  * style directory names when routines are presented with a name that
1816  * has no directory delimiters at all.  So this routine will eventually
1817  * fix the issue.
1818  */
1819 static char * fixup_bare_dirnames(const char * name)
1820 {
1821   if (decc_disable_to_vms_logname_translation) {
1822 /* fix me */
1823   }
1824   return NULL;
1825 }
1826
1827 /* 8.3, remove() is now broken on symbolic links */
1828 static int rms_erase(const char * vmsname);
1829
1830
1831 /* mp_do_kill_file
1832  * A little hack to get around a bug in some implementation of remove()
1833  * that do not know how to delete a directory
1834  *
1835  * Delete any file to which user has control access, regardless of whether
1836  * delete access is explicitly allowed.
1837  * Limitations: User must have write access to parent directory.
1838  *              Does not block signals or ASTs; if interrupted in midstream
1839  *              may leave file with an altered ACL.
1840  * HANDLE WITH CARE!
1841  */
1842 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1843 static int
1844 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1845 {
1846     char *vmsname;
1847     char *rslt;
1848     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1849     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1850     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1851     struct myacedef {
1852       unsigned char myace$b_length;
1853       unsigned char myace$b_type;
1854       unsigned short int myace$w_flags;
1855       unsigned long int myace$l_access;
1856       unsigned long int myace$l_ident;
1857     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1858                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1859       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1860      struct itmlst_3
1861        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1862                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1863        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1864        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1865        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1866        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1867
1868     /* Expand the input spec using RMS, since the CRTL remove() and
1869      * system services won't do this by themselves, so we may miss
1870      * a file "hiding" behind a logical name or search list. */
1871     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1872     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1873
1874     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1875     if (rslt == NULL) {
1876         PerlMem_free(vmsname);
1877         return -1;
1878       }
1879
1880     /* Erase the file */
1881     rmsts = rms_erase(vmsname);
1882
1883     /* Did it succeed */
1884     if ($VMS_STATUS_SUCCESS(rmsts)) {
1885         PerlMem_free(vmsname);
1886         return 0;
1887       }
1888
1889     /* If not, can changing protections help? */
1890     if (rmsts != RMS$_PRV) {
1891       set_vaxc_errno(rmsts);
1892       PerlMem_free(vmsname);
1893       return -1;
1894     }
1895
1896     /* No, so we get our own UIC to use as a rights identifier,
1897      * and the insert an ACE at the head of the ACL which allows us
1898      * to delete the file.
1899      */
1900     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1901     fildsc.dsc$w_length = strlen(vmsname);
1902     fildsc.dsc$a_pointer = vmsname;
1903     cxt = 0;
1904     newace.myace$l_ident = oldace.myace$l_ident;
1905     rmsts = -1;
1906     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1907       switch (aclsts) {
1908         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1909           set_errno(ENOENT); break;
1910         case RMS$_DIR:
1911           set_errno(ENOTDIR); break;
1912         case RMS$_DEV:
1913           set_errno(ENODEV); break;
1914         case RMS$_SYN: case SS$_INVFILFOROP:
1915           set_errno(EINVAL); break;
1916         case RMS$_PRV:
1917           set_errno(EACCES); break;
1918         default:
1919           _ckvmssts_noperl(aclsts);
1920       }
1921       set_vaxc_errno(aclsts);
1922       PerlMem_free(vmsname);
1923       return -1;
1924     }
1925     /* Grab any existing ACEs with this identifier in case we fail */
1926     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1927     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1928                     || fndsts == SS$_NOMOREACE ) {
1929       /* Add the new ACE . . . */
1930       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1931         goto yourroom;
1932
1933       rmsts = rms_erase(vmsname);
1934       if ($VMS_STATUS_SUCCESS(rmsts)) {
1935         rmsts = 0;
1936         }
1937         else {
1938         rmsts = -1;
1939         /* We blew it - dir with files in it, no write priv for
1940          * parent directory, etc.  Put things back the way they were. */
1941         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1942           goto yourroom;
1943         if (fndsts & 1) {
1944           addlst[0].bufadr = &oldace;
1945           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1946             goto yourroom;
1947         }
1948       }
1949     }
1950
1951     yourroom:
1952     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1953     /* We just deleted it, so of course it's not there.  Some versions of
1954      * VMS seem to return success on the unlock operation anyhow (after all
1955      * the unlock is successful), but others don't.
1956      */
1957     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1958     if (aclsts & 1) aclsts = fndsts;
1959     if (!(aclsts & 1)) {
1960       set_errno(EVMSERR);
1961       set_vaxc_errno(aclsts);
1962     }
1963
1964     PerlMem_free(vmsname);
1965     return rmsts;
1966
1967 }  /* end of kill_file() */
1968 /*}}}*/
1969
1970
1971 /*{{{int do_rmdir(char *name)*/
1972 int
1973 Perl_do_rmdir(pTHX_ const char *name)
1974 {
1975     char * dirfile;
1976     int retval;
1977     Stat_t st;
1978
1979     /* lstat returns a VMS fileified specification of the name */
1980     /* that is looked up, and also lets verifies that this is a directory */
1981
1982     retval = flex_lstat(name, &st);
1983     if (retval != 0) {
1984         char * ret_spec;
1985
1986         /* Due to a historical feature, flex_stat/lstat can not see some */
1987         /* Unix format file names that the rest of the CRTL can see */
1988         /* Fixing that feature will cause some perl tests to fail */
1989         /* So try this one more time. */
1990
1991         retval = lstat(name, &st.crtl_stat);
1992         if (retval != 0)
1993             return -1;
1994
1995         /* force it to a file spec for the kill file to work. */
1996         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1997         if (ret_spec == NULL) {
1998             errno = EIO;
1999             return -1;
2000         }
2001     }
2002
2003     if (!S_ISDIR(st.st_mode)) {
2004         errno = ENOTDIR;
2005         retval = -1;
2006     }
2007     else {
2008         dirfile = st.st_devnam;
2009
2010         /* It may be possible for flex_stat to find a file and vmsify() to */
2011         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
2012         /* with that case, so fail it */
2013         if (dirfile[0] == 0) {
2014             errno = EIO;
2015             return -1;
2016         }
2017
2018         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2019     }
2020
2021     return retval;
2022
2023 }  /* end of do_rmdir */
2024 /*}}}*/
2025
2026 /* kill_file
2027  * Delete any file to which user has control access, regardless of whether
2028  * delete access is explicitly allowed.
2029  * Limitations: User must have write access to parent directory.
2030  *              Does not block signals or ASTs; if interrupted in midstream
2031  *              may leave file with an altered ACL.
2032  * HANDLE WITH CARE!
2033  */
2034 /*{{{int kill_file(char *name)*/
2035 int
2036 Perl_kill_file(pTHX_ const char *name)
2037 {
2038     char * vmsfile;
2039     Stat_t st;
2040     int rmsts;
2041
2042     /* Convert the filename to VMS format and see if it is a directory */
2043     /* flex_lstat returns a vmsified file specification */
2044     rmsts = flex_lstat(name, &st);
2045     if (rmsts != 0) {
2046
2047         /* Due to a historical feature, flex_stat/lstat can not see some */
2048         /* Unix format file names that the rest of the CRTL can see when */
2049         /* ODS-2 file specifications are in use. */
2050         /* Fixing that feature will cause some perl tests to fail */
2051         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2052         st.st_mode = 0;
2053         vmsfile = (char *) name; /* cast ok */
2054
2055     } else {
2056         vmsfile = st.st_devnam;
2057         if (vmsfile[0] == 0) {
2058             /* It may be possible for flex_stat to find a file and vmsify() */
2059             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2060             /* deal with that case, so fail it */
2061             errno = EIO;
2062             return -1;
2063         }
2064     }
2065
2066     /* Remove() is allowed to delete directories, according to the X/Open
2067      * specifications.
2068      * This may need special handling to work with the ACL hacks.
2069      */
2070     if (S_ISDIR(st.st_mode)) {
2071         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2072         return rmsts;
2073     }
2074
2075     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2076
2077     /* Need to delete all versions ? */
2078     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2079         int i = 0;
2080
2081         /* Just use lstat() here as do not need st_dev */
2082         /* and we know that the file is in VMS format or that */
2083         /* because of a historical bug, flex_stat can not see the file */
2084         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2085             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2086             if (rmsts != 0)
2087                 break;
2088             i++;
2089
2090             /* Make sure that we do not loop forever */
2091             if (i > 32767) {
2092                 errno = EIO;
2093                 rmsts = -1;
2094                 break;
2095             }
2096         }
2097     }
2098
2099     return rmsts;
2100
2101 }  /* end of kill_file() */
2102 /*}}}*/
2103
2104
2105 /*{{{int my_mkdir(char *,Mode_t)*/
2106 int
2107 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2108 {
2109   STRLEN dirlen = strlen(dir);
2110
2111   /* zero length string sometimes gives ACCVIO */
2112   if (dirlen == 0) return -1;
2113
2114   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2115    * null file name/type.  However, it's commonplace under Unix,
2116    * so we'll allow it for a gain in portability.
2117    */
2118   if (dir[dirlen-1] == '/') {
2119     char *newdir = savepvn(dir,dirlen-1);
2120     int ret = mkdir(newdir,mode);
2121     Safefree(newdir);
2122     return ret;
2123   }
2124   else return mkdir(dir,mode);
2125 }  /* end of my_mkdir */
2126 /*}}}*/
2127
2128 /*{{{int my_chdir(char *)*/
2129 int
2130 Perl_my_chdir(pTHX_ const char *dir)
2131 {
2132   STRLEN dirlen = strlen(dir);
2133
2134   /* zero length string sometimes gives ACCVIO */
2135   if (dirlen == 0) return -1;
2136   const char *dir1;
2137
2138   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2139    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2140    * so that existing scripts do not need to be changed.
2141    */
2142   dir1 = dir;
2143   while ((dirlen > 0) && (*dir1 == ' ')) {
2144     dir1++;
2145     dirlen--;
2146   }
2147
2148   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2149    * that implies
2150    * null file name/type.  However, it's commonplace under Unix,
2151    * so we'll allow it for a gain in portability.
2152    *
2153    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2154    */
2155   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2156       char *newdir;
2157       int ret;
2158       newdir = (char *)PerlMem_malloc(dirlen);
2159       if (newdir ==NULL)
2160           _ckvmssts_noperl(SS$_INSFMEM);
2161       memcpy(newdir, dir1, dirlen-1);
2162       newdir[dirlen-1] = '\0';
2163       ret = chdir(newdir);
2164       PerlMem_free(newdir);
2165       return ret;
2166   }
2167   else return chdir(dir1);
2168 }  /* end of my_chdir */
2169 /*}}}*/
2170
2171
2172 /*{{{int my_chmod(char *, mode_t)*/
2173 int
2174 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2175 {
2176   Stat_t st;
2177   int ret = -1;
2178   char * changefile;
2179   STRLEN speclen = strlen(file_spec);
2180
2181   /* zero length string sometimes gives ACCVIO */
2182   if (speclen == 0) return -1;
2183
2184   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2185    * that implies null file name/type.  However, it's commonplace under Unix,
2186    * so we'll allow it for a gain in portability.
2187    *
2188    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2189    * in VMS file.dir notation.
2190    */
2191   changefile = (char *) file_spec; /* cast ok */
2192   ret = flex_lstat(file_spec, &st);
2193   if (ret != 0) {
2194
2195         /* Due to a historical feature, flex_stat/lstat can not see some */
2196         /* Unix format file names that the rest of the CRTL can see when */
2197         /* ODS-2 file specifications are in use. */
2198         /* Fixing that feature will cause some perl tests to fail */
2199         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2200         st.st_mode = 0;
2201
2202   } else {
2203       /* It may be possible to get here with nothing in st_devname */
2204       /* chmod still may work though */
2205       if (st.st_devnam[0] != 0) {
2206           changefile = st.st_devnam;
2207       }
2208   }
2209   ret = chmod(changefile, mode);
2210   return ret;
2211 }  /* end of my_chmod */
2212 /*}}}*/
2213
2214
2215 /*{{{FILE *my_tmpfile()*/
2216 FILE *
2217 my_tmpfile(void)
2218 {
2219   FILE *fp;
2220   char *cp;
2221
2222   if ((fp = tmpfile())) return fp;
2223
2224   cp = (char *)PerlMem_malloc(L_tmpnam+24);
2225   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2226
2227   if (decc_filename_unix_only == 0)
2228     strcpy(cp,"Sys$Scratch:");
2229   else
2230     strcpy(cp,"/tmp/");
2231   tmpnam(cp+strlen(cp));
2232   strcat(cp,".Perltmp");
2233   fp = fopen(cp,"w+","fop=dlt");
2234   PerlMem_free(cp);
2235   return fp;
2236 }
2237 /*}}}*/
2238
2239
2240 /*
2241  * The C RTL's sigaction fails to check for invalid signal numbers so we
2242  * help it out a bit.  The docs are correct, but the actual routine doesn't
2243  * do what the docs say it will.
2244  */
2245 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2246 int
2247 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2248                    struct sigaction* oact)
2249 {
2250   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2251         SETERRNO(EINVAL, SS$_INVARG);
2252         return -1;
2253   }
2254   return sigaction(sig, act, oact);
2255 }
2256 /*}}}*/
2257
2258 #ifdef KILL_BY_SIGPRC
2259 #include <errnodef.h>
2260
2261 /* We implement our own kill() using the undocumented system service
2262    sys$sigprc for one of two reasons:
2263
2264    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2265    target process to do a sys$exit, which usually can't be handled
2266    gracefully...certainly not by Perl and the %SIG{} mechanism.
2267
2268    2.) If the kill() in the CRTL can't be called from a signal
2269    handler without disappearing into the ether, i.e., the signal
2270    it purportedly sends is never trapped. Still true as of VMS 7.3.
2271
2272    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2273    in the target process rather than calling sys$exit.
2274
2275    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2276    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2277    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2278    with condition codes C$_SIG0+nsig*8, catching the exception on the
2279    target process and resignaling with appropriate arguments.
2280
2281    But we don't have that VMS 7.0+ exception handler, so if you
2282    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2283
2284    Also note that SIGTERM is listed in the docs as being "unimplemented",
2285    yet always seems to be signaled with a VMS condition code of 4 (and
2286    correctly handled for that code).  So we hardwire it in.
2287
2288    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2289    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2290    than signalling with an unrecognized (and unhandled by CRTL) code.
2291 */
2292
2293 #define _MY_SIG_MAX 28
2294
2295 static unsigned int
2296 Perl_sig_to_vmscondition_int(int sig)
2297 {
2298     static unsigned int sig_code[_MY_SIG_MAX+1] =
2299     {
2300         0,                  /*  0 ZERO     */
2301         SS$_HANGUP,         /*  1 SIGHUP   */
2302         SS$_CONTROLC,       /*  2 SIGINT   */
2303         SS$_CONTROLY,       /*  3 SIGQUIT  */
2304         SS$_RADRMOD,        /*  4 SIGILL   */
2305         SS$_BREAK,          /*  5 SIGTRAP  */
2306         SS$_OPCCUS,         /*  6 SIGABRT  */
2307         SS$_COMPAT,         /*  7 SIGEMT   */
2308 #ifdef __VAX
2309         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2310 #else
2311         SS$_HPARITH,        /*  8 SIGFPE AXP */
2312 #endif
2313         SS$_ABORT,          /*  9 SIGKILL  */
2314         SS$_ACCVIO,         /* 10 SIGBUS   */
2315         SS$_ACCVIO,         /* 11 SIGSEGV  */
2316         SS$_BADPARAM,       /* 12 SIGSYS   */
2317         SS$_NOMBX,          /* 13 SIGPIPE  */
2318         SS$_ASTFLT,         /* 14 SIGALRM  */
2319         4,                  /* 15 SIGTERM  */
2320         0,                  /* 16 SIGUSR1  */
2321         0,                  /* 17 SIGUSR2  */
2322         0,                  /* 18 */
2323         0,                  /* 19 */
2324         0,                  /* 20 SIGCHLD  */
2325         0,                  /* 21 SIGCONT  */
2326         0,                  /* 22 SIGSTOP  */
2327         0,                  /* 23 SIGTSTP  */
2328         0,                  /* 24 SIGTTIN  */
2329         0,                  /* 25 SIGTTOU  */
2330         0,                  /* 26 */
2331         0,                  /* 27 */
2332         0                   /* 28 SIGWINCH  */
2333     };
2334
2335     static int initted = 0;
2336     if (!initted) {
2337         initted = 1;
2338         sig_code[16] = C$_SIGUSR1;
2339         sig_code[17] = C$_SIGUSR2;
2340         sig_code[20] = C$_SIGCHLD;
2341 #if __CRTL_VER >= 70300000
2342         sig_code[28] = C$_SIGWINCH;
2343 #endif
2344     }
2345
2346     if (sig < _SIG_MIN) return 0;
2347     if (sig > _MY_SIG_MAX) return 0;
2348     return sig_code[sig];
2349 }
2350
2351 unsigned int
2352 Perl_sig_to_vmscondition(int sig)
2353 {
2354 #ifdef SS$_DEBUG
2355     if (vms_debug_on_exception != 0)
2356         lib$signal(SS$_DEBUG);
2357 #endif
2358     return Perl_sig_to_vmscondition_int(sig);
2359 }
2360
2361
2362 #define sys$sigprc SYS$SIGPRC
2363 #ifdef __cplusplus
2364 extern "C" {
2365 #endif
2366 int sys$sigprc(unsigned int *pidadr,
2367                struct dsc$descriptor_s *prcname,
2368                unsigned int code);
2369 #ifdef __cplusplus
2370 }
2371 #endif
2372
2373 int
2374 Perl_my_kill(int pid, int sig)
2375 {
2376     int iss;
2377     unsigned int code;
2378
2379      /* sig 0 means validate the PID */
2380     /*------------------------------*/
2381     if (sig == 0) {
2382         const unsigned long int jpicode = JPI$_PID;
2383         pid_t ret_pid;
2384         int status;
2385         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2386         if ($VMS_STATUS_SUCCESS(status))
2387            return 0;
2388         switch (status) {
2389         case SS$_NOSUCHNODE:
2390         case SS$_UNREACHABLE:
2391         case SS$_NONEXPR:
2392            errno = ESRCH;
2393            break;
2394         case SS$_NOPRIV:
2395            errno = EPERM;
2396            break;
2397         default:
2398            errno = EVMSERR;
2399         }
2400         vaxc$errno=status;
2401         return -1;
2402     }
2403
2404     code = Perl_sig_to_vmscondition_int(sig);
2405
2406     if (!code) {
2407         SETERRNO(EINVAL, SS$_BADPARAM);
2408         return -1;
2409     }
2410
2411     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2412      * signals are to be sent to multiple processes.
2413      *  pid = 0 - all processes in group except ones that the system exempts
2414      *  pid = -1 - all processes except ones that the system exempts
2415      *  pid = -n - all processes in group (abs(n)) except ...
2416      * For now, just report as not supported.
2417      */
2418
2419     if (pid <= 0) {
2420         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2421         return -1;
2422     }
2423
2424     iss = sys$sigprc((unsigned int *)&pid,0,code);
2425     if (iss&1) return 0;
2426
2427     switch (iss) {
2428       case SS$_NOPRIV:
2429         set_errno(EPERM);  break;
2430       case SS$_NONEXPR:
2431       case SS$_NOSUCHNODE:
2432       case SS$_UNREACHABLE:
2433         set_errno(ESRCH);  break;
2434       case SS$_INSFMEM:
2435         set_errno(ENOMEM); break;
2436       default:
2437         _ckvmssts_noperl(iss);
2438         set_errno(EVMSERR);
2439     }
2440     set_vaxc_errno(iss);
2441
2442     return -1;
2443 }
2444 #endif
2445
2446 /* Routine to convert a VMS status code to a UNIX status code.
2447 ** More tricky than it appears because of conflicting conventions with
2448 ** existing code.
2449 **
2450 ** VMS status codes are a bit mask, with the least significant bit set for
2451 ** success.
2452 **
2453 ** Special UNIX status of EVMSERR indicates that no translation is currently
2454 ** available, and programs should check the VMS status code.
2455 **
2456 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2457 ** decoding.
2458 */
2459
2460 #ifndef C_FACILITY_NO
2461 #define C_FACILITY_NO 0x350000
2462 #endif
2463 #ifndef DCL_IVVERB
2464 #define DCL_IVVERB 0x38090
2465 #endif
2466
2467 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2468 {
2469 int facility;
2470 int fac_sp;
2471 int msg_no;
2472 int msg_status;
2473 int unix_status;
2474
2475   /* Assume the best or the worst */
2476   if (vms_status & STS$M_SUCCESS)
2477     unix_status = 0;
2478   else
2479     unix_status = EVMSERR;
2480
2481   msg_status = vms_status & ~STS$M_CONTROL;
2482
2483   facility = vms_status & STS$M_FAC_NO;
2484   fac_sp = vms_status & STS$M_FAC_SP;
2485   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2486
2487   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2488     switch(msg_no) {
2489     case SS$_NORMAL:
2490         unix_status = 0;
2491         break;
2492     case SS$_ACCVIO:
2493         unix_status = EFAULT;
2494         break;
2495     case SS$_DEVOFFLINE:
2496         unix_status = EBUSY;
2497         break;
2498     case SS$_CLEARED:
2499         unix_status = ENOTCONN;
2500         break;
2501     case SS$_IVCHAN:
2502     case SS$_IVLOGNAM:
2503     case SS$_BADPARAM:
2504     case SS$_IVLOGTAB:
2505     case SS$_NOLOGNAM:
2506     case SS$_NOLOGTAB:
2507     case SS$_INVFILFOROP:
2508     case SS$_INVARG:
2509     case SS$_NOSUCHID:
2510     case SS$_IVIDENT:
2511         unix_status = EINVAL;
2512         break;
2513     case SS$_UNSUPPORTED:
2514         unix_status = ENOTSUP;
2515         break;
2516     case SS$_FILACCERR:
2517     case SS$_NOGRPPRV:
2518     case SS$_NOSYSPRV:
2519         unix_status = EACCES;
2520         break;
2521     case SS$_DEVICEFULL:
2522         unix_status = ENOSPC;
2523         break;
2524     case SS$_NOSUCHDEV:
2525         unix_status = ENODEV;
2526         break;
2527     case SS$_NOSUCHFILE:
2528     case SS$_NOSUCHOBJECT:
2529         unix_status = ENOENT;
2530         break;
2531     case SS$_ABORT:                                 /* Fatal case */
2532     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2533     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2534         unix_status = EINTR;
2535         break;
2536     case SS$_BUFFEROVF:
2537         unix_status = E2BIG;
2538         break;
2539     case SS$_INSFMEM:
2540         unix_status = ENOMEM;
2541         break;
2542     case SS$_NOPRIV:
2543         unix_status = EPERM;
2544         break;
2545     case SS$_NOSUCHNODE:
2546     case SS$_UNREACHABLE:
2547         unix_status = ESRCH;
2548         break;
2549     case SS$_NONEXPR:
2550         unix_status = ECHILD;
2551         break;
2552     default:
2553         if ((facility == 0) && (msg_no < 8)) {
2554           /* These are not real VMS status codes so assume that they are
2555           ** already UNIX status codes
2556           */
2557           unix_status = msg_no;
2558           break;
2559         }
2560     }
2561   }
2562   else {
2563     /* Translate a POSIX exit code to a UNIX exit code */
2564     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2565         unix_status = (msg_no & 0x07F8) >> 3;
2566     }
2567     else {
2568
2569          /* Documented traditional behavior for handling VMS child exits */
2570         /*--------------------------------------------------------------*/
2571         if (child_flag != 0) {
2572
2573              /* Success / Informational return 0 */
2574             /*----------------------------------*/
2575             if (msg_no & STS$K_SUCCESS)
2576                 return 0;
2577
2578              /* Warning returns 1 */
2579             /*-------------------*/
2580             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2581                 return 1;
2582
2583              /* Everything else pass through the severity bits */
2584             /*------------------------------------------------*/
2585             return (msg_no & STS$M_SEVERITY);
2586         }
2587
2588          /* Normal VMS status to ERRNO mapping attempt */
2589         /*--------------------------------------------*/
2590         switch(msg_status) {
2591         /* case RMS$_EOF: */ /* End of File */
2592         case RMS$_FNF:  /* File Not Found */
2593         case RMS$_DNF:  /* Dir Not Found */
2594                 unix_status = ENOENT;
2595                 break;
2596         case RMS$_RNF:  /* Record Not Found */
2597                 unix_status = ESRCH;
2598                 break;
2599         case RMS$_DIR:
2600                 unix_status = ENOTDIR;
2601                 break;
2602         case RMS$_DEV:
2603                 unix_status = ENODEV;
2604                 break;
2605         case RMS$_IFI:
2606         case RMS$_FAC:
2607         case RMS$_ISI:
2608                 unix_status = EBADF;
2609                 break;
2610         case RMS$_FEX:
2611                 unix_status = EEXIST;
2612                 break;
2613         case RMS$_SYN:
2614         case RMS$_FNM:
2615         case LIB$_INVSTRDES:
2616         case LIB$_INVARG:
2617         case LIB$_NOSUCHSYM:
2618         case LIB$_INVSYMNAM:
2619         case DCL_IVVERB:
2620                 unix_status = EINVAL;
2621                 break;
2622         case CLI$_BUFOVF:
2623         case RMS$_RTB:
2624         case CLI$_TKNOVF:
2625         case CLI$_RSLOVF:
2626                 unix_status = E2BIG;
2627                 break;
2628         case RMS$_PRV:  /* No privilege */
2629         case RMS$_ACC:  /* ACP file access failed */
2630         case RMS$_WLK:  /* Device write locked */
2631                 unix_status = EACCES;
2632                 break;
2633         case RMS$_MKD:  /* Failed to mark for delete */
2634                 unix_status = EPERM;
2635                 break;
2636         /* case RMS$_NMF: */  /* No more files */
2637         }
2638     }
2639   }
2640
2641   return unix_status;
2642 }
2643
2644 /* Try to guess at what VMS error status should go with a UNIX errno
2645  * value.  This is hard to do as there could be many possible VMS
2646  * error statuses that caused the errno value to be set.
2647  */
2648
2649 int Perl_unix_status_to_vms(int unix_status)
2650 {
2651 int test_unix_status;
2652
2653      /* Trivial cases first */
2654     /*---------------------*/
2655     if (unix_status == EVMSERR)
2656         return vaxc$errno;
2657
2658      /* Is vaxc$errno sane? */
2659     /*---------------------*/
2660     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2661     if (test_unix_status == unix_status)
2662         return vaxc$errno;
2663
2664      /* If way out of range, must be VMS code already */
2665     /*-----------------------------------------------*/
2666     if (unix_status > EVMSERR)
2667         return unix_status;
2668
2669      /* If out of range, punt */
2670     /*-----------------------*/
2671     if (unix_status > __ERRNO_MAX)
2672         return SS$_ABORT;
2673
2674
2675      /* Ok, now we have to do it the hard way. */
2676     /*----------------------------------------*/
2677     switch(unix_status) {
2678     case 0:     return SS$_NORMAL;
2679     case EPERM: return SS$_NOPRIV;
2680     case ENOENT: return SS$_NOSUCHOBJECT;
2681     case ESRCH: return SS$_UNREACHABLE;
2682     case EINTR: return SS$_ABORT;
2683     /* case EIO: */
2684     /* case ENXIO:  */
2685     case E2BIG: return SS$_BUFFEROVF;
2686     /* case ENOEXEC */
2687     case EBADF: return RMS$_IFI;
2688     case ECHILD: return SS$_NONEXPR;
2689     /* case EAGAIN */
2690     case ENOMEM: return SS$_INSFMEM;
2691     case EACCES: return SS$_FILACCERR;
2692     case EFAULT: return SS$_ACCVIO;
2693     /* case ENOTBLK */
2694     case EBUSY: return SS$_DEVOFFLINE;
2695     case EEXIST: return RMS$_FEX;
2696     /* case EXDEV */
2697     case ENODEV: return SS$_NOSUCHDEV;
2698     case ENOTDIR: return RMS$_DIR;
2699     /* case EISDIR */
2700     case EINVAL: return SS$_INVARG;
2701     /* case ENFILE */
2702     /* case EMFILE */
2703     /* case ENOTTY */
2704     /* case ETXTBSY */
2705     /* case EFBIG */
2706     case ENOSPC: return SS$_DEVICEFULL;
2707     case ESPIPE: return LIB$_INVARG;
2708     /* case EROFS: */
2709     /* case EMLINK: */
2710     /* case EPIPE: */
2711     /* case EDOM */
2712     case ERANGE: return LIB$_INVARG;
2713     /* case EWOULDBLOCK */
2714     /* case EINPROGRESS */
2715     /* case EALREADY */
2716     /* case ENOTSOCK */
2717     /* case EDESTADDRREQ */
2718     /* case EMSGSIZE */
2719     /* case EPROTOTYPE */
2720     /* case ENOPROTOOPT */
2721     /* case EPROTONOSUPPORT */
2722     /* case ESOCKTNOSUPPORT */
2723     /* case EOPNOTSUPP */
2724     /* case EPFNOSUPPORT */
2725     /* case EAFNOSUPPORT */
2726     /* case EADDRINUSE */
2727     /* case EADDRNOTAVAIL */
2728     /* case ENETDOWN */
2729     /* case ENETUNREACH */
2730     /* case ENETRESET */
2731     /* case ECONNABORTED */
2732     /* case ECONNRESET */
2733     /* case ENOBUFS */
2734     /* case EISCONN */
2735     case ENOTCONN: return SS$_CLEARED;
2736     /* case ESHUTDOWN */
2737     /* case ETOOMANYREFS */
2738     /* case ETIMEDOUT */
2739     /* case ECONNREFUSED */
2740     /* case ELOOP */
2741     /* case ENAMETOOLONG */
2742     /* case EHOSTDOWN */
2743     /* case EHOSTUNREACH */
2744     /* case ENOTEMPTY */
2745     /* case EPROCLIM */
2746     /* case EUSERS  */
2747     /* case EDQUOT  */
2748     /* case ENOMSG  */
2749     /* case EIDRM */
2750     /* case EALIGN */
2751     /* case ESTALE */
2752     /* case EREMOTE */
2753     /* case ENOLCK */
2754     /* case ENOSYS */
2755     /* case EFTYPE */
2756     /* case ECANCELED */
2757     /* case EFAIL */
2758     /* case EINPROG */
2759     case ENOTSUP:
2760         return SS$_UNSUPPORTED;
2761     /* case EDEADLK */
2762     /* case ENWAIT */
2763     /* case EILSEQ */
2764     /* case EBADCAT */
2765     /* case EBADMSG */
2766     /* case EABANDONED */
2767     default:
2768         return SS$_ABORT; /* punt */
2769     }
2770 }
2771
2772
2773 /* default piping mailbox size */
2774 #ifdef __VAX
2775 #  define PERL_BUFSIZ        512
2776 #else
2777 #  define PERL_BUFSIZ        8192
2778 #endif
2779
2780
2781 static void
2782 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2783 {
2784   unsigned long int mbxbufsiz;
2785   static unsigned long int syssize = 0;
2786   unsigned long int dviitm = DVI$_DEVNAM;
2787   char csize[LNM$C_NAMLENGTH+1];
2788   int sts;
2789
2790   if (!syssize) {
2791     unsigned long syiitm = SYI$_MAXBUF;
2792     /*
2793      * Get the SYSGEN parameter MAXBUF
2794      *
2795      * If the logical 'PERL_MBX_SIZE' is defined
2796      * use the value of the logical instead of PERL_BUFSIZ, but
2797      * keep the size between 128 and MAXBUF.
2798      *
2799      */
2800     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2801   }
2802
2803   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2804       mbxbufsiz = atoi(csize);
2805   } else {
2806       mbxbufsiz = PERL_BUFSIZ;
2807   }
2808   if (mbxbufsiz < 128) mbxbufsiz = 128;
2809   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2810
2811   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2812
2813   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2814   _ckvmssts_noperl(sts);
2815   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2816
2817 }  /* end of create_mbx() */
2818
2819
2820 /*{{{  my_popen and my_pclose*/
2821
2822 typedef struct _iosb           IOSB;
2823 typedef struct _iosb*         pIOSB;
2824 typedef struct _pipe           Pipe;
2825 typedef struct _pipe*         pPipe;
2826 typedef struct pipe_details    Info;
2827 typedef struct pipe_details*  pInfo;
2828 typedef struct _srqp            RQE;
2829 typedef struct _srqp*          pRQE;
2830 typedef struct _tochildbuf      CBuf;
2831 typedef struct _tochildbuf*    pCBuf;
2832
2833 struct _iosb {
2834     unsigned short status;
2835     unsigned short count;
2836     unsigned long  dvispec;
2837 };
2838
2839 #pragma member_alignment save
2840 #pragma nomember_alignment quadword
2841 struct _srqp {          /* VMS self-relative queue entry */
2842     unsigned long qptr[2];
2843 };
2844 #pragma member_alignment restore
2845 static RQE  RQE_ZERO = {0,0};
2846
2847 struct _tochildbuf {
2848     RQE             q;
2849     int             eof;
2850     unsigned short  size;
2851     char            *buf;
2852 };
2853
2854 struct _pipe {
2855     RQE            free;
2856     RQE            wait;
2857     int            fd_out;
2858     unsigned short chan_in;
2859     unsigned short chan_out;
2860     char          *buf;
2861     unsigned int   bufsize;
2862     IOSB           iosb;
2863     IOSB           iosb2;
2864     int           *pipe_done;
2865     int            retry;
2866     int            type;
2867     int            shut_on_empty;
2868     int            need_wake;
2869     pPipe         *home;
2870     pInfo          info;
2871     pCBuf          curr;
2872     pCBuf          curr2;
2873 #if defined(PERL_IMPLICIT_CONTEXT)
2874     void            *thx;           /* Either a thread or an interpreter */
2875                                     /* pointer, depending on how we're built */
2876 #endif
2877 };
2878
2879
2880 struct pipe_details
2881 {
2882     pInfo           next;
2883     PerlIO *fp;  /* file pointer to pipe mailbox */
2884     int useFILE; /* using stdio, not perlio */
2885     int pid;   /* PID of subprocess */
2886     int mode;  /* == 'r' if pipe open for reading */
2887     int done;  /* subprocess has completed */
2888     int waiting; /* waiting for completion/closure */
2889     int             closing;        /* my_pclose is closing this pipe */
2890     unsigned long   completion;     /* termination status of subprocess */
2891     pPipe           in;             /* pipe in to sub */
2892     pPipe           out;            /* pipe out of sub */
2893     pPipe           err;            /* pipe of sub's sys$error */
2894     int             in_done;        /* true when in pipe finished */
2895     int             out_done;
2896     int             err_done;
2897     unsigned short  xchan;          /* channel to debug xterm */
2898     unsigned short  xchan_valid;    /* channel is assigned */
2899 };
2900
2901 struct exit_control_block
2902 {
2903     struct exit_control_block *flink;
2904     unsigned long int (*exit_routine)(void);
2905     unsigned long int arg_count;
2906     unsigned long int *status_address;
2907     unsigned long int exit_status;
2908 };
2909
2910 typedef struct _closed_pipes    Xpipe;
2911 typedef struct _closed_pipes*  pXpipe;
2912
2913 struct _closed_pipes {
2914     int             pid;            /* PID of subprocess */
2915     unsigned long   completion;     /* termination status of subprocess */
2916 };
2917 #define NKEEPCLOSED 50
2918 static Xpipe closed_list[NKEEPCLOSED];
2919 static int   closed_index = 0;
2920 static int   closed_num = 0;
2921
2922 #define RETRY_DELAY     "0 ::0.20"
2923 #define MAX_RETRY              50
2924
2925 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2926 static unsigned long mypid;
2927 static unsigned long delaytime[2];
2928
2929 static pInfo open_pipes = NULL;
2930 static $DESCRIPTOR(nl_desc, "NL:");
2931
2932 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2933
2934
2935
2936 static unsigned long int
2937 pipe_exit_routine(void)
2938 {
2939     pInfo info;
2940     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2941     int sts, did_stuff, j;
2942
2943    /*
2944     * Flush any pending i/o, but since we are in process run-down, be
2945     * careful about referencing PerlIO structures that may already have
2946     * been deallocated.  We may not even have an interpreter anymore.
2947     */
2948     info = open_pipes;
2949     while (info) {
2950         if (info->fp) {
2951 #if defined(PERL_IMPLICIT_CONTEXT)
2952            /* We need to use the Perl context of the thread that created */
2953            /* the pipe. */
2954            pTHX;
2955            if (info->err)
2956                aTHX = info->err->thx;
2957            else if (info->out)
2958                aTHX = info->out->thx;
2959            else if (info->in)
2960                aTHX = info->in->thx;
2961 #endif
2962            if (!info->useFILE
2963 #if defined(USE_ITHREADS)
2964              && my_perl
2965 #endif
2966 #ifdef USE_PERLIO
2967              && PL_perlio_fd_refcnt
2968 #endif
2969               )
2970                PerlIO_flush(info->fp);
2971            else
2972                fflush((FILE *)info->fp);
2973         }
2974         info = info->next;
2975     }
2976
2977     /*
2978      next we try sending an EOF...ignore if doesn't work, make sure we
2979      don't hang
2980     */
2981     did_stuff = 0;
2982     info = open_pipes;
2983
2984     while (info) {
2985       _ckvmssts_noperl(sys$setast(0));
2986       if (info->in && !info->in->shut_on_empty) {
2987         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2988                                  0, 0, 0, 0, 0, 0));
2989         info->waiting = 1;
2990         did_stuff = 1;
2991       }
2992       _ckvmssts_noperl(sys$setast(1));
2993       info = info->next;
2994     }
2995
2996     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2997
2998     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2999         int nwait = 0;
3000
3001         info = open_pipes;
3002         while (info) {
3003           _ckvmssts_noperl(sys$setast(0));
3004           if (info->waiting && info->done)
3005                 info->waiting = 0;
3006           nwait += info->waiting;
3007           _ckvmssts_noperl(sys$setast(1));
3008           info = info->next;
3009         }
3010         if (!nwait) break;
3011         sleep(1);
3012     }
3013
3014     did_stuff = 0;
3015     info = open_pipes;
3016     while (info) {
3017       _ckvmssts_noperl(sys$setast(0));
3018       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3019         sts = sys$forcex(&info->pid,0,&abort);
3020         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3021         did_stuff = 1;
3022       }
3023       _ckvmssts_noperl(sys$setast(1));
3024       info = info->next;
3025     }
3026
3027     /* again, wait for effect */
3028
3029     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3030         int nwait = 0;
3031
3032         info = open_pipes;
3033         while (info) {
3034           _ckvmssts_noperl(sys$setast(0));
3035           if (info->waiting && info->done)
3036                 info->waiting = 0;
3037           nwait += info->waiting;
3038           _ckvmssts_noperl(sys$setast(1));
3039           info = info->next;
3040         }
3041         if (!nwait) break;
3042         sleep(1);
3043     }
3044
3045     info = open_pipes;
3046     while (info) {
3047       _ckvmssts_noperl(sys$setast(0));
3048       if (!info->done) {  /* We tried to be nice . . . */
3049         sts = sys$delprc(&info->pid,0);
3050         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3051         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3052       }
3053       _ckvmssts_noperl(sys$setast(1));
3054       info = info->next;
3055     }
3056
3057     while(open_pipes) {
3058
3059 #if defined(PERL_IMPLICIT_CONTEXT)
3060       /* We need to use the Perl context of the thread that created */
3061       /* the pipe. */
3062       pTHX;
3063       if (open_pipes->err)
3064           aTHX = open_pipes->err->thx;
3065       else if (open_pipes->out)
3066           aTHX = open_pipes->out->thx;
3067       else if (open_pipes->in)
3068           aTHX = open_pipes->in->thx;
3069 #endif
3070       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3071       else if (!(sts & 1)) retsts = sts;
3072     }
3073     return retsts;
3074 }
3075
3076 static struct exit_control_block pipe_exitblock =
3077        {(struct exit_control_block *) 0,
3078         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3079
3080 static void pipe_mbxtofd_ast(pPipe p);
3081 static void pipe_tochild1_ast(pPipe p);
3082 static void pipe_tochild2_ast(pPipe p);
3083
3084 static void
3085 popen_completion_ast(pInfo info)
3086 {
3087   pInfo i = open_pipes;
3088   int iss;
3089
3090   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3091   closed_list[closed_index].pid = info->pid;
3092   closed_list[closed_index].completion = info->completion;
3093   closed_index++;
3094   if (closed_index == NKEEPCLOSED)
3095     closed_index = 0;
3096   closed_num++;
3097
3098   while (i) {
3099     if (i == info) break;
3100     i = i->next;
3101   }
3102   if (!i) return;       /* unlinked, probably freed too */
3103
3104   info->done = TRUE;
3105
3106 /*
3107     Writing to subprocess ...
3108             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3109
3110             chan_out may be waiting for "done" flag, or hung waiting
3111             for i/o completion to child...cancel the i/o.  This will
3112             put it into "snarf mode" (done but no EOF yet) that discards
3113             input.
3114
3115     Output from subprocess (stdout, stderr) needs to be flushed and
3116     shut down.   We try sending an EOF, but if the mbx is full the pipe
3117     routine should still catch the "shut_on_empty" flag, telling it to
3118     use immediate-style reads so that "mbx empty" -> EOF.
3119
3120
3121 */
3122   if (info->in && !info->in_done) {               /* only for mode=w */
3123         if (info->in->shut_on_empty && info->in->need_wake) {
3124             info->in->need_wake = FALSE;
3125             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3126         } else {
3127             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3128         }
3129   }
3130
3131   if (info->out && !info->out_done) {             /* were we also piping output? */
3132       info->out->shut_on_empty = TRUE;
3133       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3134       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3135       _ckvmssts_noperl(iss);
3136   }
3137
3138   if (info->err && !info->err_done) {        /* we were piping stderr */
3139         info->err->shut_on_empty = TRUE;
3140         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3141         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3142         _ckvmssts_noperl(iss);
3143   }
3144   _ckvmssts_noperl(sys$setef(pipe_ef));
3145
3146 }
3147
3148 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3149 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3150 static void pipe_infromchild_ast(pPipe p);
3151
3152 /*
3153     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3154     inside an AST routine without worrying about reentrancy and which Perl
3155     memory allocator is being used.
3156
3157     We read data and queue up the buffers, then spit them out one at a
3158     time to the output mailbox when the output mailbox is ready for one.
3159
3160 */
3161 #define INITIAL_TOCHILDQUEUE  2
3162
3163 static pPipe
3164 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3165 {
3166     pPipe p;
3167     pCBuf b;
3168     char mbx1[64], mbx2[64];
3169     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3170                                       DSC$K_CLASS_S, mbx1},
3171                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3172                                       DSC$K_CLASS_S, mbx2};
3173     unsigned int dviitm = DVI$_DEVBUFSIZ;
3174     int j, n;
3175
3176     n = sizeof(Pipe);
3177     _ckvmssts_noperl(lib$get_vm(&n, &p));
3178
3179     create_mbx(&p->chan_in , &d_mbx1);
3180     create_mbx(&p->chan_out, &d_mbx2);
3181     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3182
3183     p->buf           = 0;
3184     p->shut_on_empty = FALSE;
3185     p->need_wake     = FALSE;
3186     p->type          = 0;
3187     p->retry         = 0;
3188     p->iosb.status   = SS$_NORMAL;
3189     p->iosb2.status  = SS$_NORMAL;
3190     p->free          = RQE_ZERO;
3191     p->wait          = RQE_ZERO;
3192     p->curr          = 0;
3193     p->curr2         = 0;
3194     p->info          = 0;
3195 #ifdef PERL_IMPLICIT_CONTEXT
3196     p->thx           = aTHX;
3197 #endif
3198
3199     n = sizeof(CBuf) + p->bufsize;
3200
3201     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3202         _ckvmssts_noperl(lib$get_vm(&n, &b));
3203         b->buf = (char *) b + sizeof(CBuf);
3204         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3205     }
3206
3207     pipe_tochild2_ast(p);
3208     pipe_tochild1_ast(p);
3209     strcpy(wmbx, mbx1);
3210     strcpy(rmbx, mbx2);
3211     return p;
3212 }
3213
3214 /*  reads the MBX Perl is writing, and queues */
3215
3216 static void
3217 pipe_tochild1_ast(pPipe p)
3218 {
3219     pCBuf b = p->curr;
3220     int iss = p->iosb.status;
3221     int eof = (iss == SS$_ENDOFFILE);
3222     int sts;
3223 #ifdef PERL_IMPLICIT_CONTEXT
3224     pTHX = p->thx;
3225 #endif
3226
3227     if (p->retry) {
3228         if (eof) {
3229             p->shut_on_empty = TRUE;
3230             b->eof     = TRUE;
3231             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3232         } else  {
3233             _ckvmssts_noperl(iss);
3234         }
3235
3236         b->eof  = eof;
3237         b->size = p->iosb.count;
3238         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3239         if (p->need_wake) {
3240             p->need_wake = FALSE;
3241             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3242         }
3243     } else {
3244         p->retry = 1;   /* initial call */
3245     }
3246
3247     if (eof) {                  /* flush the free queue, return when done */
3248         int n = sizeof(CBuf) + p->bufsize;
3249         while (1) {
3250             iss = lib$remqti(&p->free, &b);
3251             if (iss == LIB$_QUEWASEMP) return;
3252             _ckvmssts_noperl(iss);
3253             _ckvmssts_noperl(lib$free_vm(&n, &b));
3254         }
3255     }
3256
3257     iss = lib$remqti(&p->free, &b);
3258     if (iss == LIB$_QUEWASEMP) {
3259         int n = sizeof(CBuf) + p->bufsize;
3260         _ckvmssts_noperl(lib$get_vm(&n, &b));
3261         b->buf = (char *) b + sizeof(CBuf);
3262     } else {
3263        _ckvmssts_noperl(iss);
3264     }
3265
3266     p->curr = b;
3267     iss = sys$qio(0,p->chan_in,
3268              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3269              &p->iosb,
3270              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3271     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3272     _ckvmssts_noperl(iss);
3273 }
3274
3275
3276 /* writes queued buffers to output, waits for each to complete before
3277    doing the next */
3278
3279 static void
3280 pipe_tochild2_ast(pPipe p)
3281 {
3282     pCBuf b = p->curr2;
3283     int iss = p->iosb2.status;
3284     int n = sizeof(CBuf) + p->bufsize;
3285     int done = (p->info && p->info->done) ||
3286               iss == SS$_CANCEL || iss == SS$_ABORT;
3287 #if defined(PERL_IMPLICIT_CONTEXT)
3288     pTHX = p->thx;
3289 #endif
3290
3291     do {
3292         if (p->type) {         /* type=1 has old buffer, dispose */
3293             if (p->shut_on_empty) {
3294                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3295             } else {
3296                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3297             }
3298             p->type = 0;
3299         }
3300
3301         iss = lib$remqti(&p->wait, &b);
3302         if (iss == LIB$_QUEWASEMP) {
3303             if (p->shut_on_empty) {
3304                 if (done) {
3305                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3306                     *p->pipe_done = TRUE;
3307                     _ckvmssts_noperl(sys$setef(pipe_ef));
3308                 } else {
3309                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3310                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3311                 }
3312                 return;
3313             }
3314             p->need_wake = TRUE;
3315             return;
3316         }
3317         _ckvmssts_noperl(iss);
3318         p->type = 1;
3319     } while (done);
3320
3321
3322     p->curr2 = b;
3323     if (b->eof) {
3324         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3325             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3326     } else {
3327         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3328             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3329     }
3330
3331     return;
3332
3333 }
3334
3335
3336 static pPipe
3337 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3338 {
3339     pPipe p;
3340     char mbx1[64], mbx2[64];
3341     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3342                                       DSC$K_CLASS_S, mbx1},
3343                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3344                                       DSC$K_CLASS_S, mbx2};
3345     unsigned int dviitm = DVI$_DEVBUFSIZ;
3346
3347     int n = sizeof(Pipe);
3348     _ckvmssts_noperl(lib$get_vm(&n, &p));
3349     create_mbx(&p->chan_in , &d_mbx1);
3350     create_mbx(&p->chan_out, &d_mbx2);
3351
3352     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3353     n = p->bufsize * sizeof(char);
3354     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3355     p->shut_on_empty = FALSE;
3356     p->info   = 0;
3357     p->type   = 0;
3358     p->iosb.status = SS$_NORMAL;
3359 #if defined(PERL_IMPLICIT_CONTEXT)
3360     p->thx = aTHX;
3361 #endif
3362     pipe_infromchild_ast(p);
3363
3364     strcpy(wmbx, mbx1);
3365     strcpy(rmbx, mbx2);
3366     return p;
3367 }
3368
3369 static void
3370 pipe_infromchild_ast(pPipe p)
3371 {
3372     int iss = p->iosb.status;
3373     int eof = (iss == SS$_ENDOFFILE);
3374     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3375     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3376 #if defined(PERL_IMPLICIT_CONTEXT)
3377     pTHX = p->thx;
3378 #endif
3379
3380     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3381         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3382         p->chan_out = 0;
3383     }
3384
3385     /* read completed:
3386             input shutdown if EOF from self (done or shut_on_empty)
3387             output shutdown if closing flag set (my_pclose)
3388             send data/eof from child or eof from self
3389             otherwise, re-read (snarf of data from child)
3390     */
3391
3392     if (p->type == 1) {
3393         p->type = 0;
3394         if (myeof && p->chan_in) {                  /* input shutdown */
3395             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3396             p->chan_in = 0;
3397         }
3398
3399         if (p->chan_out) {
3400             if (myeof || kideof) {      /* pass EOF to parent */
3401                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3402                                          pipe_infromchild_ast, p,
3403                                          0, 0, 0, 0, 0, 0));
3404                 return;
3405             } else if (eof) {       /* eat EOF --- fall through to read*/
3406
3407             } else {                /* transmit data */
3408                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3409                                          pipe_infromchild_ast,p,
3410                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3411                 return;
3412             }
3413         }
3414     }
3415
3416     /*  everything shut? flag as done */
3417
3418     if (!p->chan_in && !p->chan_out) {
3419         *p->pipe_done = TRUE;
3420         _ckvmssts_noperl(sys$setef(pipe_ef));
3421         return;
3422     }
3423
3424     /* write completed (or read, if snarfing from child)
3425             if still have input active,
3426                queue read...immediate mode if shut_on_empty so we get EOF if empty
3427             otherwise,
3428                check if Perl reading, generate EOFs as needed
3429     */
3430
3431     if (p->type == 0) {
3432         p->type = 1;
3433         if (p->chan_in) {
3434             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3435                           pipe_infromchild_ast,p,
3436                           p->buf, p->bufsize, 0, 0, 0, 0);
3437             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3438             _ckvmssts_noperl(iss);
3439         } else {           /* send EOFs for extra reads */
3440             p->iosb.status = SS$_ENDOFFILE;
3441             p->iosb.dvispec = 0;
3442             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3443                                      0, 0, 0,
3444                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3445         }
3446     }
3447 }
3448
3449 static pPipe
3450 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3451 {
3452     pPipe p;
3453     char mbx[64];
3454     unsigned long dviitm = DVI$_DEVBUFSIZ;
3455     struct stat s;
3456     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3457                                       DSC$K_CLASS_S, mbx};
3458     int n = sizeof(Pipe);
3459
3460     /* things like terminals and mbx's don't need this filter */
3461     if (fd && fstat(fd,&s) == 0) {
3462         unsigned long devchar;
3463         char device[65];
3464         unsigned short dev_len;
3465         struct dsc$descriptor_s d_dev;
3466         char * cptr;
3467         struct item_list_3 items[3];
3468         int status;
3469         unsigned short dvi_iosb[4];
3470
3471         cptr = getname(fd, out, 1);
3472         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3473         d_dev.dsc$a_pointer = out;
3474         d_dev.dsc$w_length = strlen(out);
3475         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3476         d_dev.dsc$b_class = DSC$K_CLASS_S;
3477
3478         items[0].len = 4;
3479         items[0].code = DVI$_DEVCHAR;
3480         items[0].bufadr = &devchar;
3481         items[0].retadr = NULL;
3482         items[1].len = 64;
3483         items[1].code = DVI$_FULLDEVNAM;
3484         items[1].bufadr = device;
3485         items[1].retadr = &dev_len;
3486         items[2].len = 0;
3487         items[2].code = 0;
3488
3489         status = sys$getdviw
3490                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3491         _ckvmssts_noperl(status);
3492         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3493             device[dev_len] = 0;
3494
3495             if (!(devchar & DEV$M_DIR)) {
3496                 strcpy(out, device);
3497                 return 0;
3498             }
3499         }
3500     }
3501
3502     _ckvmssts_noperl(lib$get_vm(&n, &p));
3503     p->fd_out = dup(fd);
3504     create_mbx(&p->chan_in, &d_mbx);
3505     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3506     n = (p->bufsize+1) * sizeof(char);
3507     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3508     p->shut_on_empty = FALSE;
3509     p->retry = 0;
3510     p->info  = 0;
3511     strcpy(out, mbx);
3512
3513     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3514                              pipe_mbxtofd_ast, p,
3515                              p->buf, p->bufsize, 0, 0, 0, 0));
3516
3517     return p;
3518 }
3519
3520 static void
3521 pipe_mbxtofd_ast(pPipe p)
3522 {
3523     int iss = p->iosb.status;
3524     int done = p->info->done;
3525     int iss2;
3526     int eof = (iss == SS$_ENDOFFILE);
3527     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3528     int err = !(iss&1) && !eof;
3529 #if defined(PERL_IMPLICIT_CONTEXT)
3530     pTHX = p->thx;
3531 #endif
3532
3533     if (done && myeof) {               /* end piping */
3534         close(p->fd_out);
3535         sys$dassgn(p->chan_in);
3536         *p->pipe_done = TRUE;
3537         _ckvmssts_noperl(sys$setef(pipe_ef));
3538         return;
3539     }
3540
3541     if (!err && !eof) {             /* good data to send to file */
3542         p->buf[p->iosb.count] = '\n';
3543         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3544         if (iss2 < 0) {
3545             p->retry++;
3546             if (p->retry < MAX_RETRY) {
3547                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3548                 return;
3549             }
3550         }
3551         p->retry = 0;
3552     } else if (err) {
3553         _ckvmssts_noperl(iss);
3554     }
3555
3556
3557     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3558           pipe_mbxtofd_ast, p,
3559           p->buf, p->bufsize, 0, 0, 0, 0);
3560     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3561     _ckvmssts_noperl(iss);
3562 }
3563
3564
3565 typedef struct _pipeloc     PLOC;
3566 typedef struct _pipeloc*   pPLOC;
3567
3568 struct _pipeloc {
3569     pPLOC   next;
3570     char    dir[NAM$C_MAXRSS+1];
3571 };
3572 static pPLOC  head_PLOC = 0;
3573
3574 void
3575 free_pipelocs(pTHX_ void *head)
3576 {
3577     pPLOC p, pnext;
3578     pPLOC *pHead = (pPLOC *)head;
3579
3580     p = *pHead;
3581     while (p) {
3582         pnext = p->next;
3583         PerlMem_free(p);
3584         p = pnext;
3585     }
3586     *pHead = 0;
3587 }
3588
3589 static void
3590 store_pipelocs(pTHX)
3591 {
3592     int    i;
3593     pPLOC  p;
3594     AV    *av = 0;
3595     SV    *dirsv;
3596     char  *dir, *x;
3597     char  *unixdir;
3598     char  temp[NAM$C_MAXRSS+1];
3599     STRLEN n_a;
3600
3601     if (head_PLOC)
3602         free_pipelocs(aTHX_ &head_PLOC);
3603
3604 /*  the . directory from @INC comes last */
3605
3606     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3607     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3608     p->next = head_PLOC;
3609     head_PLOC = p;
3610     strcpy(p->dir,"./");
3611
3612 /*  get the directory from $^X */
3613
3614     unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3615     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3616
3617 #ifdef PERL_IMPLICIT_CONTEXT
3618     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3619 #else
3620     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3621 #endif
3622         my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3623         x = strrchr(temp,']');
3624         if (x == NULL) {
3625         x = strrchr(temp,'>');
3626           if (x == NULL) {
3627             /* It could be a UNIX path */
3628             x = strrchr(temp,'/');
3629           }
3630         }
3631         if (x)
3632           x[1] = '\0';
3633         else {
3634           /* Got a bare name, so use default directory */
3635           temp[0] = '.';
3636           temp[1] = '\0';
3637         }
3638
3639         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3640             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3641             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3642             p->next = head_PLOC;
3643             head_PLOC = p;
3644             my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3645         }
3646     }
3647
3648 /*  reverse order of @INC entries, skip "." since entered above */
3649
3650 #ifdef PERL_IMPLICIT_CONTEXT
3651     if (aTHX)
3652 #endif
3653     if (PL_incgv) av = GvAVn(PL_incgv);
3654
3655     for (i = 0; av && i <= AvFILL(av); i++) {
3656         dirsv = *av_fetch(av,i,TRUE);
3657
3658         if (SvROK(dirsv)) continue;
3659         dir = SvPVx(dirsv,n_a);
3660         if (strcmp(dir,".") == 0) continue;
3661         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3662             continue;
3663
3664         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3665         p->next = head_PLOC;
3666         head_PLOC = p;
3667         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3668     }
3669
3670 /* most likely spot (ARCHLIB) put first in the list */
3671
3672 #ifdef ARCHLIB_EXP
3673     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3674         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3675         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3676         p->next = head_PLOC;
3677         head_PLOC = p;
3678         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3679     }
3680 #endif
3681     PerlMem_free(unixdir);
3682 }
3683
3684 static I32
3685 Perl_cando_by_name_int
3686    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3687 #if !defined(PERL_IMPLICIT_CONTEXT)
3688 #define cando_by_name_int               Perl_cando_by_name_int
3689 #else
3690 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3691 #endif
3692
3693 static char *
3694 find_vmspipe(pTHX)
3695 {
3696     static int   vmspipe_file_status = 0;
3697     static char  vmspipe_file[NAM$C_MAXRSS+1];
3698
3699     /* already found? Check and use ... need read+execute permission */
3700
3701     if (vmspipe_file_status == 1) {
3702         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3703          && cando_by_name_int
3704            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3705             return vmspipe_file;
3706         }
3707         vmspipe_file_status = 0;
3708     }
3709
3710     /* scan through stored @INC, $^X */
3711
3712     if (vmspipe_file_status == 0) {
3713         char file[NAM$C_MAXRSS+1];
3714         pPLOC  p = head_PLOC;
3715
3716         while (p) {
3717             char * exp_res;
3718             int dirlen;
3719             dirlen = my_strlcpy(file, p->dir, sizeof(file));
3720             my_strlcat(file, "vmspipe.com", sizeof(file));
3721             p = p->next;
3722
3723             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3724             if (!exp_res) continue;
3725
3726             if (cando_by_name_int
3727                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3728              && cando_by_name_int
3729                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3730                 vmspipe_file_status = 1;
3731                 return vmspipe_file;
3732             }
3733         }
3734         vmspipe_file_status = -1;   /* failed, use tempfiles */
3735     }
3736
3737     return 0;
3738 }
3739
3740 static FILE *
3741 vmspipe_tempfile(pTHX)
3742 {
3743     char file[NAM$C_MAXRSS+1];
3744     FILE *fp;
3745     static int index = 0;
3746     Stat_t s0, s1;
3747     int cmp_result;
3748
3749     /* create a tempfile */
3750
3751     /* we can't go from   W, shr=get to  R, shr=get without
3752        an intermediate vulnerable state, so don't bother trying...
3753
3754        and lib$spawn doesn't shr=put, so have to close the write
3755
3756        So... match up the creation date/time and the FID to
3757        make sure we're dealing with the same file
3758
3759     */
3760
3761     index++;
3762     if (!decc_filename_unix_only) {
3763       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3764       fp = fopen(file,"w");
3765       if (!fp) {
3766         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3767         fp = fopen(file,"w");
3768         if (!fp) {
3769             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3770             fp = fopen(file,"w");
3771         }
3772       }
3773      }
3774      else {
3775       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3776       fp = fopen(file,"w");
3777       if (!fp) {
3778         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3779         fp = fopen(file,"w");
3780         if (!fp) {
3781           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3782           fp = fopen(file,"w");
3783         }
3784       }
3785     }
3786     if (!fp) return 0;  /* we're hosed */
3787
3788     fprintf(fp,"$! 'f$verify(0)'\n");
3789     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3790     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3791     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3792     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3793     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3794     fprintf(fp,"$ perl_del    = \"delete\"\n");
3795     fprintf(fp,"$ pif         = \"if\"\n");
3796     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3797     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3798     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3799     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3800     fprintf(fp,"$!  --- build command line to get max possible length\n");
3801     fprintf(fp,"$c=perl_popen_cmd0\n");
3802     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3803     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3804     fprintf(fp,"$x=perl_popen_cmd3\n");
3805     fprintf(fp,"$c=c+x\n");
3806     fprintf(fp,"$ perl_on\n");
3807     fprintf(fp,"$ 'c'\n");
3808     fprintf(fp,"$ perl_status = $STATUS\n");
3809     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3810     fprintf(fp,"$ perl_exit 'perl_status'\n");
3811     fsync(fileno(fp));
3812
3813     fgetname(fp, file, 1);
3814     fstat(fileno(fp), &s0.crtl_stat);
3815     fclose(fp);
3816
3817     if (decc_filename_unix_only)
3818         int_tounixspec(file, file, NULL);
3819     fp = fopen(file,"r","shr=get");
3820     if (!fp) return 0;
3821     fstat(fileno(fp), &s1.crtl_stat);
3822
3823     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3824     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3825         fclose(fp);
3826         return 0;
3827     }
3828
3829     return fp;
3830 }
3831
3832
3833 static int vms_is_syscommand_xterm(void)
3834 {
3835     const static struct dsc$descriptor_s syscommand_dsc =
3836       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3837
3838     const static struct dsc$descriptor_s decwdisplay_dsc =
3839       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3840
3841     struct item_list_3 items[2];
3842     unsigned short dvi_iosb[4];
3843     unsigned long devchar;
3844     unsigned long devclass;
3845     int status;
3846
3847     /* Very simple check to guess if sys$command is a decterm? */
3848     /* First see if the DECW$DISPLAY: device exists */
3849     items[0].len = 4;
3850     items[0].code = DVI$_DEVCHAR;
3851     items[0].bufadr = &devchar;
3852     items[0].retadr = NULL;
3853     items[1].len = 0;
3854     items[1].code = 0;
3855
3856     status = sys$getdviw
3857         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3858
3859     if ($VMS_STATUS_SUCCESS(status)) {
3860         status = dvi_iosb[0];
3861     }
3862
3863     if (!$VMS_STATUS_SUCCESS(status)) {
3864         SETERRNO(EVMSERR, status);
3865         return -1;
3866     }
3867
3868     /* If it does, then for now assume that we are on a workstation */
3869     /* Now verify that SYS$COMMAND is a terminal */
3870     /* for creating the debugger DECTerm */
3871
3872     items[0].len = 4;
3873     items[0].code = DVI$_DEVCLASS;
3874     items[0].bufadr = &devclass;
3875     items[0].retadr = NULL;
3876     items[1].len = 0;
3877     items[1].code = 0;
3878
3879     status = sys$getdviw
3880         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3881
3882     if ($VMS_STATUS_SUCCESS(status)) {
3883         status = dvi_iosb[0];
3884     }
3885
3886     if (!$VMS_STATUS_SUCCESS(status)) {
3887         SETERRNO(EVMSERR, status);
3888         return -1;
3889     }
3890     else {
3891         if (devclass == DC$_TERM) {
3892             return 0;
3893         }
3894     }
3895     return -1;
3896 }
3897
3898 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3899 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3900 {
3901     int status;
3902     int ret_stat;
3903     char * ret_char;
3904     char device_name[65];
3905     unsigned short device_name_len;
3906     struct dsc$descriptor_s customization_dsc;
3907     struct dsc$descriptor_s device_name_dsc;
3908     const char * cptr;
3909     char customization[200];
3910     char title[40];
3911     pInfo info = NULL;
3912     char mbx1[64];
3913     unsigned short p_chan;
3914     int n;
3915     unsigned short iosb[4];
3916     const char * cust_str =
3917         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3918     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3919                                           DSC$K_CLASS_S, mbx1};
3920
3921      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3922     /*---------------------------------------*/
3923     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3924
3925
3926     /* Make sure that this is from the Perl debugger */
3927     ret_char = strstr(cmd," xterm ");
3928     if (ret_char == NULL)
3929         return NULL;
3930     cptr = ret_char + 7;
3931     ret_char = strstr(cmd,"tty");
3932     if (ret_char == NULL)
3933         return NULL;
3934     ret_char = strstr(cmd,"sleep");
3935     if (ret_char == NULL)
3936         return NULL;
3937
3938     if (decw_term_port == 0) {
3939         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3940         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3941         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3942
3943        status = lib$find_image_symbol
3944                                (&filename1_dsc,
3945                                 &decw_term_port_dsc,
3946                                 (void *)&decw_term_port,
3947                                 NULL,
3948                                 0);
3949
3950         /* Try again with the other image name */
3951         if (!$VMS_STATUS_SUCCESS(status)) {
3952
3953            status = lib$find_image_symbol
3954                                (&filename2_dsc,
3955                                 &decw_term_port_dsc,
3956                                 (void *)&decw_term_port,
3957                                 NULL,
3958                                 0);
3959
3960         }
3961
3962     }
3963
3964
3965     /* No decw$term_port, give it up */
3966     if (!$VMS_STATUS_SUCCESS(status))
3967         return NULL;
3968
3969     /* Are we on a workstation? */
3970     /* to do: capture the rows / columns and pass their properties */
3971     ret_stat = vms_is_syscommand_xterm();
3972     if (ret_stat < 0)
3973         return NULL;
3974
3975     /* Make the title: */
3976     ret_char = strstr(cptr,"-title");
3977     if (ret_char != NULL) {
3978         while ((*cptr != 0) && (*cptr != '\"')) {
3979             cptr++;
3980         }
3981         if (*cptr == '\"')
3982             cptr++;
3983         n = 0;
3984         while ((*cptr != 0) && (*cptr != '\"')) {
3985             title[n] = *cptr;
3986             n++;
3987             if (n == 39) {
3988                 title[39] = 0;
3989                 break;
3990             }
3991             cptr++;
3992         }
3993         title[n] = 0;
3994     }
3995     else {
3996             /* Default title */
3997             strcpy(title,"Perl Debug DECTerm");
3998     }
3999     sprintf(customization, cust_str, title);
4000
4001     customization_dsc.dsc$a_pointer = customization;
4002     customization_dsc.dsc$w_length = strlen(customization);
4003     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4004     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4005
4006     device_name_dsc.dsc$a_pointer = device_name;
4007     device_name_dsc.dsc$w_length = sizeof device_name -1;
4008     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4009     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4010
4011     device_name_len = 0;
4012
4013     /* Try to create the window */
4014      status = (*decw_term_port)
4015        (NULL,
4016         NULL,
4017         &customization_dsc,
4018         &device_name_dsc,
4019         &device_name_len,
4020         NULL,
4021         NULL,
4022         NULL);
4023     if (!$VMS_STATUS_SUCCESS(status)) {
4024         SETERRNO(EVMSERR, status);
4025         return NULL;
4026     }
4027
4028     device_name[device_name_len] = '\0';
4029
4030     /* Need to set this up to look like a pipe for cleanup */
4031     n = sizeof(Info);
4032     status = lib$get_vm(&n, &info);
4033     if (!$VMS_STATUS_SUCCESS(status)) {
4034         SETERRNO(ENOMEM, status);
4035         return NULL;
4036     }
4037
4038     info->mode = *mode;
4039     info->done = FALSE;
4040     info->completion = 0;
4041     info->closing    = FALSE;
4042     info->in         = 0;
4043     info->out        = 0;
4044     info->err        = 0;
4045     info->fp         = NULL;
4046     info->useFILE    = 0;
4047     info->waiting    = 0;
4048     info->in_done    = TRUE;
4049     info->out_done   = TRUE;
4050     info->err_done   = TRUE;
4051
4052     /* Assign a channel on this so that it will persist, and not login */
4053     /* We stash this channel in the info structure for reference. */
4054     /* The created xterm self destructs when the last channel is removed */
4055     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4056     /* So leave this assigned. */
4057     device_name_dsc.dsc$w_length = device_name_len;
4058     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4059     if (!$VMS_STATUS_SUCCESS(status)) {
4060         SETERRNO(EVMSERR, status);
4061         return NULL;
4062     }
4063     info->xchan_valid = 1;
4064
4065     /* Now create a mailbox to be read by the application */
4066
4067     create_mbx(&p_chan, &d_mbx1);
4068
4069     /* write the name of the created terminal to the mailbox */
4070     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4071             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4072
4073     if (!$VMS_STATUS_SUCCESS(status)) {
4074         SETERRNO(EVMSERR, status);
4075         return NULL;
4076     }
4077
4078     info->fp  = PerlIO_open(mbx1, mode);
4079
4080     /* Done with this channel */
4081     sys$dassgn(p_chan);
4082
4083     /* If any errors, then clean up */
4084     if (!info->fp) {
4085         n = sizeof(Info);
4086         _ckvmssts_noperl(lib$free_vm(&n, &info));
4087         return NULL;
4088         }
4089
4090     /* All done */
4091     return info->fp;
4092 }
4093
4094 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4095
4096 static PerlIO *
4097 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4098 {
4099     static int handler_set_up = FALSE;
4100     PerlIO * ret_fp;
4101     unsigned long int sts, flags = CLI$M_NOWAIT;
4102     /* The use of a GLOBAL table (as was done previously) rendered
4103      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4104      * environment.  Hence we've switched to LOCAL symbol table.
4105      */
4106     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4107     int j, wait = 0, n;
4108     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4109     char *in, *out, *err, mbx[512];
4110     FILE *tpipe = 0;
4111     char tfilebuf[NAM$C_MAXRSS+1];
4112     pInfo info = NULL;
4113     char cmd_sym_name[20];
4114     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4115                                       DSC$K_CLASS_S, symbol};
4116     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4117                                       DSC$K_CLASS_S, 0};
4118     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4119                                       DSC$K_CLASS_S, cmd_sym_name};
4120     struct dsc$descriptor_s *vmscmd;
4121     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4122     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4123     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4124
4125     /* Check here for Xterm create request.  This means looking for
4126      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4127      *  is possible to create an xterm.
4128      */
4129     if (*in_mode == 'r') {
4130         PerlIO * xterm_fd;
4131
4132 #if defined(PERL_IMPLICIT_CONTEXT)
4133         /* Can not fork an xterm with a NULL context */
4134         /* This probably could never happen */
4135         xterm_fd = NULL;
4136         if (aTHX != NULL)
4137 #endif
4138         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4139         if (xterm_fd != NULL)
4140             return xterm_fd;
4141     }
4142
4143     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4144
4145     /* once-per-program initialization...
4146        note that the SETAST calls and the dual test of pipe_ef
4147        makes sure that only the FIRST thread through here does
4148        the initialization...all other threads wait until it's
4149        done.
4150
4151        Yeah, uglier than a pthread call, it's got all the stuff inline
4152        rather than in a separate routine.
4153     */
4154
4155     if (!pipe_ef) {
4156         _ckvmssts_noperl(sys$setast(0));
4157         if (!pipe_ef) {
4158             unsigned long int pidcode = JPI$_PID;
4159             $DESCRIPTOR(d_delay, RETRY_DELAY);
4160             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4161             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4162             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4163         }
4164         if (!handler_set_up) {
4165           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4166           handler_set_up = TRUE;
4167         }
4168         _ckvmssts_noperl(sys$setast(1));
4169     }
4170
4171     /* see if we can find a VMSPIPE.COM */
4172
4173     tfilebuf[0] = '@';
4174     vmspipe = find_vmspipe(aTHX);
4175     if (vmspipe) {
4176         vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4177     } else {        /* uh, oh...we're in tempfile hell */
4178         tpipe = vmspipe_tempfile(aTHX);
4179         if (!tpipe) {       /* a fish popular in Boston */
4180             if (ckWARN(WARN_PIPE)) {
4181                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4182             }
4183         return NULL;
4184         }
4185         fgetname(tpipe,tfilebuf+1,1);
4186         vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4187     }
4188     vmspipedsc.dsc$a_pointer = tfilebuf;
4189
4190     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4191     if (!(sts & 1)) {
4192       switch (sts) {
4193         case RMS$_FNF:  case RMS$_DNF:
4194           set_errno(ENOENT); break;
4195         case RMS$_DIR:
4196           set_errno(ENOTDIR); break;
4197         case RMS$_DEV:
4198           set_errno(ENODEV); break;
4199         case RMS$_PRV:
4200           set_errno(EACCES); break;
4201         case RMS$_SYN:
4202           set_errno(EINVAL); break;
4203         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4204           set_errno(E2BIG); break;
4205         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4206           _ckvmssts_noperl(sts); /* fall through */
4207         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4208           set_errno(EVMSERR);
4209       }
4210       set_vaxc_errno(sts);
4211       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4212         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4213       }
4214       *psts = sts;
4215       return NULL;
4216     }
4217     n = sizeof(Info);
4218     _ckvmssts_noperl(lib$get_vm(&n, &info));
4219
4220     my_strlcpy(mode, in_mode, sizeof(mode));
4221     info->mode = *mode;
4222     info->done = FALSE;
4223     info->completion = 0;
4224     info->closing    = FALSE;
4225     info->in         = 0;
4226     info->out        = 0;
4227     info->err        = 0;
4228     info->fp         = NULL;
4229     info->useFILE    = 0;
4230     info->waiting    = 0;
4231     info->in_done    = TRUE;
4232     info->out_done   = TRUE;
4233     info->err_done   = TRUE;
4234     info->xchan      = 0;
4235     info->xchan_valid = 0;
4236
4237     in = (char *)PerlMem_malloc(VMS_MAXRSS);
4238     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4239     out = (char *)PerlMem_malloc(VMS_MAXRSS);
4240     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4241     err = (char *)PerlMem_malloc(VMS_MAXRSS);
4242     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4243
4244     in[0] = out[0] = err[0] = '\0';
4245
4246     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4247         info->useFILE = 1;
4248         strcpy(p,p+1);
4249     }
4250     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4251         wait = 1;
4252         strcpy(p,p+1);
4253     }
4254
4255     if (*mode == 'r') {             /* piping from subroutine */
4256
4257         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4258         if (info->out) {
4259             info->out->pipe_done = &info->out_done;
4260             info->out_done = FALSE;
4261             info->out->info = info;
4262         }
4263         if (!info->useFILE) {
4264             info->fp  = PerlIO_open(mbx, mode);
4265         } else {
4266             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4267             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4268         }
4269
4270         if (!info->fp && info->out) {
4271             sys$cancel(info->out->chan_out);
4272
4273             while (!info->out_done) {
4274                 int done;
4275                 _ckvmssts_noperl(sys$setast(0));
4276                 done = info->out_done;
4277                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4278                 _ckvmssts_noperl(sys$setast(1));
4279                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4280             }
4281
4282             if (info->out->buf) {
4283                 n = info->out->bufsize * sizeof(char);
4284                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4285             }
4286             n = sizeof(Pipe);
4287             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4288             n = sizeof(Info);
4289             _ckvmssts_noperl(lib$free_vm(&n, &info));
4290             *psts = RMS$_FNF;
4291             return NULL;
4292         }
4293
4294         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4295         if (info->err) {
4296             info->err->pipe_done = &info->err_done;
4297             info->err_done = FALSE;
4298             info->err->info = info;
4299         }
4300
4301     } else if (*mode == 'w') {      /* piping to subroutine */
4302
4303         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4304         if (info->out) {
4305             info->out->pipe_done = &info->out_done;
4306             info->out_done = FALSE;
4307             info->out->info = info;
4308         }
4309
4310         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4311         if (info->err) {
4312             info->err->pipe_done = &info->err_done;
4313             info->err_done = FALSE;
4314             info->err->info = info;
4315         }
4316
4317         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4318         if (!info->useFILE) {
4319             info->fp  = PerlIO_open(mbx, mode);
4320         } else {
4321             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4322             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4323         }
4324
4325         if (info->in) {
4326             info->in->pipe_done = &info->in_done;
4327             info->in_done = FALSE;
4328             info->in->info = info;
4329         }
4330
4331         /* error cleanup */
4332         if (!info->fp && info->in) {
4333             info->done = TRUE;
4334             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4335                                       0, 0, 0, 0, 0, 0, 0, 0));
4336
4337             while (!info->in_done) {
4338                 int done;
4339                 _ckvmssts_noperl(sys$setast(0));
4340                 done = info->in_done;
4341                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4342                 _ckvmssts_noperl(sys$setast(1));
4343                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4344             }
4345
4346             if (info->in->buf) {
4347                 n = info->in->bufsize * sizeof(char);
4348                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4349             }
4350             n = sizeof(Pipe);
4351             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4352             n = sizeof(Info);
4353             _ckvmssts_noperl(lib$free_vm(&n, &info));
4354             *psts = RMS$_FNF;
4355             return NULL;
4356         }
4357
4358
4359     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4360         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4361         if (info->out) {
4362             info->out->pipe_done = &info->out_done;
4363             info->out_done = FALSE;
4364             info->out->info = info;
4365         }
4366
4367         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4368         if (info->err) {
4369             info->err->pipe_done = &info->err_done;
4370             info->err_done = FALSE;
4371             info->err->info = info;
4372         }
4373     }
4374
4375     d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4376     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4377
4378     d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4379     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4380
4381     d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4382     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4383
4384     /* Done with the names for the pipes */
4385     PerlMem_free(err);
4386     PerlMem_free(out);
4387     PerlMem_free(in);
4388
4389     p = vmscmd->dsc$a_pointer;
4390     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4391     if (*p == '$') p++;                         /* remove leading $ */
4392     while (*p == ' ' || *p == '\t') p++;
4393
4394     for (j = 0; j < 4; j++) {
4395         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4396         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4397
4398     d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4399     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4400
4401         if (strlen(p) > MAX_DCL_SYMBOL) {
4402             p += MAX_DCL_SYMBOL;
4403         } else {
4404             p += strlen(p);
4405         }
4406     }
4407     _ckvmssts_noperl(sys$setast(0));
4408     info->next=open_pipes;  /* prepend to list */
4409     open_pipes=info;
4410     _ckvmssts_noperl(sys$setast(1));
4411     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4412      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4413      * have SYS$COMMAND if we need it.
4414      */
4415     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4416                       0, &info->pid, &info->completion,
4417                       0, popen_completion_ast,info,0,0,0));
4418
4419     /* if we were using a tempfile, close it now */
4420
4421     if (tpipe) fclose(tpipe);
4422
4423     /* once the subprocess is spawned, it has copied the symbols and
4424        we can get rid of ours */
4425
4426     for (j = 0; j < 4; j++) {
4427         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4428         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4429     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4430     }
4431     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4432     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4433     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4434     vms_execfree(vmscmd);
4435
4436 #ifdef PERL_IMPLICIT_CONTEXT
4437     if (aTHX)
4438 #endif
4439     PL_forkprocess = info->pid;
4440
4441     ret_fp = info->fp;
4442     if (wait) {
4443          dSAVEDERRNO;
4444          int done = 0;
4445          while (!done) {
4446              _ckvmssts_noperl(sys$setast(0));
4447              done = info->done;
4448              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4449              _ckvmssts_noperl(sys$setast(1));
4450              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4451          }
4452         *psts = info->completion;
4453 /* Caller thinks it is open and tries to close it. */
4454 /* This causes some problems, as it changes the error status */
4455 /*        my_pclose(info->fp); */
4456
4457          /* If we did not have a file pointer open, then we have to */
4458          /* clean up here or eventually we will run out of something */
4459          SAVE_ERRNO;
4460          if (info->fp == NULL) {
4461              my_pclose_pinfo(aTHX_ info);
4462          }
4463          RESTORE_ERRNO;
4464
4465     } else {
4466         *psts = info->pid;
4467     }
4468     return ret_fp;
4469 }  /* end of safe_popen */
4470
4471
4472 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4473 PerlIO *
4474 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4475 {
4476     int sts;
4477     TAINT_ENV();
4478     TAINT_PROPER("popen");
4479     PERL_FLUSHALL_FOR_CHILD;
4480     return safe_popen(aTHX_ cmd,mode,&sts);
4481 }
4482
4483 /*}}}*/
4484
4485
4486 /* Routine to close and cleanup a pipe info structure */
4487
4488 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4489
4490     unsigned long int retsts;
4491     int done, n;
4492     pInfo next, last;
4493
4494     /* If we were writing to a subprocess, insure that someone reading from
4495      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4496      * produce an EOF record in the mailbox.
4497      *
4498      *  well, at least sometimes it *does*, so we have to watch out for
4499      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4500      */
4501      if (info->fp) {
4502         if (!info->useFILE
4503 #if defined(USE_ITHREADS)
4504           && my_perl
4505 #endif
4506 #ifdef USE_PERLIO
4507           && PL_perlio_fd_refcnt
4508 #endif
4509            )
4510             PerlIO_flush(info->fp);
4511         else
4512             fflush((FILE *)info->fp);
4513     }
4514
4515     _ckvmssts(sys$setast(0));
4516      info->closing = TRUE;
4517      done = info->done && info->in_done && info->out_done && info->err_done;
4518      /* hanging on write to Perl's input? cancel it */
4519      if (info->mode == 'r' && info->out && !info->out_done) {
4520         if (info->out->chan_out) {
4521             _ckvmssts(sys$cancel(info->out->chan_out));
4522             if (!info->out->chan_in) {   /* EOF generation, need AST */
4523                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4524             }
4525         }
4526      }
4527      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4528          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4529                            0, 0, 0, 0, 0, 0));
4530     _ckvmssts(sys$setast(1));
4531     if (info->fp) {
4532      if (!info->useFILE
4533 #if defined(USE_ITHREADS)
4534          && my_perl
4535 #endif
4536 #ifdef USE_PERLIO
4537          && PL_perlio_fd_refcnt
4538 #endif
4539         )
4540         PerlIO_close(info->fp);
4541      else
4542         fclose((FILE *)info->fp);
4543     }
4544      /*
4545         we have to wait until subprocess completes, but ALSO wait until all
4546         the i/o completes...otherwise we'll be freeing the "info" structure
4547         that the i/o ASTs could still be using...
4548      */
4549
4550      while (!done) {
4551          _ckvmssts(sys$setast(0));
4552          done = info->done && info->in_done && info->out_done && info->err_done;
4553          if (!done) _ckvmssts(sys$clref(pipe_ef));
4554          _ckvmssts(sys$setast(1));
4555          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4556      }
4557      retsts = info->completion;
4558
4559     /* remove from list of open pipes */
4560     _ckvmssts(sys$setast(0));
4561     last = NULL;
4562     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4563         if (next == info)
4564             break;
4565     }
4566
4567     if (last)
4568         last->next = info->next;
4569     else
4570         open_pipes = info->next;
4571     _ckvmssts(sys$setast(1));
4572
4573     /* free buffers and structures */
4574
4575     if (info->in) {
4576         if (info->in->buf) {
4577             n = info->in->bufsize * sizeof(char);
4578             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4579         }
4580         n = sizeof(Pipe);
4581         _ckvmssts(lib$free_vm(&n, &info->in));
4582     }
4583     if (info->out) {
4584         if (info->out->buf) {
4585             n = info->out->bufsize * sizeof(char);
4586             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4587         }
4588         n = sizeof(Pipe);
4589         _ckvmssts(lib$free_vm(&n, &info->out));
4590     }
4591     if (info->err) {
4592         if (info->err->buf) {
4593             n = info->err->bufsize * sizeof(char);
4594             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4595         }
4596         n = sizeof(Pipe);
4597         _ckvmssts(lib$free_vm(&n, &info->err));
4598     }
4599     n = sizeof(Info);
4600     _ckvmssts(lib$free_vm(&n, &info));
4601
4602     return retsts;
4603 }
4604
4605
4606 /*{{{  I32 my_pclose(PerlIO *fp)*/
4607 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4608 {
4609     pInfo info, last = NULL;
4610     I32 ret_status;
4611
4612     /* Fixme - need ast and mutex protection here */
4613     for (info = open_pipes; info != NULL; last = info, info = info->next)
4614         if (info->fp == fp) break;
4615
4616     if (info == NULL) {  /* no such pipe open */
4617       set_errno(ECHILD); /* quoth POSIX */
4618       set_vaxc_errno(SS$_NONEXPR);
4619       return -1;
4620     }
4621
4622     ret_status = my_pclose_pinfo(aTHX_ info);
4623
4624     return ret_status;
4625
4626 }  /* end of my_pclose() */
4627
4628 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4629   /* Roll our own prototype because we want this regardless of whether
4630    * _VMS_WAIT is defined.
4631    */
4632
4633 #ifdef __cplusplus
4634 extern "C" {
4635 #endif
4636   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4637 #ifdef __cplusplus
4638 }
4639 #endif
4640
4641 #endif
4642 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4643    created with popen(); otherwise partially emulate waitpid() unless
4644    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4645    Also check processes not considered by the CRTL waitpid().
4646  */
4647 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4648 Pid_t
4649 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4650 {
4651     pInfo info;
4652     int done;
4653     int sts;
4654     int j;
4655
4656     if (statusp) *statusp = 0;
4657
4658     for (info = open_pipes; info != NULL; info = info->next)
4659         if (info->pid == pid) break;
4660
4661     if (info != NULL) {  /* we know about this child */
4662       while (!info->done) {
4663           _ckvmssts(sys$setast(0));
4664           done = info->done;
4665           if (!done) _ckvmssts(sys$clref(pipe_ef));
4666           _ckvmssts(sys$setast(1));
4667           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4668       }
4669
4670       if (statusp) *statusp = info->completion;
4671       return pid;
4672     }
4673
4674     /* child that already terminated? */
4675
4676     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4677         if (closed_list[j].pid == pid) {
4678             if (statusp) *statusp = closed_list[j].completion;
4679             return pid;
4680         }
4681     }
4682
4683     /* fall through if this child is not one of our own pipe children */
4684
4685 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4686
4687       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4688        * in 7.2 did we get a version that fills in the VMS completion
4689        * status as Perl has always tried to do.
4690        */
4691
4692       sts = __vms_waitpid( pid, statusp, flags );
4693
4694       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4695          return sts;
4696
4697       /* If the real waitpid tells us the child does not exist, we
4698        * fall through here to implement waiting for a child that
4699        * was created by some means other than exec() (say, spawned
4700        * from DCL) or to wait for a process that is not a subprocess
4701        * of the current process.
4702        */
4703
4704 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4705
4706     {
4707       $DESCRIPTOR(intdsc,"0 00:00:01");
4708       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4709       unsigned long int pidcode = JPI$_PID, mypid;
4710       unsigned long int interval[2];
4711       unsigned int jpi_iosb[2];
4712       struct itmlst_3 jpilist[2] = {
4713           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4714           {                      0,         0,                 0, 0}
4715       };
4716
4717       if (pid <= 0) {
4718         /* Sorry folks, we don't presently implement rooting around for
4719            the first child we can find, and we definitely don't want to
4720            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4721          */
4722         set_errno(ENOTSUP);
4723         return -1;
4724       }
4725
4726       /* Get the owner of the child so I can warn if it's not mine. If the
4727        * process doesn't exist or I don't have the privs to look at it,
4728        * I can go home early.
4729        */
4730       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4731       if (sts & 1) sts = jpi_iosb[0];
4732       if (!(sts & 1)) {
4733         switch (sts) {
4734             case SS$_NONEXPR:
4735                 set_errno(ECHILD);
4736                 break;
4737             case SS$_NOPRIV:
4738                 set_errno(EACCES);
4739                 break;
4740             default:
4741                 _ckvmssts(sts);
4742         }
4743         set_vaxc_errno(sts);
4744         return -1;
4745       }
4746
4747       if (ckWARN(WARN_EXEC)) {
4748         /* remind folks they are asking for non-standard waitpid behavior */
4749         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4750         if (ownerpid != mypid)
4751           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4752                       "waitpid: process %x is not a child of process %x",
4753                       pid,mypid);
4754       }
4755
4756       /* simply check on it once a second until it's not there anymore. */
4757
4758       _ckvmssts(sys$bintim(&intdsc,interval));
4759       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4760             _ckvmssts(sys$schdwk(0,0,interval,0));
4761             _ckvmssts(sys$hiber());
4762       }
4763       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4764
4765       _ckvmssts(sts);
4766       return pid;
4767     }
4768 }  /* end of waitpid() */
4769 /*}}}*/
4770 /*}}}*/
4771 /*}}}*/
4772
4773 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4774 char *
4775 my_gconvert(double val, int ndig, int trail, char *buf)
4776 {
4777   static char __gcvtbuf[DBL_DIG+1];
4778   char *loc;
4779
4780   loc = buf ? buf : __gcvtbuf;
4781
4782   if (val) {
4783     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4784     return gcvt(val,ndig,loc);
4785   }
4786   else {
4787     loc[0] = '0'; loc[1] = '\0';
4788     return loc;
4789   }
4790
4791 }
4792 /*}}}*/
4793
4794 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4795 static int rms_free_search_context(struct FAB * fab)
4796 {
4797 struct NAM * nam;
4798
4799     nam = fab->fab$l_nam;
4800     nam->nam$b_nop |= NAM$M_SYNCHK;
4801     nam->nam$l_rlf = NULL;
4802     fab->fab$b_dns = 0;
4803     return sys$parse(fab, NULL, NULL);
4804 }
4805
4806 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4807 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4808 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4809 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4810 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4811 #define rms_nam_esll(nam) nam.nam$b_esl
4812 #define rms_nam_esl(nam) nam.nam$b_esl
4813 #define rms_nam_name(nam) nam.nam$l_name
4814 #define rms_nam_namel(nam) nam.nam$l_name
4815 #define rms_nam_type(nam) nam.nam$l_type
4816 #define rms_nam_typel(nam) nam.nam$l_type
4817 #define rms_nam_ver(nam) nam.nam$l_ver
4818 #define rms_nam_verl(nam) nam.nam$l_ver
4819 #define rms_nam_rsll(nam) nam.nam$b_rsl
4820 #define rms_nam_rsl(nam) nam.nam$b_rsl
4821 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4822 #define rms_set_fna(fab, nam, name, size) \
4823         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4824 #define rms_get_fna(fab, nam) fab.fab$l_fna
4825 #define rms_set_dna(fab, nam, name, size) \
4826         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4827 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4828 #define rms_set_esa(nam, name, size) \
4829         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4830 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4831         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4832 #define rms_set_rsa(nam, name, size) \
4833         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4834 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4835         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4836 #define rms_nam_name_type_l_size(nam) \
4837         (nam.nam$b_name + nam.nam$b_type)
4838 #else
4839 static int rms_free_search_context(struct FAB * fab)
4840 {
4841 struct NAML * nam;
4842
4843     nam = fab->fab$l_naml;
4844     nam->naml$b_nop |= NAM$M_SYNCHK;
4845     nam->naml$l_rlf = NULL;
4846     nam->naml$l_long_defname_size = 0;
4847
4848     fab->fab$b_dns = 0;
4849     return sys$parse(fab, NULL, NULL);
4850 }
4851
4852 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4853 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4854 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4855 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4856 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4857 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4858 #define rms_nam_esl(nam) nam.naml$b_esl
4859 #define rms_nam_name(nam) nam.naml$l_name
4860 #define rms_nam_namel(nam) nam.naml$l_long_name
4861 #define rms_nam_type(nam) nam.naml$l_type
4862 #define rms_nam_typel(nam) nam.naml$l_long_type
4863 #define rms_nam_ver(nam) nam.naml$l_ver
4864 #define rms_nam_verl(nam) nam.naml$l_long_ver
4865 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4866 #define rms_nam_rsl(nam) nam.naml$b_rsl
4867 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4868 #define rms_set_fna(fab, nam, name, size) \
4869         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4870         nam.naml$l_long_filename_size = size; \
4871         nam.naml$l_long_filename = name;}
4872 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4873 #define rms_set_dna(fab, nam, name, size) \
4874         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4875         nam.naml$l_long_defname_size = size; \
4876         nam.naml$l_long_defname = name; }
4877 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4878 #define rms_set_esa(nam, name, size) \
4879         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4880         nam.naml$l_long_expand_alloc = size; \
4881         nam.naml$l_long_expand = name; }
4882 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4883         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4884         nam.naml$l_long_expand = l_name; \
4885         nam.naml$l_long_expand_alloc = l_size; }
4886 #define rms_set_rsa(nam, name, size) \
4887         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4888         nam.naml$l_long_result = name; \
4889         nam.naml$l_long_result_alloc = size; }
4890 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4891         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4892         nam.naml$l_long_result = l_name; \
4893         nam.naml$l_long_result_alloc = l_size; }
4894 #define rms_nam_name_type_l_size(nam) \
4895         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4896 #endif
4897
4898
4899 /* rms_erase
4900  * The CRTL for 8.3 and later can create symbolic links in any mode,
4901  * however in 8.3 the unlink/remove/delete routines will only properly handle
4902  * them if one of the PCP modes is active.
4903  */
4904 static int rms_erase(const char * vmsname)
4905 {
4906   int status;
4907   struct FAB myfab = cc$rms_fab;
4908   rms_setup_nam(mynam);
4909
4910   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4911   rms_bind_fab_nam(myfab, mynam);
4912
4913 #ifdef NAML$M_OPEN_SPECIAL
4914   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4915 #endif
4916
4917   status = sys$erase(&myfab, 0, 0);
4918
4919   return status;
4920 }
4921
4922
4923 static int
4924 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4925                     const struct dsc$descriptor_s * vms_dst_dsc,
4926                     unsigned long flags)
4927 {
4928     /*  VMS and UNIX handle file permissions differently and the
4929      * the same ACL trick may be needed for renaming files,
4930      * especially if they are directories.
4931      */
4932
4933    /* todo: get kill_file and rename to share common code */
4934    /* I can not find online documentation for $change_acl
4935     * it appears to be replaced by $set_security some time ago */
4936
4937 const unsigned int access_mode = 0;
4938 $DESCRIPTOR(obj_file_dsc,"FILE");
4939 char *vmsname;
4940 char *rslt;
4941 unsigned long int jpicode = JPI$_UIC;
4942 int aclsts, fndsts, rnsts = -1;
4943 unsigned int ctx = 0;
4944 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4945 struct dsc$descriptor_s * clean_dsc;
4946
4947 struct myacedef {
4948     unsigned char myace$b_length;
4949     unsigned char myace$b_type;
4950     unsigned short int myace$w_flags;
4951     unsigned long int myace$l_access;
4952     unsigned long int myace$l_ident;
4953 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4954              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4955              0},
4956              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4957
4958 struct item_list_3
4959         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4960                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4961                       {0,0,0,0}},
4962         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4963         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4964                      {0,0,0,0}};
4965
4966
4967     /* Expand the input spec using RMS, since we do not want to put
4968      * ACLs on the target of a symbolic link */
4969     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
4970     if (vmsname == NULL)
4971         return SS$_INSFMEM;
4972
4973     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4974                         vmsname,
4975                         PERL_RMSEXPAND_M_SYMLINK);
4976     if (rslt == NULL) {
4977         PerlMem_free(vmsname);
4978         return SS$_INSFMEM;
4979     }
4980
4981     /* So we get our own UIC to use as a rights identifier,
4982      * and the insert an ACE at the head of the ACL which allows us
4983      * to delete the file.
4984      */
4985     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4986
4987     fildsc.dsc$w_length = strlen(vmsname);
4988     fildsc.dsc$a_pointer = vmsname;
4989     ctx = 0;
4990     newace.myace$l_ident = oldace.myace$l_ident;
4991     rnsts = SS$_ABORT;
4992
4993     /* Grab any existing ACEs with this identifier in case we fail */
4994     clean_dsc = &fildsc;
4995     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4996                                &fildsc,
4997                                NULL,
4998                                OSS$M_WLOCK,
4999                                findlst,
5000                                &ctx,
5001                                &access_mode);
5002
5003     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5004         /* Add the new ACE . . . */
5005
5006         /* if the sys$get_security succeeded, then ctx is valid, and the
5007          * object/file descriptors will be ignored.  But otherwise they
5008          * are needed
5009          */
5010         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5011                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5012         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5013             set_errno(EVMSERR);
5014             set_vaxc_errno(aclsts);
5015             PerlMem_free(vmsname);
5016             return aclsts;
5017         }
5018
5019         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5020                                 NULL, NULL,
5021                                 &flags,
5022                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5023
5024         if ($VMS_STATUS_SUCCESS(rnsts)) {
5025             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5026         }
5027
5028         /* Put things back the way they were. */
5029         ctx = 0;
5030         aclsts = sys$get_security(&obj_file_dsc,
5031                                   clean_dsc,
5032                                   NULL,
5033                                   OSS$M_WLOCK,
5034                                   findlst,
5035                                   &ctx,
5036                                   &access_mode);
5037
5038         if ($VMS_STATUS_SUCCESS(aclsts)) {
5039         int sec_flags;
5040
5041             sec_flags = 0;
5042             if (!$VMS_STATUS_SUCCESS(fndsts))
5043                 sec_flags = OSS$M_RELCTX;
5044
5045             /* Get rid of the new ACE */
5046             aclsts = sys$set_security(NULL, NULL, NULL,
5047                                   sec_flags, dellst, &ctx, &access_mode);
5048
5049             /* If there was an old ACE, put it back */
5050             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5051                 addlst[0].bufadr = &oldace;
5052                 aclsts = sys$set_security(NULL, NULL, NULL,
5053                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5054                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5055                     set_errno(EVMSERR);
5056                     set_vaxc_errno(aclsts);
5057                     rnsts = aclsts;
5058                 }
5059             } else {
5060             int aclsts2;
5061
5062                 /* Try to clear the lock on the ACL list */
5063                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5064                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5065
5066                 /* Rename errors are most important */
5067                 if (!$VMS_STATUS_SUCCESS(rnsts))
5068                     aclsts = rnsts;
5069                 set_errno(EVMSERR);
5070                 set_vaxc_errno(aclsts);
5071                 rnsts = aclsts;
5072             }
5073         }
5074         else {
5075             if (aclsts != SS$_ACLEMPTY)
5076                 rnsts = aclsts;
5077         }
5078     }
5079     else
5080         rnsts = fndsts;
5081
5082     PerlMem_free(vmsname);
5083     return rnsts;
5084 }
5085
5086
5087 /*{{{int rename(const char *, const char * */
5088 /* Not exactly what X/Open says to do, but doing it absolutely right
5089  * and efficiently would require a lot more work.  This should be close
5090  * enough to pass all but the most strict X/Open compliance test.
5091  */
5092 int
5093 Perl_rename(pTHX_ const char *src, const char * dst)
5094 {
5095 int retval;
5096 int pre_delete = 0;
5097 int src_sts;
5098 int dst_sts;
5099 Stat_t src_st;
5100 Stat_t dst_st;
5101
5102     /* Validate the source file */
5103     src_sts = flex_lstat(src, &src_st);
5104     if (src_sts != 0) {
5105
5106         /* No source file or other problem */
5107         return src_sts;
5108     }
5109     if (src_st.st_devnam[0] == 0)  {
5110         /* This may be possible so fail if it is seen. */
5111         errno = EIO;
5112         return -1;
5113     }
5114
5115     dst_sts = flex_lstat(dst, &dst_st);
5116     if (dst_sts == 0) {
5117
5118         if (dst_st.st_dev != src_st.st_dev) {
5119             /* Must be on the same device */
5120             errno = EXDEV;
5121             return -1;
5122         }
5123
5124         /* VMS_INO_T_COMPARE is true if the inodes are different
5125          * to match the output of memcmp
5126          */
5127
5128         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5129             /* That was easy, the files are the same! */
5130             return 0;
5131         }
5132
5133         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5134             /* If source is a directory, so must be dest */
5135                 errno = EISDIR;
5136                 return -1;
5137         }
5138
5139     }
5140
5141
5142     if ((dst_sts == 0) &&
5143         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5144
5145         /* We have issues here if vms_unlink_all_versions is set
5146          * If the destination exists, and is not a directory, then
5147          * we must delete in advance.
5148          *
5149          * If the src is a directory, then we must always pre-delete
5150          * the destination.
5151          *
5152          * If we successfully delete the dst in advance, and the rename fails
5153          * X/Open requires that errno be EIO.
5154          *
5155          */
5156
5157         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5158             int d_sts;
5159             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5160                                      S_ISDIR(dst_st.st_mode));
5161
5162            /* Need to delete all versions ? */
5163            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5164                 int i = 0;
5165
5166                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5167                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5168                     if (d_sts != 0)
5169                         break;
5170                     i++;
5171
5172                     /* Make sure that we do not loop forever */
5173                     if (i > 32767) {
5174                         errno = EIO;
5175                         d_sts = -1;
5176                         break;
5177                     }
5178                 }
5179            }
5180
5181             if (d_sts != 0)
5182                 return d_sts;
5183
5184             /* We killed the destination, so only errno now is EIO */
5185             pre_delete = 1;
5186         }
5187     }
5188
5189     /* Originally the idea was to call the CRTL rename() and only
5190      * try the lib$rename_file if it failed.
5191      * It turns out that there are too many variants in what the
5192      * the CRTL rename might do, so only use lib$rename_file
5193      */
5194     retval = -1;
5195
5196     {
5197         /* Is the source and dest both in VMS format */
5198         /* if the source is a directory, then need to fileify */
5199         /*  and dest must be a directory or non-existent. */
5200
5201         char * vms_dst;
5202         int sts;
5203         char * ret_str;
5204         unsigned long flags;
5205         struct dsc$descriptor_s old_file_dsc;
5206         struct dsc$descriptor_s new_file_dsc;
5207
5208         /* We need to modify the src and dst depending
5209          * on if one or more of them are directories.
5210          */
5211
5212         vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
5213         if (vms_dst == NULL)
5214             _ckvmssts_noperl(SS$_INSFMEM);
5215
5216         if (S_ISDIR(src_st.st_mode)) {
5217         char * ret_str;
5218         char * vms_dir_file;
5219
5220             vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
5221             if (vms_dir_file == NULL)
5222                 _ckvmssts_noperl(SS$_INSFMEM);
5223
5224             /* If the dest is a directory, we must remove it */
5225             if (dst_sts == 0) {
5226                 int d_sts;
5227                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5228                 if (d_sts != 0) {
5229                     PerlMem_free(vms_dst);
5230                     errno = EIO;
5231                     return d_sts;
5232                 }
5233
5234                 pre_delete = 1;
5235             }
5236
5237            /* The dest must be a VMS file specification */
5238            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5239            if (ret_str == NULL) {
5240                 PerlMem_free(vms_dst);
5241                 errno = EIO;
5242                 return -1;
5243            }
5244
5245             /* The source must be a file specification */
5246             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5247             if (ret_str == NULL) {
5248                 PerlMem_free(vms_dst);
5249                 PerlMem_free(vms_dir_file);
5250                 errno = EIO;
5251                 return -1;
5252             }
5253             PerlMem_free(vms_dst);
5254             vms_dst = vms_dir_file;
5255
5256         } else {
5257             /* File to file or file to new dir */
5258
5259             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5260                 /* VMS pathify a dir target */
5261                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5262                 if (ret_str == NULL) {
5263                     PerlMem_free(vms_dst);
5264                     errno = EIO;
5265                     return -1;
5266                 }
5267             } else {
5268                 char * v_spec, * r_spec, * d_spec, * n_spec;
5269                 char * e_spec, * vs_spec;
5270                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5271
5272                 /* fileify a target VMS file specification */
5273                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5274                 if (ret_str == NULL) {
5275                     PerlMem_free(vms_dst);
5276                     errno = EIO;
5277                     return -1;
5278                 }
5279
5280                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5281                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5282                              &e_len, &vs_spec, &vs_len);
5283                 if (sts == 0) {
5284                      if (e_len == 0) {
5285                          /* Get rid of the version */
5286                          if (vs_len != 0) {
5287                              *vs_spec = '\0';
5288                          }
5289                          /* Need to specify a '.' so that the extension */
5290                          /* is not inherited */
5291                          strcat(vms_dst,".");
5292                      }
5293                 }
5294             }
5295         }
5296
5297         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5298         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5299         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5300         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5301
5302         new_file_dsc.dsc$a_pointer = vms_dst;
5303         new_file_dsc.dsc$w_length = strlen(vms_dst);
5304         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5305         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5306
5307         flags = 0;
5308 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5309         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5310 #endif
5311
5312         sts = lib$rename_file(&old_file_dsc,
5313                               &new_file_dsc,
5314                               NULL, NULL,
5315                               &flags,
5316                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5317         if (!$VMS_STATUS_SUCCESS(sts)) {
5318
5319            /* We could have failed because VMS style permissions do not
5320             * permit renames that UNIX will allow.  Just like the hack
5321             * in for kill_file.
5322             */
5323            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5324         }
5325
5326         PerlMem_free(vms_dst);
5327         if (!$VMS_STATUS_SUCCESS(sts)) {
5328             errno = EIO;
5329             return -1;
5330         }
5331         retval = 0;
5332     }
5333
5334     if (vms_unlink_all_versions) {
5335         /* Now get rid of any previous versions of the source file that
5336          * might still exist
5337          */
5338         int i = 0;
5339         dSAVEDERRNO;
5340         SAVE_ERRNO;
5341         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5342                                    S_ISDIR(src_st.st_mode));
5343         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5344              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5345                                        S_ISDIR(src_st.st_mode));
5346              if (src_sts != 0)
5347                  break;
5348              i++;
5349
5350              /* Make sure that we do not loop forever */
5351              if (i > 32767) {
5352                  src_sts = -1;
5353                  break;
5354              }
5355         }
5356         RESTORE_ERRNO;
5357     }
5358
5359     /* We deleted the destination, so must force the error to be EIO */
5360     if ((retval != 0) && (pre_delete != 0))
5361         errno = EIO;
5362
5363     return retval;
5364 }
5365 /*}}}*/
5366
5367
5368 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5369 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5370  * to expand file specification.  Allows for a single default file
5371  * specification and a simple mask of options.  If outbuf is non-NULL,
5372  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5373  * the resultant file specification is placed.  If outbuf is NULL, the
5374  * resultant file specification is placed into a static buffer.
5375  * The third argument, if non-NULL, is taken to be a default file
5376  * specification string.  The fourth argument is unused at present.
5377  * rmesexpand() returns the address of the resultant string if
5378  * successful, and NULL on error.
5379  *
5380  * New functionality for previously unused opts value:
5381  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5382  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5383  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5384  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5385  */
5386 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5387
5388 static char *
5389 int_rmsexpand
5390    (const char *filespec,
5391     char *outbuf,
5392     const char *defspec,
5393     unsigned opts,
5394     int * fs_utf8,
5395     int * dfs_utf8)
5396 {
5397   char * ret_spec;
5398   const char * in_spec;
5399   char * spec_buf;
5400   const char * def_spec;
5401   char * vmsfspec, *vmsdefspec;
5402   char * esa;
5403   char * esal = NULL;
5404   char * outbufl;
5405   struct FAB myfab = cc$rms_fab;
5406   rms_setup_nam(mynam);
5407   STRLEN speclen;
5408   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5409   int sts;
5410
5411   /* temp hack until UTF8 is actually implemented */
5412   if (fs_utf8 != NULL)
5413     *fs_utf8 = 0;
5414
5415   if (!filespec || !*filespec) {
5416     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5417     return NULL;
5418   }
5419
5420   vmsfspec = NULL;
5421   vmsdefspec = NULL;
5422   outbufl = NULL;
5423
5424   in_spec = filespec;
5425   isunix = 0;
5426   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5427       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5428       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5429
5430       /* If this is a UNIX file spec, convert it to VMS */
5431       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5432                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5433                            &e_len, &vs_spec, &vs_len);
5434       if (sts != 0) {
5435           isunix = 1;
5436           char * ret_spec;
5437
5438           vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5439           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5440           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5441           if (ret_spec == NULL) {
5442               PerlMem_free(vmsfspec);
5443               return NULL;
5444           }
5445           in_spec = (const char *)vmsfspec;
5446
5447           /* Unless we are forcing to VMS format, a UNIX input means
5448            * UNIX output, and that requires long names to be used
5449            */
5450           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5451 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5452               opts |= PERL_RMSEXPAND_M_LONG;
5453 #else
5454               NOOP;
5455 #endif
5456           else
5457               isunix = 0;
5458       }
5459
5460   }
5461
5462   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5463   rms_bind_fab_nam(myfab, mynam);
5464
5465   /* Process the default file specification if present */
5466   def_spec = defspec;
5467   if (defspec && *defspec) {
5468     int t_isunix;
5469     t_isunix = is_unix_filespec(defspec);
5470     if (t_isunix) {
5471       vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5472       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5473       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5474
5475       if (ret_spec == NULL) {
5476           /* Clean up and bail */
5477           PerlMem_free(vmsdefspec);
5478           if (vmsfspec != NULL)
5479               PerlMem_free(vmsfspec);
5480               return NULL;
5481           }
5482           def_spec = (const char *)vmsdefspec;
5483       }
5484       rms_set_dna(myfab, mynam,
5485                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5486   }
5487
5488   /* Now we need the expansion buffers */
5489   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
5490   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5491 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5492   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
5493   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5494 #endif
5495   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5496
5497   /* If a NAML block is used RMS always writes to the long and short
5498    * addresses unless you suppress the short name.
5499    */
5500 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5501   outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
5502   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5503 #endif
5504    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5505
5506 #ifdef NAM$M_NO_SHORT_UPCASE
5507   if (decc_efs_case_preserve)
5508     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5509 #endif
5510
5511    /* We may not want to follow symbolic links */
5512 #ifdef NAML$M_OPEN_SPECIAL
5513   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5514     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5515 #endif
5516
5517   /* First attempt to parse as an existing file */
5518   retsts = sys$parse(&myfab,0,0);
5519   if (!(retsts & STS$K_SUCCESS)) {
5520
5521     /* Could not find the file, try as syntax only if error is not fatal */
5522     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5523     if (retsts == RMS$_DNF ||
5524         retsts == RMS$_DIR ||
5525         retsts == RMS$_DEV ||
5526         retsts == RMS$_PRV) {
5527       retsts = sys$parse(&myfab,0,0);
5528       if (retsts & STS$K_SUCCESS) goto int_expanded;
5529     }
5530
5531      /* Still could not parse the file specification */
5532     /*----------------------------------------------*/
5533     sts = rms_free_search_context(&myfab); /* Free search context */
5534     if (vmsdefspec != NULL)
5535         PerlMem_free(vmsdefspec);
5536     if (vmsfspec != NULL)
5537         PerlMem_free(vmsfspec);
5538     if (outbufl != NULL)
5539         PerlMem_free(outbufl);
5540     PerlMem_free(esa);
5541     if (esal != NULL)
5542         PerlMem_free(esal);
5543     set_vaxc_errno(retsts);
5544     if      (retsts == RMS$_PRV) set_errno(EACCES);
5545     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5546     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5547     else                         set_errno(EVMSERR);
5548     return NULL;
5549   }
5550   retsts = sys$search(&myfab,0,0);
5551   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5552     sts = rms_free_search_context(&myfab); /* Free search context */
5553     if (vmsdefspec != NULL)
5554         PerlMem_free(vmsdefspec);
5555     if (vmsfspec != NULL)
5556         PerlMem_free(vmsfspec);
5557     if (outbufl != NULL)
5558         PerlMem_free(outbufl);
5559     PerlMem_free(esa);
5560     if (esal != NULL)
5561         PerlMem_free(esal);
5562     set_vaxc_errno(retsts);
5563     if      (retsts == RMS$_PRV) set_errno(EACCES);
5564     else                         set_errno(EVMSERR);
5565     return NULL;
5566   }
5567
5568   /* If the input filespec contained any lowercase characters,
5569    * downcase the result for compatibility with Unix-minded code. */
5570 int_expanded:
5571   if (!decc_efs_case_preserve) {
5572     char * tbuf;
5573     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5574       if (islower(*tbuf)) { haslower = 1; break; }
5575   }
5576
5577    /* Is a long or a short name expected */
5578   /*------------------------------------*/
5579   spec_buf = NULL;
5580 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5581   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5582     if (rms_nam_rsll(mynam)) {
5583         spec_buf = outbufl;
5584         speclen = rms_nam_rsll(mynam);
5585     }
5586     else {
5587         spec_buf = esal; /* Not esa */
5588         speclen = rms_nam_esll(mynam);
5589     }
5590   }
5591   else {
5592 #endif
5593     if (rms_nam_rsl(mynam)) {
5594         spec_buf = outbuf;
5595         speclen = rms_nam_rsl(mynam);
5596     }
5597     else {
5598         spec_buf = esa; /* Not esal */
5599         speclen = rms_nam_esl(mynam);
5600     }
5601 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5602   }
5603 #endif
5604   spec_buf[speclen] = '\0';
5605
5606   /* Trim off null fields added by $PARSE
5607    * If type > 1 char, must have been specified in original or default spec
5608    * (not true for version; $SEARCH may have added version of existing file).
5609    */
5610   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5611   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5612     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5613              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5614   }
5615   else {
5616     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5617              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5618   }
5619   if (trimver || trimtype) {
5620     if (defspec && *defspec) {
5621       char *defesal = NULL;
5622       char *defesa = NULL;
5623       defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5624       if (defesa != NULL) {
5625         struct FAB deffab = cc$rms_fab;
5626 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5627         defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5628         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5629 #endif
5630         rms_setup_nam(defnam);
5631
5632         rms_bind_fab_nam(deffab, defnam);
5633
5634         /* Cast ok */
5635         rms_set_fna
5636             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5637
5638         /* RMS needs the esa/esal as a work area if wildcards are involved */
5639         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5640
5641         rms_clear_nam_nop(defnam);
5642         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5643 #ifdef NAM$M_NO_SHORT_UPCASE
5644         if (decc_efs_case_preserve)
5645           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5646 #endif
5647 #ifdef NAML$M_OPEN_SPECIAL
5648         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5649           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5650 #endif
5651         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5652           if (trimver) {
5653              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5654           }
5655           if (trimtype) {
5656             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5657           }
5658         }
5659         if (defesal != NULL)
5660             PerlMem_free(defesal);
5661         PerlMem_free(defesa);
5662       } else {
5663           _ckvmssts_noperl(SS$_INSFMEM);
5664       }
5665     }
5666     if (trimver) {
5667       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5668         if (*(rms_nam_verl(mynam)) != '\"')
5669           speclen = rms_nam_verl(mynam) - spec_buf;
5670       }
5671       else {
5672         if (*(rms_nam_ver(mynam)) != '\"')
5673           speclen = rms_nam_ver(mynam) - spec_buf;
5674       }
5675     }
5676     if (trimtype) {
5677       /* If we didn't already trim version, copy down */
5678       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5679         if (speclen > rms_nam_verl(mynam) - spec_buf)
5680           memmove
5681            (rms_nam_typel(mynam),
5682             rms_nam_verl(mynam),
5683             speclen - (rms_nam_verl(mynam) - spec_buf));
5684           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5685       }
5686       else {
5687         if (speclen > rms_nam_ver(mynam) - spec_buf)
5688           memmove
5689            (rms_nam_type(mynam),
5690             rms_nam_ver(mynam),
5691             speclen - (rms_nam_ver(mynam) - spec_buf));
5692           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5693       }
5694     }
5695   }
5696
5697    /* Done with these copies of the input files */
5698   /*-------------------------------------------*/
5699   if (vmsfspec != NULL)
5700         PerlMem_free(vmsfspec);
5701   if (vmsdefspec != NULL)
5702         PerlMem_free(vmsdefspec);
5703
5704   /* If we just had a directory spec on input, $PARSE "helpfully"
5705    * adds an empty name and type for us */
5706 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5707   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5708     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5709         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5710         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5711       speclen = rms_nam_namel(mynam) - spec_buf;
5712   }
5713   else
5714 #endif
5715   {
5716     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5717         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5718         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5719       speclen = rms_nam_name(mynam) - spec_buf;
5720   }
5721
5722   /* Posix format specifications must have matching quotes */
5723   if (speclen < (VMS_MAXRSS - 1)) {
5724     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5725       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5726         spec_buf[speclen] = '\"';
5727         speclen++;
5728       }
5729     }
5730   }
5731   spec_buf[speclen] = '\0';
5732   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5733
5734   /* Have we been working with an expanded, but not resultant, spec? */
5735   /* Also, convert back to Unix syntax if necessary. */
5736   {
5737   int rsl;
5738
5739 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5740     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5741       rsl = rms_nam_rsll(mynam);
5742     } else
5743 #endif
5744     {
5745       rsl = rms_nam_rsl(mynam);
5746     }
5747     if (!rsl) {
5748       /* rsl is not present, it means that spec_buf is either */
5749       /* esa or esal, and needs to be copied to outbuf */
5750       /* convert to Unix if desired */
5751       if (isunix) {
5752         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5753       } else {
5754         /* VMS file specs are not in UTF-8 */
5755         if (fs_utf8 != NULL)
5756             *fs_utf8 = 0;
5757         my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5758         ret_spec = outbuf;
5759       }
5760     }
5761     else {
5762       /* Now spec_buf is either outbuf or outbufl */
5763       /* We need the result into outbuf */
5764       if (isunix) {
5765            /* If we need this in UNIX, then we need another buffer */
5766            /* to keep things in order */
5767            char * src;
5768            char * new_src = NULL;
5769            if (spec_buf == outbuf) {
5770                new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
5771                my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5772            } else {
5773                src = spec_buf;
5774            }
5775            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5776            if (new_src) {
5777                PerlMem_free(new_src);
5778            }
5779       } else {
5780            /* VMS file specs are not in UTF-8 */
5781            if (fs_utf8 != NULL)
5782                *fs_utf8 = 0;
5783
5784            /* Copy the buffer if needed */
5785            if (outbuf != spec_buf)
5786                my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5787            ret_spec = outbuf;
5788       }
5789     }
5790   }
5791
5792   /* Need to clean up the search context */
5793   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5794   sts = rms_free_search_context(&myfab); /* Free search context */
5795
5796   /* Clean up the extra buffers */
5797   if (esal != NULL)
5798       PerlMem_free(esal);
5799   PerlMem_free(esa);
5800   if (outbufl != NULL)
5801      PerlMem_free(outbufl);
5802
5803   /* Return the result */
5804   return ret_spec;
5805 }
5806
5807 /* Common simple case - Expand an already VMS spec */
5808 static char *
5809 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5810     opts |= PERL_RMSEXPAND_M_VMS_IN;
5811     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5812 }
5813
5814 /* Common simple case - Expand to a VMS spec */
5815 static char *
5816 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5817     opts |= PERL_RMSEXPAND_M_VMS;
5818     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5819 }
5820
5821
5822 /* Entry point used by perl routines */
5823 static char *
5824 mp_do_rmsexpand
5825    (pTHX_ const char *filespec,
5826     char *outbuf,
5827     int ts,
5828     const char *defspec,
5829     unsigned opts,
5830     int * fs_utf8,
5831     int * dfs_utf8)
5832 {
5833     static char __rmsexpand_retbuf[VMS_MAXRSS];
5834     char * expanded, *ret_spec, *ret_buf;
5835
5836     expanded = NULL;
5837     ret_buf = outbuf;
5838     if (ret_buf == NULL) {
5839         if (ts) {
5840             Newx(expanded, VMS_MAXRSS, char);
5841             if (expanded == NULL)
5842                 _ckvmssts(SS$_INSFMEM);
5843             ret_buf = expanded;
5844         } else {
5845             ret_buf = __rmsexpand_retbuf;
5846         }
5847     }
5848
5849
5850     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5851                              opts, fs_utf8,  dfs_utf8);
5852
5853     if (ret_spec == NULL) {
5854        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5855        if (expanded)
5856            Safefree(expanded);
5857     }
5858
5859     return ret_spec;
5860 }
5861 /*}}}*/
5862 /* External entry points */
5863 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5864 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5865 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5866 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5867 char *Perl_rmsexpand_utf8
5868   (pTHX_ const char *spec, char *buf, const char *def,
5869    unsigned opt, int * fs_utf8, int * dfs_utf8)
5870 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5871 char *Perl_rmsexpand_utf8_ts
5872   (pTHX_ const char *spec, char *buf, const char *def,
5873    unsigned opt, int * fs_utf8, int * dfs_utf8)
5874 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5875
5876
5877 /*
5878 ** The following routines are provided to make life easier when
5879 ** converting among VMS-style and Unix-style directory specifications.
5880 ** All will take input specifications in either VMS or Unix syntax. On
5881 ** failure, all return NULL.  If successful, the routines listed below
5882 ** return a pointer to a buffer containing the appropriately
5883 ** reformatted spec (and, therefore, subsequent calls to that routine
5884 ** will clobber the result), while the routines of the same names with
5885 ** a _ts suffix appended will return a pointer to a mallocd string
5886 ** containing the appropriately reformatted spec.
5887 ** In all cases, only explicit syntax is altered; no check is made that
5888 ** the resulting string is valid or that the directory in question
5889 ** actually exists.
5890 **
5891 **   fileify_dirspec() - convert a directory spec into the name of the
5892 **     directory file (i.e. what you can stat() to see if it's a dir).
5893 **     The style (VMS or Unix) of the result is the same as the style
5894 **     of the parameter passed in.
5895 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5896 **     what you prepend to a filename to indicate what directory it's in).
5897 **     The style (VMS or Unix) of the result is the same as the style
5898 **     of the parameter passed in.
5899 **   tounixpath() - convert a directory spec into a Unix-style path.
5900 **   tovmspath() - convert a directory spec into a VMS-style path.
5901 **   tounixspec() - convert any file spec into a Unix-style file spec.
5902 **   tovmsspec() - convert any file spec into a VMS-style spec.
5903 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5904 **
5905 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5906 ** Permission is given to distribute this code as part of the Perl
5907 ** standard distribution under the terms of the GNU General Public
5908 ** License or the Perl Artistic License.  Copies of each may be
5909 ** found in the Perl standard distribution.
5910  */
5911
5912 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5913 static char *
5914 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5915 {
5916     unsigned long int dirlen, retlen, hasfilename = 0;
5917     char *cp1, *cp2, *lastdir;
5918     char *trndir, *vmsdir;
5919     unsigned short int trnlnm_iter_count;
5920     int sts;
5921     if (utf8_fl != NULL)
5922         *utf8_fl = 0;
5923
5924     if (!dir || !*dir) {
5925       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5926     }
5927     dirlen = strlen(dir);
5928     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5929     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5930       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5931         dir = "/sys$disk";
5932         dirlen = 9;
5933       }
5934       else
5935         dirlen = 1;
5936     }
5937     if (dirlen > (VMS_MAXRSS - 1)) {
5938       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5939       return NULL;
5940     }
5941     trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5942     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5943     if (!strpbrk(dir+1,"/]>:")  &&
5944         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5945       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5946       trnlnm_iter_count = 0;
5947       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
5948         trnlnm_iter_count++;
5949         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5950       }
5951       dirlen = strlen(trndir);
5952     }
5953     else {
5954       memcpy(trndir, dir, dirlen);
5955       trndir[dirlen] = '\0';
5956     }
5957
5958     /* At this point we are done with *dir and use *trndir which is a
5959      * copy that can be modified.  *dir must not be modified.
5960      */
5961
5962     /* If we were handed a rooted logical name or spec, treat it like a
5963      * simple directory, so that
5964      *    $ Define myroot dev:[dir.]
5965      *    ... do_fileify_dirspec("myroot",buf,1) ...
5966      * does something useful.
5967      */
5968     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5969       trndir[--dirlen] = '\0';
5970       trndir[dirlen-1] = ']';
5971     }
5972     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5973       trndir[--dirlen] = '\0';
5974       trndir[dirlen-1] = '>';
5975     }
5976
5977     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5978       /* If we've got an explicit filename, we can just shuffle the string. */
5979       if (*(cp1+1)) hasfilename = 1;
5980       /* Similarly, we can just back up a level if we've got multiple levels
5981          of explicit directories in a VMS spec which ends with directories. */
5982       else {
5983         for (cp2 = cp1; cp2 > trndir; cp2--) {
5984           if (*cp2 == '.') {
5985             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5986 /* fix-me, can not scan EFS file specs backward like this */
5987               *cp2 = *cp1; *cp1 = '\0';
5988               hasfilename = 1;
5989               break;
5990             }
5991           }
5992           if (*cp2 == '[' || *cp2 == '<') break;
5993         }
5994       }
5995     }
5996
5997     vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5998     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5999     cp1 = strpbrk(trndir,"]:>");
6000     if (hasfilename || !cp1) { /* filename present or not VMS */
6001
6002       if (trndir[0] == '.') {
6003         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6004           PerlMem_free(trndir);
6005           PerlMem_free(vmsdir);
6006           return int_fileify_dirspec("[]", buf, NULL);
6007         }
6008         else if (trndir[1] == '.' &&
6009                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6010           PerlMem_free(trndir);
6011           PerlMem_free(vmsdir);
6012           return int_fileify_dirspec("[-]", buf, NULL);
6013         }
6014       }
6015       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6016         dirlen -= 1;                 /* to last element */
6017         lastdir = strrchr(trndir,'/');
6018       }
6019       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6020         /* If we have "/." or "/..", VMSify it and let the VMS code
6021          * below expand it, rather than repeating the code to handle
6022          * relative components of a filespec here */
6023         do {
6024           if (*(cp1+2) == '.') cp1++;
6025           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6026             char * ret_chr;
6027             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6028                 PerlMem_free(trndir);
6029                 PerlMem_free(vmsdir);
6030                 return NULL;
6031             }
6032             if (strchr(vmsdir,'/') != NULL) {
6033               /* If int_tovmsspec() returned it, it must have VMS syntax
6034                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6035                * the time to check this here only so we avoid a recursion
6036                * loop; otherwise, gigo.
6037                */
6038               PerlMem_free(trndir);
6039               PerlMem_free(vmsdir);
6040               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6041               return NULL;
6042             }
6043             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6044                 PerlMem_free(trndir);
6045                 PerlMem_free(vmsdir);
6046                 return NULL;
6047             }
6048             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6049             PerlMem_free(trndir);
6050             PerlMem_free(vmsdir);
6051             return ret_chr;
6052           }
6053           cp1++;
6054         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6055         lastdir = strrchr(trndir,'/');
6056       }
6057       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6058         char * ret_chr;
6059         /* Ditto for specs that end in an MFD -- let the VMS code
6060          * figure out whether it's a real device or a rooted logical. */
6061
6062         /* This should not happen any more.  Allowing the fake /000000
6063          * in a UNIX pathname causes all sorts of problems when trying
6064          * to run in UNIX emulation.  So the VMS to UNIX conversions
6065          * now remove the fake /000000 directories.
6066          */
6067
6068         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6069         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6070             PerlMem_free(trndir);
6071             PerlMem_free(vmsdir);
6072             return NULL;
6073         }
6074         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6075             PerlMem_free(trndir);
6076             PerlMem_free(vmsdir);
6077             return NULL;
6078         }
6079         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6080         PerlMem_free(trndir);
6081         PerlMem_free(vmsdir);
6082         return ret_chr;
6083       }
6084       else {
6085
6086         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6087              !(lastdir = cp1 = strrchr(trndir,']')) &&
6088              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6089
6090         cp2 = strrchr(cp1,'.');
6091         if (cp2) {
6092             int e_len, vs_len = 0;
6093             int is_dir = 0;
6094             char * cp3;
6095             cp3 = strchr(cp2,';');
6096             e_len = strlen(cp2);
6097             if (cp3) {
6098                 vs_len = strlen(cp3);
6099                 e_len = e_len - vs_len;
6100             }
6101             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6102             if (!is_dir) {
6103                 if (!decc_efs_charset) {
6104                     /* If this is not EFS, then not a directory */
6105                     PerlMem_free(trndir);
6106                     PerlMem_free(vmsdir);
6107                     set_errno(ENOTDIR);
6108                     set_vaxc_errno(RMS$_DIR);
6109                     return NULL;
6110                 }
6111             } else {
6112                 /* Ok, here we have an issue, technically if a .dir shows */
6113                 /* from inside a directory, then we should treat it as */
6114                 /* xxx^.dir.dir.  But we do not have that context at this */
6115                 /* point unless this is totally restructured, so we remove */
6116                 /* The .dir for now, and fix this better later */
6117                 dirlen = cp2 - trndir;
6118             }
6119             if (decc_efs_charset && !strchr(trndir,'/')) {
6120                 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6121                 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6122
6123                 for (; cp4 > cp1; cp4--) {
6124                     if (*cp4 == '.') {
6125                         if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6126                             memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6127                             *cp4 = '^';
6128                             dirlen++;
6129                         }
6130                     }
6131                 }
6132             }
6133         }
6134
6135       }
6136
6137       retlen = dirlen + 6;
6138       memcpy(buf, trndir, dirlen);
6139       buf[dirlen] = '\0';
6140
6141       /* We've picked up everything up to the directory file name.
6142          Now just add the type and version, and we're set. */
6143       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6144           strcat(buf,".dir;1");
6145       else
6146           strcat(buf,".DIR;1");
6147       PerlMem_free(trndir);
6148       PerlMem_free(vmsdir);
6149       return buf;
6150     }
6151     else {  /* VMS-style directory spec */
6152
6153       char *esa, *esal, term, *cp;
6154       char *my_esa;
6155       int my_esa_len;
6156       unsigned long int cmplen, haslower = 0;
6157       struct FAB dirfab = cc$rms_fab;
6158       rms_setup_nam(savnam);
6159       rms_setup_nam(dirnam);
6160
6161       esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
6162       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6163       esal = NULL;
6164 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6165       esal = (char *)PerlMem_malloc(VMS_MAXRSS);
6166       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6167 #endif
6168       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6169       rms_bind_fab_nam(dirfab, dirnam);
6170       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6171       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6172 #ifdef NAM$M_NO_SHORT_UPCASE
6173       if (decc_efs_case_preserve)
6174         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6175 #endif
6176
6177       for (cp = trndir; *cp; cp++)
6178         if (islower(*cp)) { haslower = 1; break; }
6179       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6180         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6181             (dirfab.fab$l_sts == RMS$_DNF) ||
6182             (dirfab.fab$l_sts == RMS$_PRV)) {
6183             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6184             sts = sys$parse(&dirfab);
6185         }
6186         if (!sts) {
6187           PerlMem_free(esa);
6188           if (esal != NULL)
6189               PerlMem_free(esal);
6190           PerlMem_free(trndir);
6191           PerlMem_free(vmsdir);
6192           set_errno(EVMSERR);
6193           set_vaxc_errno(dirfab.fab$l_sts);
6194           return NULL;
6195         }
6196       }
6197       else {
6198         savnam = dirnam;
6199         /* Does the file really exist? */
6200         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6201           /* Yes; fake the fnb bits so we'll check type below */
6202           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6203         }
6204         else { /* No; just work with potential name */
6205           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6206           else {
6207             int fab_sts;
6208             fab_sts = dirfab.fab$l_sts;
6209             sts = rms_free_search_context(&dirfab);
6210             PerlMem_free(esa);
6211             if (esal != NULL)
6212                 PerlMem_free(esal);
6213             PerlMem_free(trndir);
6214             PerlMem_free(vmsdir);
6215             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6216             return NULL;
6217           }
6218         }
6219       }
6220
6221       /* Make sure we are using the right buffer */
6222 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6223       if (esal != NULL) {
6224         my_esa = esal;
6225         my_esa_len = rms_nam_esll(dirnam);
6226       } else {
6227 #endif
6228         my_esa = esa;
6229         my_esa_len = rms_nam_esl(dirnam);
6230 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6231       }
6232 #endif
6233       my_esa[my_esa_len] = '\0';
6234       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6235         cp1 = strchr(my_esa,']');
6236         if (!cp1) cp1 = strchr(my_esa,'>');
6237         if (cp1) {  /* Should always be true */
6238           my_esa_len -= cp1 - my_esa - 1;
6239           memmove(my_esa, cp1 + 1, my_esa_len);
6240         }
6241       }
6242       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6243         /* Yep; check version while we're at it, if it's there. */
6244         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6245         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6246           /* Something other than .DIR[;1].  Bzzt. */
6247           sts = rms_free_search_context(&dirfab);
6248           PerlMem_free(esa);
6249           if (esal != NULL)
6250              PerlMem_free(esal);
6251           PerlMem_free(trndir);
6252           PerlMem_free(vmsdir);
6253           set_errno(ENOTDIR);
6254           set_vaxc_errno(RMS$_DIR);
6255           return NULL;
6256         }
6257       }
6258
6259       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6260         /* They provided at least the name; we added the type, if necessary, */
6261         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6262         sts = rms_free_search_context(&dirfab);
6263         PerlMem_free(trndir);
6264         PerlMem_free(esa);
6265         if (esal != NULL)
6266             PerlMem_free(esal);
6267         PerlMem_free(vmsdir);
6268         return buf;
6269       }
6270       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6271         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6272         *cp1 = '\0';
6273         my_esa_len -= 9;
6274       }
6275       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6276       if (cp1 == NULL) { /* should never happen */
6277         sts = rms_free_search_context(&dirfab);
6278         PerlMem_free(trndir);
6279         PerlMem_free(esa);
6280         if (esal != NULL)
6281             PerlMem_free(esal);
6282         PerlMem_free(vmsdir);
6283         return NULL;
6284       }
6285       term = *cp1;
6286       *cp1 = '\0';
6287       retlen = strlen(my_esa);
6288       cp1 = strrchr(my_esa,'.');
6289       /* ODS-5 directory specifications can have extra "." in them. */
6290       /* Fix-me, can not scan EFS file specifications backwards */
6291       while (cp1 != NULL) {
6292         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6293           break;
6294         else {
6295            cp1--;
6296            while ((cp1 > my_esa) && (*cp1 != '.'))
6297              cp1--;
6298         }
6299         if (cp1 == my_esa)
6300           cp1 = NULL;
6301       }
6302
6303       if ((cp1) != NULL) {
6304         /* There's more than one directory in the path.  Just roll back. */
6305         *cp1 = term;
6306         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6307       }
6308       else {
6309         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6310           /* Go back and expand rooted logical name */
6311           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6312 #ifdef NAM$M_NO_SHORT_UPCASE
6313           if (decc_efs_case_preserve)
6314             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6315 #endif
6316           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6317             sts = rms_free_search_context(&dirfab);
6318             PerlMem_free(esa);
6319             if (esal != NULL)
6320                 PerlMem_free(esal);
6321             PerlMem_free(trndir);
6322             PerlMem_free(vmsdir);
6323             set_errno(EVMSERR);
6324             set_vaxc_errno(dirfab.fab$l_sts);
6325             return NULL;
6326           }
6327
6328           /* This changes the length of the string of course */
6329           if (esal != NULL) {
6330               my_esa_len = rms_nam_esll(dirnam);
6331           } else {
6332               my_esa_len = rms_nam_esl(dirnam);
6333           }
6334
6335           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6336           cp1 = strstr(my_esa,"][");
6337           if (!cp1) cp1 = strstr(my_esa,"]<");
6338           dirlen = cp1 - my_esa;
6339           memcpy(buf, my_esa, dirlen);
6340           if (!strncmp(cp1+2,"000000]",7)) {
6341             buf[dirlen-1] = '\0';
6342             /* fix-me Not full ODS-5, just extra dots in directories for now */
6343             cp1 = buf + dirlen - 1;
6344             while (cp1 > buf)
6345             {
6346               if (*cp1 == '[')
6347                 break;
6348               if (*cp1 == '.') {
6349                 if (*(cp1-1) != '^')
6350                   break;
6351               }
6352               cp1--;
6353             }
6354             if (*cp1 == '.') *cp1 = ']';
6355             else {
6356               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6357               memmove(cp1+1,"000000]",7);
6358             }
6359           }
6360           else {
6361             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6362             buf[retlen] = '\0';
6363             /* Convert last '.' to ']' */
6364             cp1 = buf+retlen-1;
6365             while (*cp != '[') {
6366               cp1--;
6367               if (*cp1 == '.') {
6368                 /* Do not trip on extra dots in ODS-5 directories */
6369                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6370                 break;
6371               }
6372             }
6373             if (*cp1 == '.') *cp1 = ']';
6374             else {
6375               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6376               memmove(cp1+1,"000000]",7);
6377             }
6378           }
6379         }
6380         else {  /* This is a top-level dir.  Add the MFD to the path. */
6381           cp1 = my_esa;
6382           cp2 = buf;
6383           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6384           strcpy(cp2,":[000000]");
6385           cp1 += 2;
6386           strcpy(cp2+9,cp1);
6387         }
6388       }
6389       sts = rms_free_search_context(&dirfab);
6390       /* We've set up the string up through the filename.  Add the
6391          type and version, and we're done. */
6392       strcat(buf,".DIR;1");
6393
6394       /* $PARSE may have upcased filespec, so convert output to lower
6395        * case if input contained any lowercase characters. */
6396       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6397       PerlMem_free(trndir);
6398       PerlMem_free(esa);
6399       if (esal != NULL)
6400         PerlMem_free(esal);
6401       PerlMem_free(vmsdir);
6402       return buf;
6403     }
6404 }  /* end of int_fileify_dirspec() */
6405
6406
6407 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6408 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6409 {
6410     static char __fileify_retbuf[VMS_MAXRSS];
6411     char * fileified, *ret_spec, *ret_buf;
6412
6413     fileified = NULL;
6414     ret_buf = buf;
6415     if (ret_buf == NULL) {
6416         if (ts) {
6417             Newx(fileified, VMS_MAXRSS, char);
6418             if (fileified == NULL)
6419                 _ckvmssts(SS$_INSFMEM);
6420             ret_buf = fileified;
6421         } else {
6422             ret_buf = __fileify_retbuf;
6423         }
6424     }
6425
6426     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6427
6428     if (ret_spec == NULL) {
6429        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6430        if (fileified)
6431            Safefree(fileified);
6432     }
6433
6434     return ret_spec;
6435 }  /* end of do_fileify_dirspec() */
6436 /*}}}*/
6437
6438 /* External entry points */
6439 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6440 { return do_fileify_dirspec(dir,buf,0,NULL); }
6441 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6442 { return do_fileify_dirspec(dir,buf,1,NULL); }
6443 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6444 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6445 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6446 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6447
6448 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6449     char * v_spec, int v_len, char * r_spec, int r_len,
6450     char * d_spec, int d_len, char * n_spec, int n_len,
6451     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6452
6453     /* VMS specification - Try to do this the simple way */
6454     if ((v_len + r_len > 0) || (d_len > 0)) {
6455         int is_dir;
6456
6457         /* No name or extension component, already a directory */
6458         if ((n_len + e_len + vs_len) == 0) {
6459             strcpy(buf, dir);
6460             return buf;
6461         }
6462
6463         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6464         /* This results from catfile() being used instead of catdir() */
6465         /* So even though it should not work, we need to allow it */
6466
6467         /* If this is .DIR;1 then do a simple conversion */
6468         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6469         if (is_dir || (e_len == 0) && (d_len > 0)) {
6470              int len;
6471              len = v_len + r_len + d_len - 1;
6472              char dclose = d_spec[d_len - 1];
6473              memcpy(buf, dir, len);
6474              buf[len] = '.';
6475              len++;
6476              memcpy(&buf[len], n_spec, n_len);
6477              len += n_len;
6478              buf[len] = dclose;
6479              buf[len + 1] = '\0';
6480              return buf;
6481         }
6482
6483 #ifdef HAS_SYMLINK
6484         else if (d_len > 0) {
6485             /* In the olden days, a directory needed to have a .DIR */
6486             /* extension to be a valid directory, but now it could  */
6487             /* be a symbolic link */
6488             int len;
6489             len = v_len + r_len + d_len - 1;
6490             char dclose = d_spec[d_len - 1];
6491             memcpy(buf, dir, len);
6492             buf[len] = '.';
6493             len++;
6494             memcpy(&buf[len], n_spec, n_len);
6495             len += n_len;
6496             if (e_len > 0) {
6497                 if (decc_efs_charset) {
6498                     buf[len] = '^';
6499                     len++;
6500                     memcpy(&buf[len], e_spec, e_len);
6501                     len += e_len;
6502                 } else {
6503                     set_vaxc_errno(RMS$_DIR);
6504                     set_errno(ENOTDIR);
6505                     return NULL;
6506                 }
6507             }
6508             buf[len] = dclose;
6509             buf[len + 1] = '\0';
6510             return buf;
6511         }
6512 #else
6513         else {
6514             set_vaxc_errno(RMS$_DIR);
6515             set_errno(ENOTDIR);
6516             return NULL;
6517         }
6518 #endif
6519     }
6520     set_vaxc_errno(RMS$_DIR);
6521     set_errno(ENOTDIR);
6522     return NULL;
6523 }
6524
6525
6526 /* Internal routine to make sure or convert a directory to be in a */
6527 /* path specification.  No utf8 flag because it is not changed or used */
6528 static char *int_pathify_dirspec(const char *dir, char *buf)
6529 {
6530     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6531     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6532     char * exp_spec, *ret_spec;
6533     char * trndir;
6534     unsigned short int trnlnm_iter_count;
6535     STRLEN trnlen;
6536     int need_to_lower;
6537
6538     if (vms_debug_fileify) {
6539         if (dir == NULL)
6540             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6541         else
6542             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6543     }
6544
6545     /* We may need to lower case the result if we translated  */
6546     /* a logical name or got the current working directory */
6547     need_to_lower = 0;
6548
6549     if (!dir || !*dir) {
6550       set_errno(EINVAL);
6551       set_vaxc_errno(SS$_BADPARAM);
6552       return NULL;
6553     }
6554
6555     trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
6556     if (trndir == NULL)
6557         _ckvmssts_noperl(SS$_INSFMEM);
6558
6559     /* If no directory specified use the current default */
6560     if (*dir)
6561         my_strlcpy(trndir, dir, VMS_MAXRSS);
6562     else {
6563         getcwd(trndir, VMS_MAXRSS - 1);
6564         need_to_lower = 1;
6565     }
6566
6567     /* now deal with bare names that could be logical names */
6568     trnlnm_iter_count = 0;
6569     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6570            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6571         trnlnm_iter_count++;
6572         need_to_lower = 1;
6573         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6574             break;
6575         trnlen = strlen(trndir);
6576
6577         /* Trap simple rooted lnms, and return lnm:[000000] */
6578         if (!strcmp(trndir+trnlen-2,".]")) {
6579             my_strlcpy(buf, dir, VMS_MAXRSS);
6580             strcat(buf, ":[000000]");
6581             PerlMem_free(trndir);
6582
6583             if (vms_debug_fileify) {
6584                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6585             }
6586             return buf;
6587         }
6588     }
6589
6590     /* At this point we do not work with *dir, but the copy in  *trndir */
6591
6592     if (need_to_lower && !decc_efs_case_preserve) {
6593         /* Legacy mode, lower case the returned value */
6594         __mystrtolower(trndir);
6595     }
6596
6597
6598     /* Some special cases, '..', '.' */
6599     sts = 0;
6600     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6601        /* Force UNIX filespec */
6602        sts = 1;
6603
6604     } else {
6605         /* Is this Unix or VMS format? */
6606         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6607                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6608                              &e_len, &vs_spec, &vs_len);
6609         if (sts == 0) {
6610
6611             /* Just a filename? */
6612             if ((v_len + r_len + d_len) == 0) {
6613
6614                 /* Now we have a problem, this could be Unix or VMS */
6615                 /* We have to guess.  .DIR usually means VMS */
6616
6617                 /* In UNIX report mode, the .DIR extension is removed */
6618                 /* if one shows up, it is for a non-directory or a directory */
6619                 /* in EFS charset mode */
6620
6621                 /* So if we are in Unix report mode, assume that this */
6622                 /* is a relative Unix directory specification */
6623
6624                 sts = 1;
6625                 if (!decc_filename_unix_report && decc_efs_charset) {
6626                     int is_dir;
6627                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6628
6629                     if (is_dir) {
6630                         /* Traditional mode, assume .DIR is directory */
6631                         buf[0] = '[';
6632                         buf[1] = '.';
6633                         memcpy(&buf[2], n_spec, n_len);
6634                         buf[n_len + 2] = ']';
6635                         buf[n_len + 3] = '\0';
6636                         PerlMem_free(trndir);
6637                         if (vms_debug_fileify) {
6638                             fprintf(stderr,
6639                                     "int_pathify_dirspec: buf = %s\n",
6640                                     buf);
6641                         }
6642                         return buf;
6643                     }
6644                 }
6645             }
6646         }
6647     }
6648     if (sts == 0) {
6649         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6650             v_spec, v_len, r_spec, r_len,
6651             d_spec, d_len, n_spec, n_len,
6652             e_spec, e_len, vs_spec, vs_len);
6653
6654         if (ret_spec != NULL) {
6655             PerlMem_free(trndir);
6656             if (vms_debug_fileify) {
6657                 fprintf(stderr,
6658                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6659             }
6660             return ret_spec;
6661         }
6662
6663         /* Simple way did not work, which means that a logical name */
6664         /* was present for the directory specification.             */
6665         /* Need to use an rmsexpand variant to decode it completely */
6666         exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
6667         if (exp_spec == NULL)
6668             _ckvmssts_noperl(SS$_INSFMEM);
6669
6670         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6671         if (ret_spec != NULL) {
6672             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6673                                  &r_spec, &r_len, &d_spec, &d_len,
6674                                  &n_spec, &n_len, &e_spec,
6675                                  &e_len, &vs_spec, &vs_len);
6676             if (sts == 0) {
6677                 ret_spec = int_pathify_dirspec_simple(
6678                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6679                     d_spec, d_len, n_spec, n_len,
6680                     e_spec, e_len, vs_spec, vs_len);
6681
6682                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6683                     /* Legacy mode, lower case the returned value */
6684                     __mystrtolower(ret_spec);
6685                 }
6686             } else {
6687                 set_vaxc_errno(RMS$_DIR);
6688                 set_errno(ENOTDIR);
6689                 ret_spec = NULL;
6690             }
6691         }
6692         PerlMem_free(exp_spec);
6693         PerlMem_free(trndir);
6694         if (vms_debug_fileify) {
6695             if (ret_spec == NULL)
6696                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6697             else
6698                 fprintf(stderr,
6699                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6700         }
6701         return ret_spec;
6702
6703     } else {
6704         /* Unix specification, Could be trivial conversion, */
6705         /* but have to deal with trailing '.dir' or extra '.' */
6706
6707         char * lastdot;
6708         char * lastslash;
6709         int is_dir;
6710         STRLEN dir_len = strlen(trndir);
6711
6712         lastslash = strrchr(trndir, '/');
6713         if (lastslash == NULL)
6714             lastslash = trndir;
6715         else
6716             lastslash++;
6717
6718         lastdot = NULL;
6719
6720         /* '..' or '.' are valid directory components */
6721         is_dir = 0;
6722         if (lastslash[0] == '.') {
6723             if (lastslash[1] == '\0') {
6724                is_dir = 1;
6725             } else if (lastslash[1] == '.') {
6726                 if (lastslash[2] == '\0') {
6727                     is_dir = 1;
6728                 } else {
6729                     /* And finally allow '...' */
6730                     if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6731                         is_dir = 1;
6732                     }
6733                 }
6734             }
6735         }
6736
6737         if (!is_dir) {
6738            lastdot = strrchr(lastslash, '.');
6739         }
6740         if (lastdot != NULL) {
6741             STRLEN e_len;
6742              /* '.dir' is discarded, and any other '.' is invalid */
6743             e_len = strlen(lastdot);
6744
6745             is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6746
6747             if (is_dir) {
6748                 dir_len = dir_len - 4;
6749             }
6750         }
6751
6752         my_strlcpy(buf, trndir, VMS_MAXRSS);
6753         if (buf[dir_len - 1] != '/') {
6754             buf[dir_len] = '/';
6755             buf[dir_len + 1] = '\0';
6756         }
6757
6758         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6759         if (!decc_efs_charset) {
6760              int dir_start = 0;
6761              char * str = buf;
6762              if (str[0] == '.') {
6763                  char * dots = str;
6764                  int cnt = 1;
6765                  while ((dots[cnt] == '.') && (cnt < 3))
6766                      cnt++;
6767                  if (cnt <= 3) {
6768                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6769                          dir_start = 1;
6770                          str += cnt;
6771                      }
6772                  }
6773              }
6774              for (; *str; ++str) {
6775                  while (*str == '/') {
6776                      dir_start = 1;
6777                      *str++;
6778                  }
6779                  if (dir_start) {
6780
6781                      /* Have to skip up to three dots which could be */
6782                      /* directories, 3 dots being a VMS extension for Perl */
6783                      char * dots = str;
6784                      int cnt = 0;
6785                      while ((dots[cnt] == '.') && (cnt < 3)) {
6786                          cnt++;
6787                      }
6788                      if (dots[cnt] == '\0')
6789                          break;
6790                      if ((cnt > 1) && (dots[cnt] != '/')) {
6791                          dir_start = 0;
6792                      } else {
6793                          str += cnt;
6794                      }
6795
6796                      /* too many dots? */
6797                      if ((cnt == 0) || (cnt > 3)) {
6798                          dir_start = 0;
6799                      }
6800                  }
6801                  if (!dir_start && (*str == '.')) {
6802                      *str = '_';
6803                  }
6804              }
6805         }
6806         PerlMem_free(trndir);
6807         ret_spec = buf;
6808         if (vms_debug_fileify) {
6809             if (ret_spec == NULL)
6810                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6811             else
6812                 fprintf(stderr,
6813                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6814         }
6815         return ret_spec;
6816     }
6817 }
6818
6819 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6820 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6821 {
6822     static char __pathify_retbuf[VMS_MAXRSS];
6823     char * pathified, *ret_spec, *ret_buf;
6824
6825     pathified = NULL;
6826     ret_buf = buf;
6827     if (ret_buf == NULL) {
6828         if (ts) {
6829             Newx(pathified, VMS_MAXRSS, char);
6830             if (pathified == NULL)
6831                 _ckvmssts(SS$_INSFMEM);
6832             ret_buf = pathified;
6833         } else {
6834             ret_buf = __pathify_retbuf;
6835         }
6836     }
6837
6838     ret_spec = int_pathify_dirspec(dir, ret_buf);
6839
6840     if (ret_spec == NULL) {
6841        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6842        if (pathified)
6843            Safefree(pathified);
6844     }
6845
6846     return ret_spec;
6847
6848 }  /* end of do_pathify_dirspec() */
6849
6850
6851 /* External entry points */
6852 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6853 { return do_pathify_dirspec(dir,buf,0,NULL); }
6854 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6855 { return do_pathify_dirspec(dir,buf,1,NULL); }
6856 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6857 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6858 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6859 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6860
6861 /* Internal tounixspec routine that does not use a thread context */
6862 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6863 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6864 {
6865   char *dirend, *cp1, *cp3, *tmp;
6866   const char *cp2;
6867   int dirlen;
6868   unsigned short int trnlnm_iter_count;
6869   int cmp_rslt;
6870   if (utf8_fl != NULL)
6871     *utf8_fl = 0;
6872
6873   if (vms_debug_fileify) {
6874       if (spec == NULL)
6875           fprintf(stderr, "int_tounixspec: spec = NULL\n");
6876       else
6877           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6878   }
6879
6880
6881   if (spec == NULL) {
6882       set_errno(EINVAL);
6883       set_vaxc_errno(SS$_BADPARAM);
6884       return NULL;
6885   }
6886   if (strlen(spec) > (VMS_MAXRSS-1)) {
6887       set_errno(E2BIG);
6888       set_vaxc_errno(SS$_BUFFEROVF);
6889       return NULL;
6890   }
6891
6892   /* New VMS specific format needs translation
6893    * glob passes filenames with trailing '\n' and expects this preserved.
6894    */
6895   if (decc_posix_compliant_pathnames) {
6896     if (strncmp(spec, "\"^UP^", 5) == 0) {
6897       char * uspec;
6898       char *tunix;
6899       int tunix_len;
6900       int nl_flag;
6901
6902       tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
6903       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6904       tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
6905       nl_flag = 0;
6906       if (tunix[tunix_len - 1] == '\n') {
6907         tunix[tunix_len - 1] = '\"';
6908         tunix[tunix_len] = '\0';
6909         tunix_len--;
6910         nl_flag = 1;
6911       }
6912       uspec = decc$translate_vms(tunix);
6913       PerlMem_free(tunix);
6914       if ((int)uspec > 0) {
6915         my_strlcpy(rslt, uspec, VMS_MAXRSS);
6916         if (nl_flag) {
6917           strcat(rslt,"\n");
6918         }
6919         else {
6920           /* If we can not translate it, makemaker wants as-is */
6921           my_strlcpy(rslt, spec, VMS_MAXRSS);
6922         }
6923         return rslt;
6924       }
6925     }
6926   }
6927
6928   cmp_rslt = 0; /* Presume VMS */
6929   cp1 = strchr(spec, '/');
6930   if (cp1 == NULL)
6931     cmp_rslt = 0;
6932
6933     /* Look for EFS ^/ */
6934     if (decc_efs_charset) {
6935       while (cp1 != NULL) {
6936         cp2 = cp1 - 1;
6937         if (*cp2 != '^') {
6938           /* Found illegal VMS, assume UNIX */
6939           cmp_rslt = 1;
6940           break;
6941         }
6942       cp1++;
6943       cp1 = strchr(cp1, '/');
6944     }
6945   }
6946
6947   /* Look for "." and ".." */
6948   if (decc_filename_unix_report) {
6949     if (spec[0] == '.') {
6950       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6951         cmp_rslt = 1;
6952       }
6953       else {
6954         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6955           cmp_rslt = 1;
6956         }
6957       }
6958     }
6959   }
6960   /* This is already UNIX or at least nothing VMS understands */
6961   if (cmp_rslt) {
6962     my_strlcpy(rslt, spec, VMS_MAXRSS);
6963     if (vms_debug_fileify) {
6964         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6965     }
6966     return rslt;
6967   }
6968
6969   cp1 = rslt;
6970   cp2 = spec;
6971   dirend = strrchr(spec,']');
6972   if (dirend == NULL) dirend = strrchr(spec,'>');
6973   if (dirend == NULL) dirend = strchr(spec,':');
6974   if (dirend == NULL) {
6975     strcpy(rslt,spec);
6976     if (vms_debug_fileify) {
6977         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6978     }
6979     return rslt;
6980   }
6981
6982   /* Special case 1 - sys$posix_root = / */
6983   if (!decc_disable_posix_root) {
6984     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6985       *cp1 = '/';
6986       cp1++;
6987       cp2 = cp2 + 15;
6988       }
6989   }
6990
6991   /* Special case 2 - Convert NLA0: to /dev/null */
6992   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6993   if (cmp_rslt == 0) {
6994     strcpy(rslt, "/dev/null");
6995     cp1 = cp1 + 9;
6996     cp2 = cp2 + 5;
6997     if (spec[6] != '\0') {
6998       cp1[9] = '/';
6999       cp1++;
7000       cp2++;
7001     }
7002   }
7003
7004    /* Also handle special case "SYS$SCRATCH:" */
7005   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7006   tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
7007   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7008   if (cmp_rslt == 0) {
7009   int islnm;
7010
7011     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7012     if (!islnm) {
7013       strcpy(rslt, "/tmp");
7014       cp1 = cp1 + 4;
7015       cp2 = cp2 + 12;
7016       if (spec[12] != '\0') {
7017         cp1[4] = '/';
7018         cp1++;
7019         cp2++;
7020       }
7021     }
7022   }
7023
7024   if (*cp2 != '[' && *cp2 != '<') {
7025     *(cp1++) = '/';
7026   }
7027   else {  /* the VMS spec begins with directories */
7028     cp2++;
7029     if (*cp2 == ']' || *cp2 == '>') {
7030       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7031       PerlMem_free(tmp);
7032       return rslt;
7033     }
7034     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7035       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7036         PerlMem_free(tmp);
7037         if (vms_debug_fileify) {
7038             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7039         }
7040         return NULL;
7041       }
7042       trnlnm_iter_count = 0;
7043       do {
7044         cp3 = tmp;
7045         while (*cp3 != ':' && *cp3) cp3++;
7046         *(cp3++) = '\0';
7047         if (strchr(cp3,']') != NULL) break;
7048         trnlnm_iter_count++;
7049         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7050       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7051       cp1 = rslt;
7052       cp3 = tmp;
7053       *(cp1++) = '/';
7054       while (*cp3) {
7055         *(cp1++) = *(cp3++);
7056         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7057             PerlMem_free(tmp);
7058             set_errno(ENAMETOOLONG);
7059             set_vaxc_errno(SS$_BUFFEROVF);
7060             if (vms_debug_fileify) {
7061                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7062             }
7063             return NULL; /* No room */
7064         }
7065       }
7066       *(cp1++) = '/';
7067     }
7068     if ((*cp2 == '^')) {
7069         /* EFS file escape, pass the next character as is */
7070         /* Fix me: HEX encoding for Unicode not implemented */
7071         cp2++;
7072     }
7073     else if ( *cp2 == '.') {
7074       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7075         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7076         cp2 += 3;
7077       }
7078       else cp2++;
7079     }
7080   }
7081   PerlMem_free(tmp);
7082   for (; cp2 <= dirend; cp2++) {
7083     if ((*cp2 == '^')) {
7084         /* EFS file escape, pass the next character as is */
7085         /* Fix me: HEX encoding for Unicode not implemented */
7086         *(cp1++) = *(++cp2);
7087         /* An escaped dot stays as is -- don't convert to slash */
7088         if (*cp2 == '.') cp2++;
7089     }
7090     if (*cp2 == ':') {
7091       *(cp1++) = '/';
7092       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7093     }
7094     else if (*cp2 == ']' || *cp2 == '>') {
7095       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7096     }
7097     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7098       *(cp1++) = '/';
7099       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7100         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7101                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7102         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7103             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7104       }
7105       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7106         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7107         cp2 += 2;
7108       }
7109     }
7110     else if (*cp2 == '-') {
7111       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7112         while (*cp2 == '-') {
7113           cp2++;
7114           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7115         }
7116         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7117                                                          /* filespecs like */
7118           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7119           if (vms_debug_fileify) {
7120               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7121           }
7122           return NULL;
7123         }
7124       }
7125       else *(cp1++) = *cp2;
7126     }
7127     else *(cp1++) = *cp2;
7128   }
7129   /* Translate the rest of the filename. */
7130   while (*cp2) {
7131       int dot_seen;
7132       dot_seen = 0;
7133       switch(*cp2) {
7134       /* Fixme - for compatibility with the CRTL we should be removing */
7135       /* spaces from the file specifications, but this may show that */
7136       /* some tests that were appearing to pass are not really passing */
7137       case '%':
7138           cp2++;
7139           *(cp1++) = '?';
7140           break;
7141       case '^':
7142           /* Fix me hex expansions not implemented */
7143           cp2++;  /* '^.' --> '.' and other. */
7144           if (*cp2) {
7145               if (*cp2 == '_') {
7146                   cp2++;
7147                   *(cp1++) = ' ';
7148               } else {
7149                   *(cp1++) = *(cp2++);
7150               }
7151           }
7152           break;
7153       case ';':
7154           if (decc_filename_unix_no_version) {
7155               /* Easy, drop the version */
7156               while (*cp2)
7157                   cp2++;
7158               break;
7159           } else {
7160               /* Punt - passing the version as a dot will probably */
7161               /* break perl in weird ways, but so did passing */
7162               /* through the ; as a version.  Follow the CRTL and */
7163               /* hope for the best. */
7164               cp2++;
7165               *(cp1++) = '.';
7166           }
7167           break;
7168       case '.':
7169           if (dot_seen) {
7170               /* We will need to fix this properly later */
7171               /* As Perl may be installed on an ODS-5 volume, but not */
7172               /* have the EFS_CHARSET enabled, it still may encounter */
7173               /* filenames with extra dots in them, and a precedent got */
7174               /* set which allowed them to work, that we will uphold here */
7175               /* If extra dots are present in a name and no ^ is on them */
7176               /* VMS assumes that the first one is the extension delimiter */
7177               /* the rest have an implied ^. */
7178
7179               /* this is also a conflict as the . is also a version */
7180               /* delimiter in VMS, */
7181
7182               *(cp1++) = *(cp2++);
7183               break;
7184           }
7185           dot_seen = 1;
7186           /* This is an extension */
7187           if (decc_readdir_dropdotnotype) {
7188               cp2++;
7189               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7190                   /* Drop the dot for the extension */
7191                   break;
7192               } else {
7193                   *(cp1++) = '.';
7194               }
7195               break;
7196           }
7197       default:
7198           *(cp1++) = *(cp2++);
7199       }
7200   }
7201   *cp1 = '\0';
7202
7203   /* This still leaves /000000/ when working with a
7204    * VMS device root or concealed root.
7205    */
7206   {
7207   int ulen;
7208   char * zeros;
7209
7210       ulen = strlen(rslt);
7211
7212       /* Get rid of "000000/ in rooted filespecs */
7213       if (ulen > 7) {
7214         zeros = strstr(rslt, "/000000/");
7215         if (zeros != NULL) {
7216           int mlen;
7217           mlen = ulen - (zeros - rslt) - 7;
7218           memmove(zeros, &zeros[7], mlen);
7219           ulen = ulen - 7;
7220           rslt[ulen] = '\0';
7221         }
7222       }
7223   }
7224
7225   if (vms_debug_fileify) {
7226       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7227   }
7228   return rslt;
7229
7230 }  /* end of int_tounixspec() */
7231
7232
7233 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7234 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7235 {
7236     static char __tounixspec_retbuf[VMS_MAXRSS];
7237     char * unixspec, *ret_spec, *ret_buf;
7238
7239     unixspec = NULL;
7240     ret_buf = buf;
7241     if (ret_buf == NULL) {
7242         if (ts) {
7243             Newx(unixspec, VMS_MAXRSS, char);
7244             if (unixspec == NULL)
7245                 _ckvmssts(SS$_INSFMEM);
7246             ret_buf = unixspec;
7247         } else {
7248             ret_buf = __tounixspec_retbuf;
7249         }
7250     }
7251
7252     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7253
7254     if (ret_spec == NULL) {
7255        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7256        if (unixspec)
7257            Safefree(unixspec);
7258     }
7259
7260     return ret_spec;
7261
7262 }  /* end of do_tounixspec() */
7263 /*}}}*/
7264 /* External entry points */
7265 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7266   { return do_tounixspec(spec,buf,0, NULL); }
7267 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7268   { return do_tounixspec(spec,buf,1, NULL); }
7269 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7270   { return do_tounixspec(spec,buf,0, utf8_fl); }
7271 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7272   { return do_tounixspec(spec,buf,1, utf8_fl); }
7273
7274 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7275
7276 /*
7277  This procedure is used to identify if a path is based in either
7278  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7279  it returns the OpenVMS format directory for it.
7280
7281  It is expecting specifications of only '/' or '/xxxx/'
7282
7283  If a posix root does not exist, or 'xxxx' is not a directory
7284  in the posix root, it returns a failure.
7285
7286  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7287
7288  It is used only internally by posix_to_vmsspec_hardway().
7289  */
7290
7291 static int posix_root_to_vms
7292   (char *vmspath, int vmspath_len,
7293    const char *unixpath,
7294    const int * utf8_fl)
7295 {
7296 int sts;
7297 struct FAB myfab = cc$rms_fab;
7298 rms_setup_nam(mynam);
7299 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7300 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7301 char * esa, * esal, * rsa, * rsal;
7302 int dir_flag;
7303 int unixlen;
7304
7305     dir_flag = 0;
7306     vmspath[0] = '\0';
7307     unixlen = strlen(unixpath);
7308     if (unixlen == 0) {
7309       return RMS$_FNF;
7310     }
7311
7312 #if __CRTL_VER >= 80200000
7313   /* If not a posix spec already, convert it */
7314   if (decc_posix_compliant_pathnames) {
7315     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7316       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7317     }
7318     else {
7319       /* This is already a VMS specification, no conversion */
7320       unixlen--;
7321       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7322     }
7323   }
7324   else
7325 #endif
7326   {
7327   int path_len;
7328   int i,j;
7329
7330      /* Check to see if this is under the POSIX root */
7331      if (decc_disable_posix_root) {
7332         return RMS$_FNF;
7333      }
7334
7335      /* Skip leading / */
7336      if (unixpath[0] == '/') {
7337         unixpath++;
7338         unixlen--;
7339      }
7340
7341
7342      strcpy(vmspath,"SYS$POSIX_ROOT:");
7343
7344      /* If this is only the / , or blank, then... */
7345      if (unixpath[0] == '\0') {
7346         /* by definition, this is the answer */
7347         return SS$_NORMAL;
7348      }
7349
7350      /* Need to look up a directory */
7351      vmspath[15] = '[';
7352      vmspath[16] = '\0';
7353
7354      /* Copy and add '^' escape characters as needed */
7355      j = 16;
7356      i = 0;
7357      while (unixpath[i] != 0) {
7358      int k;
7359
7360         j += copy_expand_unix_filename_escape
7361             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7362         i += k;
7363      }
7364
7365      path_len = strlen(vmspath);
7366      if (vmspath[path_len - 1] == '/')
7367         path_len--;
7368      vmspath[path_len] = ']';
7369      path_len++;
7370      vmspath[path_len] = '\0';
7371
7372   }
7373   vmspath[vmspath_len] = 0;
7374   if (unixpath[unixlen - 1] == '/')
7375   dir_flag = 1;
7376   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7377   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7378   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7379   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7380   rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7381   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7382   rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7383   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7384   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7385   rms_bind_fab_nam(myfab, mynam);
7386   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7387   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7388   if (decc_efs_case_preserve)
7389     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7390 #ifdef NAML$M_OPEN_SPECIAL
7391   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7392 #endif
7393
7394   /* Set up the remaining naml fields */
7395   sts = sys$parse(&myfab);
7396
7397   /* It failed! Try again as a UNIX filespec */
7398   if (!(sts & 1)) {
7399     PerlMem_free(esal);
7400     PerlMem_free(esa);
7401     PerlMem_free(rsal);
7402     PerlMem_free(rsa);
7403     return sts;
7404   }
7405
7406    /* get the Device ID and the FID */
7407    sts = sys$search(&myfab);
7408
7409    /* These are no longer needed */
7410    PerlMem_free(esa);
7411    PerlMem_free(rsal);
7412    PerlMem_free(rsa);
7413
7414    /* on any failure, returned the POSIX ^UP^ filespec */
7415    if (!(sts & 1)) {
7416       PerlMem_free(esal);
7417       return sts;
7418    }
7419    specdsc.dsc$a_pointer = vmspath;
7420    specdsc.dsc$w_length = vmspath_len;
7421
7422    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7423    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7424    sts = lib$fid_to_name
7425       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7426
7427   /* on any failure, returned the POSIX ^UP^ filespec */
7428   if (!(sts & 1)) {
7429      /* This can happen if user does not have permission to read directories */
7430      if (strncmp(unixpath,"\"^UP^",5) != 0)
7431        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7432      else
7433        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7434   }
7435   else {
7436     vmspath[specdsc.dsc$w_length] = 0;
7437
7438     /* Are we expecting a directory? */
7439     if (dir_flag != 0) {
7440     int i;
7441     char *eptr;
7442
7443       eptr = NULL;
7444
7445       i = specdsc.dsc$w_length - 1;
7446       while (i > 0) {
7447       int zercnt;
7448         zercnt = 0;
7449         /* Version must be '1' */
7450         if (vmspath[i--] != '1')
7451           break;
7452         /* Version delimiter is one of ".;" */
7453         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7454           break;
7455         i--;
7456         if (vmspath[i--] != 'R')
7457           break;
7458         if (vmspath[i--] != 'I')
7459           break;
7460         if (vmspath[i--] != 'D')
7461           break;
7462         if (vmspath[i--] != '.')
7463           break;
7464         eptr = &vmspath[i+1];
7465         while (i > 0) {
7466           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7467             if (vmspath[i-1] != '^') {
7468               if (zercnt != 6) {
7469                 *eptr = vmspath[i];
7470                 eptr[1] = '\0';
7471                 vmspath[i] = '.';
7472                 break;
7473               }
7474               else {
7475                 /* Get rid of 6 imaginary zero directory filename */
7476                 vmspath[i+1] = '\0';
7477               }
7478             }
7479           }
7480           if (vmspath[i] == '0')
7481             zercnt++;
7482           else
7483             zercnt = 10;
7484           i--;
7485         }
7486         break;
7487       }
7488     }
7489   }
7490   PerlMem_free(esal);
7491   return sts;
7492 }
7493
7494 /* /dev/mumble needs to be handled special.
7495    /dev/null becomes NLA0:, And there is the potential for other stuff
7496    like /dev/tty which may need to be mapped to something.
7497 */
7498
7499 static int
7500 slash_dev_special_to_vms
7501    (const char * unixptr,
7502     char * vmspath,
7503     int vmspath_len)
7504 {
7505 char * nextslash;
7506 int len;
7507 int cmp;
7508
7509     unixptr += 4;
7510     nextslash = strchr(unixptr, '/');
7511     len = strlen(unixptr);
7512     if (nextslash != NULL)
7513         len = nextslash - unixptr;
7514     cmp = strncmp("null", unixptr, 5);
7515     if (cmp == 0) {
7516         if (vmspath_len >= 6) {
7517             strcpy(vmspath, "_NLA0:");
7518             return SS$_NORMAL;
7519         }
7520     }
7521     return 0;
7522 }
7523
7524
7525 /* The built in routines do not understand perl's special needs, so
7526     doing a manual conversion from UNIX to VMS
7527
7528     If the utf8_fl is not null and points to a non-zero value, then
7529     treat 8 bit characters as UTF-8.
7530
7531     The sequence starting with '$(' and ending with ')' will be passed
7532     through with out interpretation instead of being escaped.
7533
7534   */
7535 static int posix_to_vmsspec_hardway
7536   (char *vmspath, int vmspath_len,
7537    const char *unixpath,
7538    int dir_flag,
7539    int * utf8_fl) {
7540
7541 char *esa;
7542 const char *unixptr;
7543 const char *unixend;
7544 char *vmsptr;
7545 const char *lastslash;
7546 const char *lastdot;
7547 int unixlen;
7548 int vmslen;
7549 int dir_start;
7550 int dir_dot;
7551 int quoted;
7552 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7553 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7554
7555   if (utf8_fl != NULL)
7556     *utf8_fl = 0;
7557
7558   unixptr = unixpath;
7559   dir_dot = 0;
7560
7561   /* Ignore leading "/" characters */
7562   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7563     unixptr++;
7564   }
7565   unixlen = strlen(unixptr);
7566
7567   /* Do nothing with blank paths */
7568   if (unixlen == 0) {
7569     vmspath[0] = '\0';
7570     return SS$_NORMAL;
7571   }
7572
7573   quoted = 0;
7574   /* This could have a "^UP^ on the front */
7575   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7576     quoted = 1;
7577     unixptr+= 5;
7578     unixlen-= 5;
7579   }
7580
7581   lastslash = strrchr(unixptr,'/');
7582   lastdot = strrchr(unixptr,'.');
7583   unixend = strrchr(unixptr,'\"');
7584   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7585     unixend = unixptr + unixlen;
7586   }
7587
7588   /* last dot is last dot or past end of string */
7589   if (lastdot == NULL)
7590     lastdot = unixptr + unixlen;
7591
7592   /* if no directories, set last slash to beginning of string */
7593   if (lastslash == NULL) {
7594     lastslash = unixptr;
7595   }
7596   else {
7597     /* Watch out for trailing "." after last slash, still a directory */
7598     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7599       lastslash = unixptr + unixlen;
7600     }
7601
7602     /* Watch out for trailing ".." after last slash, still a directory */
7603     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7604       lastslash = unixptr + unixlen;
7605     }
7606
7607     /* dots in directories are aways escaped */
7608     if (lastdot < lastslash)
7609       lastdot = unixptr + unixlen;
7610   }
7611
7612   /* if (unixptr < lastslash) then we are in a directory */
7613
7614   dir_start = 0;
7615
7616   vmsptr = vmspath;
7617   vmslen = 0;
7618
7619   /* Start with the UNIX path */
7620   if (*unixptr != '/') {
7621     /* relative paths */
7622
7623     /* If allowing logical names on relative pathnames, then handle here */
7624     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7625         !decc_posix_compliant_pathnames) {
7626     char * nextslash;
7627     int seg_len;
7628     char * trn;
7629     int islnm;
7630
7631         /* Find the next slash */
7632         nextslash = strchr(unixptr,'/');
7633
7634         esa = (char *)PerlMem_malloc(vmspath_len);
7635         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7636
7637         trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7638         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7639
7640         if (nextslash != NULL) {
7641
7642             seg_len = nextslash - unixptr;
7643             memcpy(esa, unixptr, seg_len);
7644             esa[seg_len] = 0;
7645         }
7646         else {
7647             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7648         }
7649         /* trnlnm(section) */
7650         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7651
7652         if (islnm) {
7653             /* Now fix up the directory */
7654
7655             /* Split up the path to find the components */
7656             sts = vms_split_path
7657                   (trn,
7658                    &v_spec,
7659                    &v_len,
7660                    &r_spec,
7661                    &r_len,
7662                    &d_spec,
7663                    &d_len,
7664                    &n_spec,
7665                    &n_len,
7666                    &e_spec,
7667                    &e_len,
7668                    &vs_spec,
7669                    &vs_len);
7670
7671             while (sts == 0) {
7672             int cmp;
7673
7674                 /* A logical name must be a directory  or the full
7675                    specification.  It is only a full specification if
7676                    it is the only component */
7677                 if ((unixptr[seg_len] == '\0') ||
7678                     (unixptr[seg_len+1] == '\0')) {
7679
7680                     /* Is a directory being required? */
7681                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7682                         /* Not a logical name */
7683                         break;
7684                     }
7685
7686
7687                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7688                         /* This must be a directory */
7689                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7690                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7691                             vmsptr[vmslen] = ':';
7692                             vmslen++;
7693                             vmsptr[vmslen] = '\0';
7694                             return SS$_NORMAL;
7695                         }
7696                     }
7697
7698                 }
7699
7700
7701                 /* must be dev/directory - ignore version */
7702                 if ((n_len + e_len) != 0)
7703                     break;
7704
7705                 /* transfer the volume */
7706                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7707                     memcpy(vmsptr, v_spec, v_len);
7708                     vmsptr += v_len;
7709                     vmsptr[0] = '\0';
7710                     vmslen += v_len;
7711                 }
7712
7713                 /* unroot the rooted directory */
7714                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7715                     r_spec[0] = '[';
7716                     r_spec[r_len - 1] = ']';
7717
7718                     /* This should not be there, but nothing is perfect */
7719                     if (r_len > 9) {
7720                         cmp = strcmp(&r_spec[1], "000000.");
7721                         if (cmp == 0) {
7722                             r_spec += 7;
7723                             r_spec[7] = '[';
7724                             r_len -= 7;
7725                             if (r_len == 2)
7726                                 r_len = 0;
7727                         }
7728                     }
7729                     if (r_len > 0) {
7730                         memcpy(vmsptr, r_spec, r_len);
7731                         vmsptr += r_len;
7732                         vmslen += r_len;
7733                         vmsptr[0] = '\0';
7734                     }
7735                 }
7736                 /* Bring over the directory. */
7737                 if ((d_len > 0) &&
7738                     ((d_len + vmslen) < vmspath_len)) {
7739                     d_spec[0] = '[';
7740                     d_spec[d_len - 1] = ']';
7741                     if (d_len > 9) {
7742                         cmp = strcmp(&d_spec[1], "000000.");
7743                         if (cmp == 0) {
7744                             d_spec += 7;
7745                             d_spec[7] = '[';
7746                             d_len -= 7;
7747                             if (d_len == 2)
7748                                 d_len = 0;
7749                         }
7750                     }
7751
7752                     if (r_len > 0) {
7753                         /* Remove the redundant root */
7754                         if (r_len > 0) {
7755                             /* remove the ][ */
7756                             vmsptr--;
7757                             vmslen--;
7758                             d_spec++;
7759                             d_len--;
7760                         }
7761                         memcpy(vmsptr, d_spec, d_len);
7762                             vmsptr += d_len;
7763                             vmslen += d_len;
7764                             vmsptr[0] = '\0';
7765                     }
7766                 }
7767                 break;
7768             }
7769         }
7770
7771         PerlMem_free(esa);
7772         PerlMem_free(trn);
7773     }
7774
7775     if (lastslash > unixptr) {
7776     int dotdir_seen;
7777
7778       /* skip leading ./ */
7779       dotdir_seen = 0;
7780       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7781         dotdir_seen = 1;
7782         unixptr++;
7783         unixptr++;
7784       }
7785
7786       /* Are we still in a directory? */
7787       if (unixptr <= lastslash) {
7788         *vmsptr++ = '[';
7789         vmslen = 1;
7790         dir_start = 1;
7791
7792         /* if not backing up, then it is relative forward. */
7793         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7794               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7795           *vmsptr++ = '.';
7796           vmslen++;
7797           dir_dot = 1;
7798           }
7799        }
7800        else {
7801          if (dotdir_seen) {
7802            /* Perl wants an empty directory here to tell the difference
7803             * between a DCL command and a filename
7804             */
7805           *vmsptr++ = '[';
7806           *vmsptr++ = ']';
7807           vmslen = 2;
7808         }
7809       }
7810     }
7811     else {
7812       /* Handle two special files . and .. */
7813       if (unixptr[0] == '.') {
7814         if (&unixptr[1] == unixend) {
7815           *vmsptr++ = '[';
7816           *vmsptr++ = ']';
7817           vmslen += 2;
7818           *vmsptr++ = '\0';
7819           return SS$_NORMAL;
7820         }
7821         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7822           *vmsptr++ = '[';
7823           *vmsptr++ = '-';
7824           *vmsptr++ = ']';
7825           vmslen += 3;
7826           *vmsptr++ = '\0';
7827           return SS$_NORMAL;
7828         }
7829       }
7830     }
7831   }
7832   else {        /* Absolute PATH handling */
7833   int sts;
7834   char * nextslash;
7835   int seg_len;
7836     /* Need to find out where root is */
7837
7838     /* In theory, this procedure should never get an absolute POSIX pathname
7839      * that can not be found on the POSIX root.
7840      * In practice, that can not be relied on, and things will show up
7841      * here that are a VMS device name or concealed logical name instead.
7842      * So to make things work, this procedure must be tolerant.
7843      */
7844     esa = (char *)PerlMem_malloc(vmspath_len);
7845     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7846
7847     sts = SS$_NORMAL;
7848     nextslash = strchr(&unixptr[1],'/');
7849     seg_len = 0;
7850     if (nextslash != NULL) {
7851       int cmp;
7852       seg_len = nextslash - &unixptr[1];
7853       my_strlcpy(vmspath, unixptr, seg_len + 2);
7854       cmp = 1;
7855       if (seg_len == 3) {
7856         cmp = strncmp(vmspath, "dev", 4);
7857         if (cmp == 0) {
7858             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7859             if (sts == SS$_NORMAL)
7860                 return SS$_NORMAL;
7861         }
7862       }
7863       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7864     }
7865
7866     if ($VMS_STATUS_SUCCESS(sts)) {
7867       /* This is verified to be a real path */
7868
7869       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7870       if ($VMS_STATUS_SUCCESS(sts)) {
7871         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
7872         vmsptr = vmspath + vmslen;
7873         unixptr++;
7874         if (unixptr < lastslash) {
7875         char * rptr;
7876           vmsptr--;
7877           *vmsptr++ = '.';
7878           dir_start = 1;
7879           dir_dot = 1;
7880           if (vmslen > 7) {
7881           int cmp;
7882             rptr = vmsptr - 7;
7883             cmp = strcmp(rptr,"000000.");
7884             if (cmp == 0) {
7885               vmslen -= 7;
7886               vmsptr -= 7;
7887               vmsptr[1] = '\0';
7888             } /* removing 6 zeros */
7889           } /* vmslen < 7, no 6 zeros possible */
7890         } /* Not in a directory */
7891       } /* Posix root found */
7892       else {
7893         /* No posix root, fall back to default directory */
7894         strcpy(vmspath, "SYS$DISK:[");
7895         vmsptr = &vmspath[10];
7896         vmslen = 10;
7897         if (unixptr > lastslash) {
7898            *vmsptr = ']';
7899            vmsptr++;
7900            vmslen++;
7901         }
7902         else {
7903            dir_start = 1;
7904         }
7905       }
7906     } /* end of verified real path handling */
7907     else {
7908     int add_6zero;
7909     int islnm;
7910
7911       /* Ok, we have a device or a concealed root that is not in POSIX
7912        * or we have garbage.  Make the best of it.
7913        */
7914
7915       /* Posix to VMS destroyed this, so copy it again */
7916       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
7917       vmslen = strlen(vmspath); /* We know we're truncating. */
7918       vmsptr = &vmsptr[vmslen];
7919       islnm = 0;
7920
7921       /* Now do we need to add the fake 6 zero directory to it? */
7922       add_6zero = 1;
7923       if ((*lastslash == '/') && (nextslash < lastslash)) {
7924         /* No there is another directory */
7925         add_6zero = 0;
7926       }
7927       else {
7928       int trnend;
7929       int cmp;
7930
7931         /* now we have foo:bar or foo:[000000]bar to decide from */
7932         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7933
7934         if (!islnm && !decc_posix_compliant_pathnames) {
7935
7936             cmp = strncmp("bin", vmspath, 4);
7937             if (cmp == 0) {
7938                 /* bin => SYS$SYSTEM: */
7939                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7940             }
7941             else {
7942                 /* tmp => SYS$SCRATCH: */
7943                 cmp = strncmp("tmp", vmspath, 4);
7944                 if (cmp == 0) {
7945                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7946                 }
7947             }
7948         }
7949
7950         trnend = islnm ? islnm - 1 : 0;
7951
7952         /* if this was a logical name, ']' or '>' must be present */
7953         /* if not a logical name, then assume a device and hope. */
7954         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7955
7956         /* if log name and trailing '.' then rooted - treat as device */
7957         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7958
7959         /* Fix me, if not a logical name, a device lookup should be
7960          * done to see if the device is file structured.  If the device
7961          * is not file structured, the 6 zeros should not be put on.
7962          *
7963          * As it is, perl is occasionally looking for dev:[000000]tty.
7964          * which looks a little strange.
7965          *
7966          * Not that easy to detect as "/dev" may be file structured with
7967          * special device files.
7968          */
7969
7970         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
7971             (&nextslash[1] == unixend)) {
7972           /* No real directory present */
7973           add_6zero = 1;
7974         }
7975       }
7976
7977       /* Put the device delimiter on */
7978       *vmsptr++ = ':';
7979       vmslen++;
7980       unixptr = nextslash;
7981       unixptr++;
7982
7983       /* Start directory if needed */
7984       if (!islnm || add_6zero) {
7985         *vmsptr++ = '[';
7986         vmslen++;
7987         dir_start = 1;
7988       }
7989
7990       /* add fake 000000] if needed */
7991       if (add_6zero) {
7992         *vmsptr++ = '0';
7993         *vmsptr++ = '0';
7994         *vmsptr++ = '0';
7995         *vmsptr++ = '0';
7996         *vmsptr++ = '0';
7997         *vmsptr++ = '0';
7998         *vmsptr++ = ']';
7999         vmslen += 7;
8000         dir_start = 0;
8001       }
8002
8003     } /* non-POSIX translation */
8004     PerlMem_free(esa);
8005   } /* End of relative/absolute path handling */
8006
8007   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8008   int dash_flag;
8009   int in_cnt;
8010   int out_cnt;
8011
8012     dash_flag = 0;
8013
8014     if (dir_start != 0) {
8015
8016       /* First characters in a directory are handled special */
8017       while ((*unixptr == '/') ||
8018              ((*unixptr == '.') &&
8019               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8020                 (&unixptr[1]==unixend)))) {
8021       int loop_flag;
8022
8023         loop_flag = 0;
8024
8025         /* Skip redundant / in specification */
8026         while ((*unixptr == '/') && (dir_start != 0)) {
8027           loop_flag = 1;
8028           unixptr++;
8029           if (unixptr == lastslash)
8030             break;
8031         }
8032         if (unixptr == lastslash)
8033           break;
8034
8035         /* Skip redundant ./ characters */
8036         while ((*unixptr == '.') &&
8037                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8038           loop_flag = 1;
8039           unixptr++;
8040           if (unixptr == lastslash)
8041             break;
8042           if (*unixptr == '/')
8043             unixptr++;
8044         }
8045         if (unixptr == lastslash)
8046           break;
8047
8048         /* Skip redundant ../ characters */
8049         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8050              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8051           /* Set the backing up flag */
8052           loop_flag = 1;
8053           dir_dot = 0;
8054           dash_flag = 1;
8055           *vmsptr++ = '-';
8056           vmslen++;
8057           unixptr++; /* first . */
8058           unixptr++; /* second . */
8059           if (unixptr == lastslash)
8060             break;
8061           if (*unixptr == '/') /* The slash */
8062             unixptr++;
8063         }
8064         if (unixptr == lastslash)
8065           break;
8066
8067         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8068         /* Not needed when VMS is pretending to be UNIX. */
8069
8070         /* Is this loop stuck because of too many dots? */
8071         if (loop_flag == 0) {
8072           /* Exit the loop and pass the rest through */
8073           break;
8074         }
8075       }
8076
8077       /* Are we done with directories yet? */
8078       if (unixptr >= lastslash) {
8079
8080         /* Watch out for trailing dots */
8081         if (dir_dot != 0) {
8082             vmslen --;
8083             vmsptr--;
8084         }
8085         *vmsptr++ = ']';
8086         vmslen++;
8087         dash_flag = 0;
8088         dir_start = 0;
8089         if (*unixptr == '/')
8090           unixptr++;
8091       }
8092       else {
8093         /* Have we stopped backing up? */
8094         if (dash_flag) {
8095           *vmsptr++ = '.';
8096           vmslen++;
8097           dash_flag = 0;
8098           /* dir_start continues to be = 1 */
8099         }
8100         if (*unixptr == '-') {
8101           *vmsptr++ = '^';
8102           *vmsptr++ = *unixptr++;
8103           vmslen += 2;
8104           dir_start = 0;
8105
8106           /* Now are we done with directories yet? */
8107           if (unixptr >= lastslash) {
8108
8109             /* Watch out for trailing dots */
8110             if (dir_dot != 0) {
8111               vmslen --;
8112               vmsptr--;
8113             }
8114
8115             *vmsptr++ = ']';
8116             vmslen++;
8117             dash_flag = 0;
8118             dir_start = 0;
8119           }
8120         }
8121       }
8122     }
8123
8124     /* All done? */
8125     if (unixptr >= unixend)
8126       break;
8127
8128     /* Normal characters - More EFS work probably needed */
8129     dir_start = 0;
8130     dir_dot = 0;
8131
8132     switch(*unixptr) {
8133     case '/':
8134         /* remove multiple / */
8135         while (unixptr[1] == '/') {
8136            unixptr++;
8137         }
8138         if (unixptr == lastslash) {
8139           /* Watch out for trailing dots */
8140           if (dir_dot != 0) {
8141             vmslen --;
8142             vmsptr--;
8143           }
8144           *vmsptr++ = ']';
8145         }
8146         else {
8147           dir_start = 1;
8148           *vmsptr++ = '.';
8149           dir_dot = 1;
8150
8151           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8152           /* Not needed when VMS is pretending to be UNIX. */
8153
8154         }
8155         dash_flag = 0;
8156         if (unixptr != unixend)
8157           unixptr++;
8158         vmslen++;
8159         break;
8160     case '.':
8161         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8162             (&unixptr[1] == unixend)) {
8163           *vmsptr++ = '^';
8164           *vmsptr++ = '.';
8165           vmslen += 2;
8166           unixptr++;
8167
8168           /* trailing dot ==> '^..' on VMS */
8169           if (unixptr == unixend) {
8170             *vmsptr++ = '.';
8171             vmslen++;
8172             unixptr++;
8173           }
8174           break;
8175         }
8176
8177         *vmsptr++ = *unixptr++;
8178         vmslen ++;
8179         break;
8180     case '"':
8181         if (quoted && (&unixptr[1] == unixend)) {
8182             unixptr++;
8183             break;
8184         }
8185         in_cnt = copy_expand_unix_filename_escape
8186                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8187         vmsptr += out_cnt;
8188         unixptr += in_cnt;
8189         break;
8190     case '~':
8191     case ';':
8192     case '\\':
8193     case '?':
8194     case ' ':
8195     default:
8196         in_cnt = copy_expand_unix_filename_escape
8197                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8198         vmsptr += out_cnt;
8199         unixptr += in_cnt;
8200         break;
8201     }
8202   }
8203
8204   /* Make sure directory is closed */
8205   if (unixptr == lastslash) {
8206     char *vmsptr2;
8207     vmsptr2 = vmsptr - 1;
8208
8209     if (*vmsptr2 != ']') {
8210       *vmsptr2--;
8211
8212       /* directories do not end in a dot bracket */
8213       if (*vmsptr2 == '.') {
8214         vmsptr2--;
8215
8216         /* ^. is allowed */
8217         if (*vmsptr2 != '^') {
8218           vmsptr--; /* back up over the dot */
8219         }
8220       }
8221       *vmsptr++ = ']';
8222     }
8223   }
8224   else {
8225     char *vmsptr2;
8226     /* Add a trailing dot if a file with no extension */
8227     vmsptr2 = vmsptr - 1;
8228     if ((vmslen > 1) &&
8229         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8230         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8231         *vmsptr++ = '.';
8232         vmslen++;
8233     }
8234   }
8235
8236   *vmsptr = '\0';
8237   return SS$_NORMAL;
8238 }
8239 #endif
8240
8241  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8242 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8243 {
8244 char * result;
8245 int utf8_flag;
8246
8247    /* If a UTF8 flag is being passed, honor it */
8248    utf8_flag = 0;
8249    if (utf8_fl != NULL) {
8250      utf8_flag = *utf8_fl;
8251     *utf8_fl = 0;
8252    }
8253
8254    if (utf8_flag) {
8255      /* If there is a possibility of UTF8, then if any UTF8 characters
8256         are present, then they must be converted to VTF-7
8257       */
8258      result = strcpy(rslt, path); /* FIX-ME */
8259    }
8260    else
8261      result = strcpy(rslt, path);
8262
8263    return result;
8264 }
8265
8266
8267
8268 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8269 static char *int_tovmsspec
8270    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8271   char *dirend;
8272   char *lastdot;
8273   char *cp1;
8274   const char *cp2;
8275   unsigned long int infront = 0, hasdir = 1;
8276   int rslt_len;
8277   int no_type_seen;
8278   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8279   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8280
8281   if (vms_debug_fileify) {
8282       if (path == NULL)
8283           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8284       else
8285           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8286   }
8287
8288   if (path == NULL) {
8289       /* If we fail, we should be setting errno */
8290       set_errno(EINVAL);
8291       set_vaxc_errno(SS$_BADPARAM);
8292       return NULL;
8293   }
8294   rslt_len = VMS_MAXRSS-1;
8295
8296   /* '.' and '..' are "[]" and "[-]" for a quick check */
8297   if (path[0] == '.') {
8298     if (path[1] == '\0') {
8299       strcpy(rslt,"[]");
8300       if (utf8_flag != NULL)
8301         *utf8_flag = 0;
8302       return rslt;
8303     }
8304     else {
8305       if (path[1] == '.' && path[2] == '\0') {
8306         strcpy(rslt,"[-]");
8307         if (utf8_flag != NULL)
8308            *utf8_flag = 0;
8309         return rslt;
8310       }
8311     }
8312   }
8313
8314    /* Posix specifications are now a native VMS format */
8315   /*--------------------------------------------------*/
8316 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8317   if (decc_posix_compliant_pathnames) {
8318     if (strncmp(path,"\"^UP^",5) == 0) {
8319       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8320       return rslt;
8321     }
8322   }
8323 #endif
8324
8325   /* This is really the only way to see if this is already in VMS format */
8326   sts = vms_split_path
8327        (path,
8328         &v_spec,
8329         &v_len,
8330         &r_spec,
8331         &r_len,
8332         &d_spec,
8333         &d_len,
8334         &n_spec,
8335         &n_len,
8336         &e_spec,
8337         &e_len,
8338         &vs_spec,
8339         &vs_len);
8340   if (sts == 0) {
8341     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8342        replacement, because the above parse just took care of most of
8343        what is needed to do vmspath when the specification is already
8344        in VMS format.
8345
8346        And if it is not already, it is easier to do the conversion as
8347        part of this routine than to call this routine and then work on
8348        the result.
8349      */
8350
8351     /* If VMS punctuation was found, it is already VMS format */
8352     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8353       if (utf8_flag != NULL)
8354         *utf8_flag = 0;
8355       my_strlcpy(rslt, path, VMS_MAXRSS);
8356       if (vms_debug_fileify) {
8357           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8358       }
8359       return rslt;
8360     }
8361     /* Now, what to do with trailing "." cases where there is no
8362        extension?  If this is a UNIX specification, and EFS characters
8363        are enabled, then the trailing "." should be converted to a "^.".
8364        But if this was already a VMS specification, then it should be
8365        left alone.
8366
8367        So in the case of ambiguity, leave the specification alone.
8368      */
8369
8370
8371     /* If there is a possibility of UTF8, then if any UTF8 characters
8372         are present, then they must be converted to VTF-7
8373      */
8374     if (utf8_flag != NULL)
8375       *utf8_flag = 0;
8376     my_strlcpy(rslt, path, VMS_MAXRSS);
8377     if (vms_debug_fileify) {
8378         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8379     }
8380     return rslt;
8381   }
8382
8383   dirend = strrchr(path,'/');
8384
8385   if (dirend == NULL) {
8386      char *macro_start;
8387      int has_macro;
8388
8389      /* If we get here with no UNIX directory delimiters, then this is
8390         not a complete file specification, either garbage a UNIX glob
8391         specification that can not be converted to a VMS wildcard, or
8392         it a UNIX shell macro.  MakeMaker wants shell macros passed
8393         through AS-IS,
8394
8395         utf8 flag setting needs to be preserved.
8396       */
8397       hasdir = 0;
8398
8399       has_macro = 0;
8400       macro_start = strchr(path,'$');
8401       if (macro_start != NULL) {
8402           if (macro_start[1] == '(') {
8403               has_macro = 1;
8404           }
8405       }
8406       if ((decc_efs_charset == 0) || (has_macro)) {
8407           my_strlcpy(rslt, path, VMS_MAXRSS);
8408           if (vms_debug_fileify) {
8409               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8410           }
8411           return rslt;
8412       }
8413   }
8414   else if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8415     if (!*(dirend+2)) dirend +=2;
8416     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8417     if (decc_efs_charset == 0) {
8418       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8419     }
8420   }
8421
8422   cp1 = rslt;
8423   cp2 = path;
8424   lastdot = strrchr(cp2,'.');
8425   if (*cp2 == '/') {
8426     char *trndev;
8427     int islnm, rooted;
8428     STRLEN trnend;
8429
8430     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8431     if (!*(cp2+1)) {
8432       if (decc_disable_posix_root) {
8433         strcpy(rslt,"sys$disk:[000000]");
8434       }
8435       else {
8436         strcpy(rslt,"sys$posix_root:[000000]");
8437       }
8438       if (utf8_flag != NULL)
8439         *utf8_flag = 0;
8440       if (vms_debug_fileify) {
8441           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8442       }
8443       return rslt;
8444     }
8445     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8446     *cp1 = '\0';
8447     trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8448     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8449     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8450
8451      /* DECC special handling */
8452     if (!islnm) {
8453       if (strcmp(rslt,"bin") == 0) {
8454         strcpy(rslt,"sys$system");
8455         cp1 = rslt + 10;
8456         *cp1 = 0;
8457         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8458       }
8459       else if (strcmp(rslt,"tmp") == 0) {
8460         strcpy(rslt,"sys$scratch");
8461         cp1 = rslt + 11;
8462         *cp1 = 0;
8463         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8464       }
8465       else if (!decc_disable_posix_root) {
8466         strcpy(rslt, "sys$posix_root");
8467         cp1 = rslt + 14;
8468         *cp1 = 0;
8469         cp2 = path;
8470         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8471         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8472       }
8473       else if (strcmp(rslt,"dev") == 0) {
8474         if (strncmp(cp2,"/null", 5) == 0) {
8475           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8476             strcpy(rslt,"NLA0");
8477             cp1 = rslt + 4;
8478             *cp1 = 0;
8479             cp2 = cp2 + 5;
8480             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8481           }
8482         }
8483       }
8484     }
8485
8486     trnend = islnm ? strlen(trndev) - 1 : 0;
8487     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8488     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8489     /* If the first element of the path is a logical name, determine
8490      * whether it has to be translated so we can add more directories. */
8491     if (!islnm || rooted) {
8492       *(cp1++) = ':';
8493       *(cp1++) = '[';
8494       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8495       else cp2++;
8496     }
8497     else {
8498       if (cp2 != dirend) {
8499         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8500         cp1 = rslt + trnend;
8501         if (*cp2 != 0) {
8502           *(cp1++) = '.';
8503           cp2++;
8504         }
8505       }
8506       else {
8507         if (decc_disable_posix_root) {
8508           *(cp1++) = ':';
8509           hasdir = 0;
8510         }
8511       }
8512     }
8513     PerlMem_free(trndev);
8514   }
8515   else {
8516     *(cp1++) = '[';
8517     if (*cp2 == '.') {
8518       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8519         cp2 += 2;         /* skip over "./" - it's redundant */
8520         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8521       }
8522       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8523         *(cp1++) = '-';                                 /* "../" --> "-" */
8524         cp2 += 3;
8525       }
8526       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8527                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8528         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8529         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8530         cp2 += 4;
8531       }
8532       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8533         /* Escape the extra dots in EFS file specifications */
8534         *(cp1++) = '^';
8535       }
8536       if (cp2 > dirend) cp2 = dirend;
8537     }
8538     else *(cp1++) = '.';
8539   }
8540   for (; cp2 < dirend; cp2++) {
8541     if (*cp2 == '/') {
8542       if (*(cp2-1) == '/') continue;
8543       if (*(cp1-1) != '.') *(cp1++) = '.';
8544       infront = 0;
8545     }
8546     else if (!infront && *cp2 == '.') {
8547       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8548       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8549       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8550         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8551         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8552         else {
8553           *(cp1++) = '-';
8554         }
8555         cp2 += 2;
8556         if (cp2 == dirend) break;
8557       }
8558       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8559                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8560         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8561         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8562         if (!*(cp2+3)) {
8563           *(cp1++) = '.';  /* Simulate trailing '/' */
8564           cp2 += 2;  /* for loop will incr this to == dirend */
8565         }
8566         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8567       }
8568       else {
8569         if (decc_efs_charset == 0)
8570           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8571         else {
8572           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8573           *(cp1++) = '.';
8574         }
8575       }
8576     }
8577     else {
8578       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8579       if (*cp2 == '.') {
8580         if (decc_efs_charset == 0)
8581           *(cp1++) = '_';
8582         else {
8583           *(cp1++) = '^';
8584           *(cp1++) = '.';
8585         }
8586       }
8587       else                  *(cp1++) =  *cp2;
8588       infront = 1;
8589     }
8590   }
8591   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8592   if (hasdir) *(cp1++) = ']';
8593   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8594   /* fixme for ODS5 */
8595   no_type_seen = 0;
8596   if (cp2 > lastdot)
8597     no_type_seen = 1;
8598   while (*cp2) {
8599     switch(*cp2) {
8600     case '?':
8601         if (decc_efs_charset == 0)
8602           *(cp1++) = '%';
8603         else
8604           *(cp1++) = '?';
8605         cp2++;
8606     case ' ':
8607         *(cp1)++ = '^';
8608         *(cp1)++ = '_';
8609         cp2++;
8610         break;
8611     case '.':
8612         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8613             decc_readdir_dropdotnotype) {
8614           *(cp1)++ = '^';
8615           *(cp1)++ = '.';
8616           cp2++;
8617
8618           /* trailing dot ==> '^..' on VMS */
8619           if (*cp2 == '\0') {
8620             *(cp1++) = '.';
8621             no_type_seen = 0;
8622           }
8623         }
8624         else {
8625           *(cp1++) = *(cp2++);
8626           no_type_seen = 0;
8627         }
8628         break;
8629     case '$':
8630          /* This could be a macro to be passed through */
8631         *(cp1++) = *(cp2++);
8632         if (*cp2 == '(') {
8633         const char * save_cp2;
8634         char * save_cp1;
8635         int is_macro;
8636
8637             /* paranoid check */
8638             save_cp2 = cp2;
8639             save_cp1 = cp1;
8640             is_macro = 0;
8641
8642             /* Test through */
8643             *(cp1++) = *(cp2++);
8644             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8645                 *(cp1++) = *(cp2++);
8646                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8647                     *(cp1++) = *(cp2++);
8648                 }
8649                 if (*cp2 == ')') {
8650                     *(cp1++) = *(cp2++);
8651                     is_macro = 1;
8652                 }
8653             }
8654             if (is_macro == 0) {
8655                 /* Not really a macro - never mind */
8656                 cp2 = save_cp2;
8657                 cp1 = save_cp1;
8658             }
8659         }
8660         break;
8661     case '\"':
8662     case '~':
8663     case '`':
8664     case '!':
8665     case '#':
8666     case '%':
8667     case '^':
8668         /* Don't escape again if following character is
8669          * already something we escape.
8670          */
8671         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8672             *(cp1++) = *(cp2++);
8673             break;
8674         }
8675         /* But otherwise fall through and escape it. */
8676     case '&':
8677     case '(':
8678     case ')':
8679     case '=':
8680     case '+':
8681     case '\'':
8682     case '@':
8683     case '[':
8684     case ']':
8685     case '{':
8686     case '}':
8687     case ':':
8688     case '\\':
8689     case '|':
8690     case '<':
8691     case '>':
8692         *(cp1++) = '^';
8693         *(cp1++) = *(cp2++);
8694         break;
8695     case ';':
8696         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8697          * which is wrong.  UNIX notation should be ".dir." unless
8698          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8699          * changing this behavior could break more things at this time.
8700          * efs character set effectively does not allow "." to be a version
8701          * delimiter as a further complication about changing this.
8702          */
8703         if (decc_filename_unix_report != 0) {
8704           *(cp1++) = '^';
8705         }
8706         *(cp1++) = *(cp2++);
8707         break;
8708     default:
8709         *(cp1++) = *(cp2++);
8710     }
8711   }
8712   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8713   char *lcp1;
8714     lcp1 = cp1;
8715     lcp1--;
8716      /* Fix me for "^]", but that requires making sure that you do
8717       * not back up past the start of the filename
8718       */
8719     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8720       *cp1++ = '.';
8721   }
8722   *cp1 = '\0';
8723
8724   if (utf8_flag != NULL)
8725     *utf8_flag = 0;
8726   if (vms_debug_fileify) {
8727       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8728   }
8729   return rslt;
8730
8731 }  /* end of int_tovmsspec() */
8732
8733
8734 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8735 static char *mp_do_tovmsspec
8736    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8737   static char __tovmsspec_retbuf[VMS_MAXRSS];
8738     char * vmsspec, *ret_spec, *ret_buf;
8739
8740     vmsspec = NULL;
8741     ret_buf = buf;
8742     if (ret_buf == NULL) {
8743         if (ts) {
8744             Newx(vmsspec, VMS_MAXRSS, char);
8745             if (vmsspec == NULL)
8746                 _ckvmssts(SS$_INSFMEM);
8747             ret_buf = vmsspec;
8748         } else {
8749             ret_buf = __tovmsspec_retbuf;
8750         }
8751     }
8752
8753     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8754
8755     if (ret_spec == NULL) {
8756        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8757        if (vmsspec)
8758            Safefree(vmsspec);
8759     }
8760
8761     return ret_spec;
8762
8763 }  /* end of mp_do_tovmsspec() */
8764 /*}}}*/
8765 /* External entry points */
8766 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8767   { return do_tovmsspec(path,buf,0,NULL); }
8768 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8769   { return do_tovmsspec(path,buf,1,NULL); }
8770 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8771   { return do_tovmsspec(path,buf,0,utf8_fl); }
8772 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8773   { return do_tovmsspec(path,buf,1,utf8_fl); }
8774
8775 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8776 /* Internal routine for use with out an explicit context present */
8777 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
8778
8779     char * ret_spec, *pathified;
8780
8781     if (path == NULL)
8782         return NULL;
8783
8784     pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8785     if (pathified == NULL)
8786         _ckvmssts_noperl(SS$_INSFMEM);
8787
8788     ret_spec = int_pathify_dirspec(path, pathified);
8789
8790     if (ret_spec == NULL) {
8791         PerlMem_free(pathified);
8792         return NULL;
8793     }
8794
8795     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8796
8797     PerlMem_free(pathified);
8798     return ret_spec;
8799
8800 }
8801
8802 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8803 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8804   static char __tovmspath_retbuf[VMS_MAXRSS];
8805   int vmslen;
8806   char *pathified, *vmsified, *cp;
8807
8808   if (path == NULL) return NULL;
8809   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8810   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8811   if (int_pathify_dirspec(path, pathified) == NULL) {
8812     PerlMem_free(pathified);
8813     return NULL;
8814   }
8815
8816   vmsified = NULL;
8817   if (buf == NULL)
8818      Newx(vmsified, VMS_MAXRSS, char);
8819   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8820     PerlMem_free(pathified);
8821     if (vmsified) Safefree(vmsified);
8822     return NULL;
8823   }
8824   PerlMem_free(pathified);
8825   if (buf) {
8826     return buf;
8827   }
8828   else if (ts) {
8829     vmslen = strlen(vmsified);
8830     Newx(cp,vmslen+1,char);
8831     memcpy(cp,vmsified,vmslen);
8832     cp[vmslen] = '\0';
8833     Safefree(vmsified);
8834     return cp;
8835   }
8836   else {
8837     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8838     Safefree(vmsified);
8839     return __tovmspath_retbuf;
8840   }
8841
8842 }  /* end of do_tovmspath() */
8843 /*}}}*/
8844 /* External entry points */
8845 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8846   { return do_tovmspath(path,buf,0, NULL); }
8847 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8848   { return do_tovmspath(path,buf,1, NULL); }
8849 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8850   { return do_tovmspath(path,buf,0,utf8_fl); }
8851 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8852   { return do_tovmspath(path,buf,1,utf8_fl); }
8853
8854
8855 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8856 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8857   static char __tounixpath_retbuf[VMS_MAXRSS];
8858   int unixlen;
8859   char *pathified, *unixified, *cp;
8860
8861   if (path == NULL) return NULL;
8862   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8863   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8864   if (int_pathify_dirspec(path, pathified) == NULL) {
8865     PerlMem_free(pathified);
8866     return NULL;
8867   }
8868
8869   unixified = NULL;
8870   if (buf == NULL) {
8871       Newx(unixified, VMS_MAXRSS, char);
8872   }
8873   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8874     PerlMem_free(pathified);
8875     if (unixified) Safefree(unixified);
8876     return NULL;
8877   }
8878   PerlMem_free(pathified);
8879   if (buf) {
8880     return buf;
8881   }
8882   else if (ts) {
8883     unixlen = strlen(unixified);
8884     Newx(cp,unixlen+1,char);
8885     memcpy(cp,unixified,unixlen);
8886     cp[unixlen] = '\0';
8887     Safefree(unixified);
8888     return cp;
8889   }
8890   else {
8891     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
8892     Safefree(unixified);
8893     return __tounixpath_retbuf;
8894   }
8895
8896 }  /* end of do_tounixpath() */
8897 /*}}}*/
8898 /* External entry points */
8899 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8900   { return do_tounixpath(path,buf,0,NULL); }
8901 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8902   { return do_tounixpath(path,buf,1,NULL); }
8903 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8904   { return do_tounixpath(path,buf,0,utf8_fl); }
8905 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8906   { return do_tounixpath(path,buf,1,utf8_fl); }
8907
8908 /*
8909  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8910  *
8911  *****************************************************************************
8912  *                                                                           *
8913  *  Copyright (C) 1989-1994, 2007 by                                         *
8914  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8915  *                                                                           *
8916  *  Permission is hereby granted for the reproduction of this software       *
8917  *  on condition that this copyright notice is included in source            *
8918  *  distributions of the software.  The code may be modified and             *
8919  *  distributed under the same terms as Perl itself.                         *
8920  *                                                                           *
8921  *  27-Aug-1994 Modified for inclusion in perl5                              *
8922  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8923  *****************************************************************************
8924  */
8925
8926 /*
8927  * getredirection() is intended to aid in porting C programs
8928  * to VMS (Vax-11 C).  The native VMS environment does not support
8929  * '>' and '<' I/O redirection, or command line wild card expansion,
8930  * or a command line pipe mechanism using the '|' AND background
8931  * command execution '&'.  All of these capabilities are provided to any
8932  * C program which calls this procedure as the first thing in the
8933  * main program.
8934  * The piping mechanism will probably work with almost any 'filter' type
8935  * of program.  With suitable modification, it may useful for other
8936  * portability problems as well.
8937  *
8938  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8939  */
8940 struct list_item
8941     {
8942     struct list_item *next;
8943     char *value;
8944     };
8945
8946 static void add_item(struct list_item **head,
8947                      struct list_item **tail,
8948                      char *value,
8949                      int *count);
8950
8951 static void mp_expand_wild_cards(pTHX_ char *item,
8952                                 struct list_item **head,
8953                                 struct list_item **tail,
8954                                 int *count);
8955
8956 static int background_process(pTHX_ int argc, char **argv);
8957
8958 static void pipe_and_fork(pTHX_ char **cmargv);
8959
8960 /*{{{ void getredirection(int *ac, char ***av)*/
8961 static void
8962 mp_getredirection(pTHX_ int *ac, char ***av)
8963 /*
8964  * Process vms redirection arg's.  Exit if any error is seen.
8965  * If getredirection() processes an argument, it is erased
8966  * from the vector.  getredirection() returns a new argc and argv value.
8967  * In the event that a background command is requested (by a trailing "&"),
8968  * this routine creates a background subprocess, and simply exits the program.
8969  *
8970  * Warning: do not try to simplify the code for vms.  The code
8971  * presupposes that getredirection() is called before any data is
8972  * read from stdin or written to stdout.
8973  *
8974  * Normal usage is as follows:
8975  *
8976  *      main(argc, argv)
8977  *      int             argc;
8978  *      char            *argv[];
8979  *      {
8980  *              getredirection(&argc, &argv);
8981  *      }
8982  */
8983 {
8984     int                 argc = *ac;     /* Argument Count         */
8985     char                **argv = *av;   /* Argument Vector        */
8986     char                *ap;            /* Argument pointer       */
8987     int                 j;              /* argv[] index           */
8988     int                 item_count = 0; /* Count of Items in List */
8989     struct list_item    *list_head = 0; /* First Item in List       */
8990     struct list_item    *list_tail;     /* Last Item in List        */
8991     char                *in = NULL;     /* Input File Name          */
8992     char                *out = NULL;    /* Output File Name         */
8993     char                *outmode = "w"; /* Mode to Open Output File */
8994     char                *err = NULL;    /* Error File Name          */
8995     char                *errmode = "w"; /* Mode to Open Error File  */
8996     int                 cmargc = 0;     /* Piped Command Arg Count  */
8997     char                **cmargv = NULL;/* Piped Command Arg Vector */
8998
8999     /*
9000      * First handle the case where the last thing on the line ends with
9001      * a '&'.  This indicates the desire for the command to be run in a
9002      * subprocess, so we satisfy that desire.
9003      */
9004     ap = argv[argc-1];
9005     if (0 == strcmp("&", ap))
9006        exit(background_process(aTHX_ --argc, argv));
9007     if (*ap && '&' == ap[strlen(ap)-1])
9008         {
9009         ap[strlen(ap)-1] = '\0';
9010        exit(background_process(aTHX_ argc, argv));
9011         }
9012     /*
9013      * Now we handle the general redirection cases that involve '>', '>>',
9014      * '<', and pipes '|'.
9015      */
9016     for (j = 0; j < argc; ++j)
9017         {
9018         if (0 == strcmp("<", argv[j]))
9019             {
9020             if (j+1 >= argc)
9021                 {
9022                 fprintf(stderr,"No input file after < on command line");
9023                 exit(LIB$_WRONUMARG);
9024                 }
9025             in = argv[++j];
9026             continue;
9027             }
9028         if ('<' == *(ap = argv[j]))
9029             {
9030             in = 1 + ap;
9031             continue;
9032             }
9033         if (0 == strcmp(">", ap))
9034             {
9035             if (j+1 >= argc)
9036                 {
9037                 fprintf(stderr,"No output file after > on command line");
9038                 exit(LIB$_WRONUMARG);
9039                 }
9040             out = argv[++j];
9041             continue;
9042             }
9043         if ('>' == *ap)
9044             {
9045             if ('>' == ap[1])
9046                 {
9047                 outmode = "a";
9048                 if ('\0' == ap[2])
9049                     out = argv[++j];
9050                 else
9051                     out = 2 + ap;
9052                 }
9053             else
9054                 out = 1 + ap;
9055             if (j >= argc)
9056                 {
9057                 fprintf(stderr,"No output file after > or >> on command line");
9058                 exit(LIB$_WRONUMARG);
9059                 }
9060             continue;
9061             }
9062         if (('2' == *ap) && ('>' == ap[1]))
9063             {
9064             if ('>' == ap[2])
9065                 {
9066                 errmode = "a";
9067                 if ('\0' == ap[3])
9068                     err = argv[++j];
9069                 else
9070                     err = 3 + ap;
9071                 }
9072             else
9073                 if ('\0' == ap[2])
9074                     err = argv[++j];
9075                 else
9076                     err = 2 + ap;
9077             if (j >= argc)
9078                 {
9079                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9080                 exit(LIB$_WRONUMARG);
9081                 }
9082             continue;
9083             }
9084         if (0 == strcmp("|", argv[j]))
9085             {
9086             if (j+1 >= argc)
9087                 {
9088                 fprintf(stderr,"No command into which to pipe on command line");
9089                 exit(LIB$_WRONUMARG);
9090                 }
9091             cmargc = argc-(j+1);
9092             cmargv = &argv[j+1];
9093             argc = j;
9094             continue;
9095             }
9096         if ('|' == *(ap = argv[j]))
9097             {
9098             ++argv[j];
9099             cmargc = argc-j;
9100             cmargv = &argv[j];
9101             argc = j;
9102             continue;
9103             }
9104         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9105         }
9106     /*
9107      * Allocate and fill in the new argument vector, Some Unix's terminate
9108      * the list with an extra null pointer.
9109      */
9110     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9111     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9112     *av = argv;
9113     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9114         argv[j] = list_head->value;
9115     *ac = item_count;
9116     if (cmargv != NULL)
9117         {
9118         if (out != NULL)
9119             {
9120             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9121             exit(LIB$_INVARGORD);
9122             }
9123         pipe_and_fork(aTHX_ cmargv);
9124         }
9125
9126     /* Check for input from a pipe (mailbox) */
9127
9128     if (in == NULL && 1 == isapipe(0))
9129         {
9130         char mbxname[L_tmpnam];
9131         long int bufsize;
9132         long int dvi_item = DVI$_DEVBUFSIZ;
9133         $DESCRIPTOR(mbxnam, "");
9134         $DESCRIPTOR(mbxdevnam, "");
9135
9136         /* Input from a pipe, reopen it in binary mode to disable       */
9137         /* carriage control processing.                                 */
9138
9139         fgetname(stdin, mbxname, 1);
9140         mbxnam.dsc$a_pointer = mbxname;
9141         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9142         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9143         mbxdevnam.dsc$a_pointer = mbxname;
9144         mbxdevnam.dsc$w_length = sizeof(mbxname);
9145         dvi_item = DVI$_DEVNAM;
9146         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9147         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9148         set_errno(0);
9149         set_vaxc_errno(1);
9150         freopen(mbxname, "rb", stdin);
9151         if (errno != 0)
9152             {
9153             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9154             exit(vaxc$errno);
9155             }
9156         }
9157     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9158         {
9159         fprintf(stderr,"Can't open input file %s as stdin",in);
9160         exit(vaxc$errno);
9161         }
9162     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9163         {
9164         fprintf(stderr,"Can't open output file %s as stdout",out);
9165         exit(vaxc$errno);
9166         }
9167         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9168
9169     if (err != NULL) {
9170         if (strcmp(err,"&1") == 0) {
9171             dup2(fileno(stdout), fileno(stderr));
9172             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9173         } else {
9174         FILE *tmperr;
9175         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9176             {
9177             fprintf(stderr,"Can't open error file %s as stderr",err);
9178             exit(vaxc$errno);
9179             }
9180             fclose(tmperr);
9181            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9182                 {
9183                 exit(vaxc$errno);
9184                 }
9185             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9186         }
9187         }
9188 #ifdef ARGPROC_DEBUG
9189     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9190     for (j = 0; j < *ac;  ++j)
9191         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9192 #endif
9193    /* Clear errors we may have hit expanding wildcards, so they don't
9194       show up in Perl's $! later */
9195    set_errno(0); set_vaxc_errno(1);
9196 }  /* end of getredirection() */
9197 /*}}}*/
9198
9199 static void add_item(struct list_item **head,
9200                      struct list_item **tail,
9201                      char *value,
9202                      int *count)
9203 {
9204     if (*head == 0)
9205         {
9206         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9207         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9208         *tail = *head;
9209         }
9210     else {
9211         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9212         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9213         *tail = (*tail)->next;
9214         }
9215     (*tail)->value = value;
9216     ++(*count);
9217 }
9218
9219 static void mp_expand_wild_cards(pTHX_ char *item,
9220                               struct list_item **head,
9221                               struct list_item **tail,
9222                               int *count)
9223 {
9224 int expcount = 0;
9225 unsigned long int context = 0;
9226 int isunix = 0;
9227 int item_len = 0;
9228 char *had_version;
9229 char *had_device;
9230 int had_directory;
9231 char *devdir,*cp;
9232 char *vmsspec;
9233 $DESCRIPTOR(filespec, "");
9234 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9235 $DESCRIPTOR(resultspec, "");
9236 unsigned long int lff_flags = 0;
9237 int sts;
9238 int rms_sts;
9239
9240 #ifdef VMS_LONGNAME_SUPPORT
9241     lff_flags = LIB$M_FIL_LONG_NAMES;
9242 #endif
9243
9244     for (cp = item; *cp; cp++) {
9245         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9246         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9247     }
9248     if (!*cp || isspace(*cp))
9249         {
9250         add_item(head, tail, item, count);
9251         return;
9252         }
9253     else
9254         {
9255      /* "double quoted" wild card expressions pass as is */
9256      /* From DCL that means using e.g.:                  */
9257      /* perl program """perl.*"""                        */
9258      item_len = strlen(item);
9259      if ( '"' == *item && '"' == item[item_len-1] )
9260        {
9261        item++;
9262        item[item_len-2] = '\0';
9263        add_item(head, tail, item, count);
9264        return;
9265        }
9266      }
9267     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9268     resultspec.dsc$b_class = DSC$K_CLASS_D;
9269     resultspec.dsc$a_pointer = NULL;
9270     vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9271     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9272     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9273       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9274     if (!isunix || !filespec.dsc$a_pointer)
9275       filespec.dsc$a_pointer = item;
9276     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9277     /*
9278      * Only return version specs, if the caller specified a version
9279      */
9280     had_version = strchr(item, ';');
9281     /*
9282      * Only return device and directory specs, if the caller specified either.
9283      */
9284     had_device = strchr(item, ':');
9285     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9286
9287     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9288                                  (&filespec, &resultspec, &context,
9289                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9290         {
9291         char *string;
9292         char *c;
9293
9294         string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9295         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9296         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9297         if (NULL == had_version)
9298             *(strrchr(string, ';')) = '\0';
9299         if ((!had_directory) && (had_device == NULL))
9300             {
9301             if (NULL == (devdir = strrchr(string, ']')))
9302                 devdir = strrchr(string, '>');
9303             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9304             }
9305         /*
9306          * Be consistent with what the C RTL has already done to the rest of
9307          * the argv items and lowercase all of these names.
9308          */
9309         if (!decc_efs_case_preserve) {
9310             for (c = string; *c; ++c)
9311             if (isupper(*c))
9312                 *c = tolower(*c);
9313         }
9314         if (isunix) trim_unixpath(string,item,1);
9315         add_item(head, tail, string, count);
9316         ++expcount;
9317     }
9318     PerlMem_free(vmsspec);
9319     if (sts != RMS$_NMF)
9320         {
9321         set_vaxc_errno(sts);
9322         switch (sts)
9323             {
9324             case RMS$_FNF: case RMS$_DNF:
9325                 set_errno(ENOENT); break;
9326             case RMS$_DIR:
9327                 set_errno(ENOTDIR); break;
9328             case RMS$_DEV:
9329                 set_errno(ENODEV); break;
9330             case RMS$_FNM: case RMS$_SYN:
9331                 set_errno(EINVAL); break;
9332             case RMS$_PRV:
9333                 set_errno(EACCES); break;
9334             default:
9335                 _ckvmssts_noperl(sts);
9336             }
9337         }
9338     if (expcount == 0)
9339         add_item(head, tail, item, count);
9340     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9341     _ckvmssts_noperl(lib$find_file_end(&context));
9342 }
9343
9344 static int child_st[2];/* Event Flag set when child process completes   */
9345
9346 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9347
9348 static unsigned long int exit_handler(void)
9349 {
9350 short iosb[4];
9351
9352     if (0 == child_st[0])
9353         {
9354 #ifdef ARGPROC_DEBUG
9355         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9356 #endif
9357         fflush(stdout);     /* Have to flush pipe for binary data to    */
9358                             /* terminate properly -- <tp@mccall.com>    */
9359         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9360         sys$dassgn(child_chan);
9361         fclose(stdout);
9362         sys$synch(0, child_st);
9363         }
9364     return(1);
9365 }
9366
9367 static void sig_child(int chan)
9368 {
9369 #ifdef ARGPROC_DEBUG
9370     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9371 #endif
9372     if (child_st[0] == 0)
9373         child_st[0] = 1;
9374 }
9375
9376 static struct exit_control_block exit_block =
9377     {
9378     0,
9379     exit_handler,
9380     1,
9381     &exit_block.exit_status,
9382     0
9383     };
9384
9385 static void
9386 pipe_and_fork(pTHX_ char **cmargv)
9387 {
9388     PerlIO *fp;
9389     struct dsc$descriptor_s *vmscmd;
9390     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9391     int sts, j, l, ismcr, quote, tquote = 0;
9392
9393     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9394     vms_execfree(vmscmd);
9395
9396     j = l = 0;
9397     p = subcmd;
9398     q = cmargv[0];
9399     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9400               && toupper(*(q+2)) == 'R' && !*(q+3);
9401
9402     while (q && l < MAX_DCL_LINE_LENGTH) {
9403         if (!*q) {
9404             if (j > 0 && quote) {
9405                 *p++ = '"';
9406                 l++;
9407             }
9408             q = cmargv[++j];
9409             if (q) {
9410                 if (ismcr && j > 1) quote = 1;
9411                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9412                 *p++ = ' ';
9413                 l++;
9414                 if (quote || tquote) {
9415                     *p++ = '"';
9416                     l++;
9417                 }
9418             }
9419         } else {
9420             if ((quote||tquote) && *q == '"') {
9421                 *p++ = '"';
9422                 l++;
9423             }
9424             *p++ = *q++;
9425             l++;
9426         }
9427     }
9428     *p = '\0';
9429
9430     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9431     if (fp == NULL) {
9432         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9433     }
9434 }
9435
9436 static int background_process(pTHX_ int argc, char **argv)
9437 {
9438 char command[MAX_DCL_SYMBOL + 1] = "$";
9439 $DESCRIPTOR(value, "");
9440 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9441 static $DESCRIPTOR(null, "NLA0:");
9442 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9443 char pidstring[80];
9444 $DESCRIPTOR(pidstr, "");
9445 int pid;
9446 unsigned long int flags = 17, one = 1, retsts;
9447 int len;
9448
9449     len = my_strlcat(command, argv[0], sizeof(command));
9450     while (--argc && (len < MAX_DCL_SYMBOL))
9451         {
9452         my_strlcat(command, " \"", sizeof(command));
9453         my_strlcat(command, *(++argv), sizeof(command));
9454         len = my_strlcat(command, "\"", sizeof(command));
9455         }
9456     value.dsc$a_pointer = command;
9457     value.dsc$w_length = strlen(value.dsc$a_pointer);
9458     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9459     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9460     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9461         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9462     }
9463     else {
9464         _ckvmssts_noperl(retsts);
9465     }
9466 #ifdef ARGPROC_DEBUG
9467     PerlIO_printf(Perl_debug_log, "%s\n", command);
9468 #endif
9469     sprintf(pidstring, "%08X", pid);
9470     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9471     pidstr.dsc$a_pointer = pidstring;
9472     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9473     lib$set_symbol(&pidsymbol, &pidstr);
9474     return(SS$_NORMAL);
9475 }
9476 /*}}}*/
9477 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9478
9479
9480 /* OS-specific initialization at image activation (not thread startup) */
9481 /* Older VAXC header files lack these constants */
9482 #ifndef JPI$_RIGHTS_SIZE
9483 #  define JPI$_RIGHTS_SIZE 817
9484 #endif
9485 #ifndef KGB$M_SUBSYSTEM
9486 #  define KGB$M_SUBSYSTEM 0x8
9487 #endif
9488
9489 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9490
9491 /*{{{void vms_image_init(int *, char ***)*/
9492 void
9493 vms_image_init(int *argcp, char ***argvp)
9494 {
9495   int status;
9496   char eqv[LNM$C_NAMLENGTH+1] = "";
9497   unsigned int len, tabct = 8, tabidx = 0;
9498   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9499   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9500   unsigned short int dummy, rlen;
9501   struct dsc$descriptor_s **tabvec;
9502 #if defined(PERL_IMPLICIT_CONTEXT)
9503   pTHX = NULL;
9504 #endif
9505   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9506                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9507                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9508                                  {          0,                0,    0,      0} };
9509
9510 #ifdef KILL_BY_SIGPRC
9511     Perl_csighandler_init();
9512 #endif
9513
9514 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9515     /* This was moved from the pre-image init handler because on threaded */
9516     /* Perl it was always returning 0 for the default value. */
9517     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9518     if (status > 0) {
9519         int s;
9520         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9521         if (s > 0) {
9522             int initial;
9523             initial = decc$feature_get_value(s, 4);
9524             if (initial > 0) {
9525                 /* initial is: 0 if nothing has set the feature */
9526                 /*            -1 if initialized to default */
9527                 /*             1 if set by logical name */
9528                 /*             2 if set by decc$feature_set_value */
9529                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9530
9531                 /* If the value is not valid, force the feature off */
9532                 if (decc_disable_posix_root < 0) {
9533                     decc$feature_set_value(s, 1, 1);
9534                     decc_disable_posix_root = 1;
9535                 }
9536             }
9537             else {
9538                 /* Nothing has asked for it explicitly, so use our own default. */
9539                 decc_disable_posix_root = 1;
9540                 decc$feature_set_value(s, 1, 1);
9541             }
9542         }
9543     }
9544 #endif
9545
9546   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9547   _ckvmssts_noperl(iosb[0]);
9548   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9549     if (iprv[i]) {           /* Running image installed with privs? */
9550       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9551       will_taint = TRUE;
9552       break;
9553     }
9554   }
9555   /* Rights identifiers might trigger tainting as well. */
9556   if (!will_taint && (rlen || rsz)) {
9557     while (rlen < rsz) {
9558       /* We didn't get all the identifiers on the first pass.  Allocate a
9559        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9560        * were needed to hold all identifiers at time of last call; we'll
9561        * allocate that many unsigned long ints), and go back and get 'em.
9562        * If it gave us less than it wanted to despite ample buffer space,
9563        * something's broken.  Is your system missing a system identifier?
9564        */
9565       if (rsz <= jpilist[1].buflen) {
9566          /* Perl_croak accvios when used this early in startup. */
9567          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9568                          rsz, (unsigned long) jpilist[1].buflen,
9569                          "Check your rights database for corruption.\n");
9570          exit(SS$_ABORT);
9571       }
9572       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9573       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9574       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9575       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9576       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9577       _ckvmssts_noperl(iosb[0]);
9578     }
9579     mask = (unsigned long int *)jpilist[1].bufadr;
9580     /* Check attribute flags for each identifier (2nd longword); protected
9581      * subsystem identifiers trigger tainting.
9582      */
9583     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9584       if (mask[i] & KGB$M_SUBSYSTEM) {
9585         will_taint = TRUE;
9586         break;
9587       }
9588     }
9589     if (mask != rlst) PerlMem_free(mask);
9590   }
9591
9592   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9593    * logical, some versions of the CRTL will add a phanthom /000000/
9594    * directory.  This needs to be removed.
9595    */
9596   if (decc_filename_unix_report) {
9597   char * zeros;
9598   int ulen;
9599     ulen = strlen(argvp[0][0]);
9600     if (ulen > 7) {
9601       zeros = strstr(argvp[0][0], "/000000/");
9602       if (zeros != NULL) {
9603         int mlen;
9604         mlen = ulen - (zeros - argvp[0][0]) - 7;
9605         memmove(zeros, &zeros[7], mlen);
9606         ulen = ulen - 7;
9607         argvp[0][0][ulen] = '\0';
9608       }
9609     }
9610     /* It also may have a trailing dot that needs to be removed otherwise
9611      * it will be converted to VMS mode incorrectly.
9612      */
9613     ulen--;
9614     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9615       argvp[0][0][ulen] = '\0';
9616   }
9617
9618   /* We need to use this hack to tell Perl it should run with tainting,
9619    * since its tainting flag may be part of the PL_curinterp struct, which
9620    * hasn't been allocated when vms_image_init() is called.
9621    */
9622   if (will_taint) {
9623     char **newargv, **oldargv;
9624     oldargv = *argvp;
9625     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9626     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9627     newargv[0] = oldargv[0];
9628     newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9629     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9630     strcpy(newargv[1], "-T");
9631     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9632     (*argcp)++;
9633     newargv[*argcp] = NULL;
9634     /* We orphan the old argv, since we don't know where it's come from,
9635      * so we don't know how to free it.
9636      */
9637     *argvp = newargv;
9638   }
9639   else {  /* Did user explicitly request tainting? */
9640     int i;
9641     char *cp, **av = *argvp;
9642     for (i = 1; i < *argcp; i++) {
9643       if (*av[i] != '-') break;
9644       for (cp = av[i]+1; *cp; cp++) {
9645         if (*cp == 'T') { will_taint = 1; break; }
9646         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9647                   strchr("DFIiMmx",*cp)) break;
9648       }
9649       if (will_taint) break;
9650     }
9651   }
9652
9653   for (tabidx = 0;
9654        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9655        tabidx++) {
9656     if (!tabidx) {
9657       tabvec = (struct dsc$descriptor_s **)
9658             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9659       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9660     }
9661     else if (tabidx >= tabct) {
9662       tabct += 8;
9663       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9664       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9665     }
9666     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9667     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9668     tabvec[tabidx]->dsc$w_length  = 0;
9669     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9670     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9671     tabvec[tabidx]->dsc$a_pointer = NULL;
9672     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9673   }
9674   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9675
9676   getredirection(argcp,argvp);
9677 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9678   {
9679 # include <reentrancy.h>
9680   decc$set_reentrancy(C$C_MULTITHREAD);
9681   }
9682 #endif
9683   return;
9684 }
9685 /*}}}*/
9686
9687
9688 /* trim_unixpath()
9689  * Trim Unix-style prefix off filespec, so it looks like what a shell
9690  * glob expansion would return (i.e. from specified prefix on, not
9691  * full path).  Note that returned filespec is Unix-style, regardless
9692  * of whether input filespec was VMS-style or Unix-style.
9693  *
9694  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9695  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9696  * vector of options; at present, only bit 0 is used, and if set tells
9697  * trim unixpath to try the current default directory as a prefix when
9698  * presented with a possibly ambiguous ... wildcard.
9699  *
9700  * Returns !=0 on success, with trimmed filespec replacing contents of
9701  * fspec, and 0 on failure, with contents of fpsec unchanged.
9702  */
9703 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9704 int
9705 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9706 {
9707   char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9708   int tmplen, reslen = 0, dirs = 0;
9709
9710   if (!wildspec || !fspec) return 0;
9711
9712   unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9713   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9714   tplate = unixwild;
9715   if (strpbrk(wildspec,"]>:") != NULL) {
9716     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9717         PerlMem_free(unixwild);
9718         return 0;
9719     }
9720   }
9721   else {
9722     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9723   }
9724   unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9725   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9726   if (strpbrk(fspec,"]>:") != NULL) {
9727     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9728         PerlMem_free(unixwild);
9729         PerlMem_free(unixified);
9730         return 0;
9731     }
9732     else base = unixified;
9733     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9734      * check to see that final result fits into (isn't longer than) fspec */
9735     reslen = strlen(fspec);
9736   }
9737   else base = fspec;
9738
9739   /* No prefix or absolute path on wildcard, so nothing to remove */
9740   if (!*tplate || *tplate == '/') {
9741     PerlMem_free(unixwild);
9742     if (base == fspec) {
9743         PerlMem_free(unixified);
9744         return 1;
9745     }
9746     tmplen = strlen(unixified);
9747     if (tmplen > reslen) {
9748         PerlMem_free(unixified);
9749         return 0;  /* not enough space */
9750     }
9751     /* Copy unixified resultant, including trailing NUL */
9752     memmove(fspec,unixified,tmplen+1);
9753     PerlMem_free(unixified);
9754     return 1;
9755   }
9756
9757   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9758   if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9759     for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9760     for (cp1 = end ;cp1 >= base; cp1--)
9761       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9762         { cp1++; break; }
9763     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9764     PerlMem_free(unixified);
9765     PerlMem_free(unixwild);
9766     return 1;
9767   }
9768   else {
9769     char *tpl, *lcres;
9770     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9771     int ells = 1, totells, segdirs, match;
9772     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9773                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9774
9775     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9776     totells = ells;
9777     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9778     tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9779     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9780     if (ellipsis == tplate && opts & 1) {
9781       /* Template begins with an ellipsis.  Since we can't tell how many
9782        * directory names at the front of the resultant to keep for an
9783        * arbitrary starting point, we arbitrarily choose the current
9784        * default directory as a starting point.  If it's there as a prefix,
9785        * clip it off.  If not, fall through and act as if the leading
9786        * ellipsis weren't there (i.e. return shortest possible path that
9787        * could match template).
9788        */
9789       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9790           PerlMem_free(tpl);
9791           PerlMem_free(unixified);
9792           PerlMem_free(unixwild);
9793           return 0;
9794       }
9795       if (!decc_efs_case_preserve) {
9796         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9797           if (_tolower(*cp1) != _tolower(*cp2)) break;
9798       }
9799       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9800       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9801       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9802         memmove(fspec,cp2+1,end - cp2);
9803         PerlMem_free(tpl);
9804         PerlMem_free(unixified);
9805         PerlMem_free(unixwild);
9806         return 1;
9807       }
9808     }
9809     /* First off, back up over constant elements at end of path */
9810     if (dirs) {
9811       for (front = end ; front >= base; front--)
9812          if (*front == '/' && !dirs--) { front++; break; }
9813     }
9814     lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9815     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9816     for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9817          cp1++,cp2++) {
9818             if (!decc_efs_case_preserve) {
9819                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9820             }
9821             else {
9822                 *cp2 = *cp1;
9823             }
9824     }
9825     if (cp1 != '\0') {
9826         PerlMem_free(tpl);
9827         PerlMem_free(unixified);
9828         PerlMem_free(unixwild);
9829         PerlMem_free(lcres);
9830         return 0;  /* Path too long. */
9831     }
9832     lcend = cp2;
9833     *cp2 = '\0';  /* Pick up with memcpy later */
9834     lcfront = lcres + (front - base);
9835     /* Now skip over each ellipsis and try to match the path in front of it. */
9836     while (ells--) {
9837       for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9838         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9839             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9840       if (cp1 < tplate) break; /* template started with an ellipsis */
9841       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9842         ellipsis = cp1; continue;
9843       }
9844       wilddsc.dsc$a_pointer = tpl;
9845       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9846       nextell = cp1;
9847       for (segdirs = 0, cp2 = tpl;
9848            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9849            cp1++, cp2++) {
9850          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9851          else {
9852             if (!decc_efs_case_preserve) {
9853               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9854             }
9855             else {
9856               *cp2 = *cp1;  /* else preserve case for match */
9857             }
9858          }
9859          if (*cp2 == '/') segdirs++;
9860       }
9861       if (cp1 != ellipsis - 1) {
9862           PerlMem_free(tpl);
9863           PerlMem_free(unixified);
9864           PerlMem_free(unixwild);
9865           PerlMem_free(lcres);
9866           return 0; /* Path too long */
9867       }
9868       /* Back up at least as many dirs as in template before matching */
9869       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9870         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9871       for (match = 0; cp1 > lcres;) {
9872         resdsc.dsc$a_pointer = cp1;
9873         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9874           match++;
9875           if (match == 1) lcfront = cp1;
9876         }
9877         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9878       }
9879       if (!match) {
9880         PerlMem_free(tpl);
9881         PerlMem_free(unixified);
9882         PerlMem_free(unixwild);
9883         PerlMem_free(lcres);
9884         return 0;  /* Can't find prefix ??? */
9885       }
9886       if (match > 1 && opts & 1) {
9887         /* This ... wildcard could cover more than one set of dirs (i.e.
9888          * a set of similar dir names is repeated).  If the template
9889          * contains more than 1 ..., upstream elements could resolve the
9890          * ambiguity, but it's not worth a full backtracking setup here.
9891          * As a quick heuristic, clip off the current default directory
9892          * if it's present to find the trimmed spec, else use the
9893          * shortest string that this ... could cover.
9894          */
9895         char def[NAM$C_MAXRSS+1], *st;
9896
9897         if (getcwd(def, sizeof def,0) == NULL) {
9898             PerlMem_free(unixified);
9899             PerlMem_free(unixwild);
9900             PerlMem_free(lcres);
9901             PerlMem_free(tpl);
9902             return 0;
9903         }
9904         if (!decc_efs_case_preserve) {
9905           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9906             if (_tolower(*cp1) != _tolower(*cp2)) break;
9907         }
9908         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9909         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9910         if (*cp1 == '\0' && *cp2 == '/') {
9911           memmove(fspec,cp2+1,end - cp2);
9912           PerlMem_free(tpl);
9913           PerlMem_free(unixified);
9914           PerlMem_free(unixwild);
9915           PerlMem_free(lcres);
9916           return 1;
9917         }
9918         /* Nope -- stick with lcfront from above and keep going. */
9919       }
9920     }
9921     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9922     PerlMem_free(tpl);
9923     PerlMem_free(unixified);
9924     PerlMem_free(unixwild);
9925     PerlMem_free(lcres);
9926     return 1;
9927   }
9928
9929 }  /* end of trim_unixpath() */
9930 /*}}}*/
9931
9932
9933 /*
9934  *  VMS readdir() routines.
9935  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9936  *
9937  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9938  *  Minor modifications to original routines.
9939  */
9940
9941 /* readdir may have been redefined by reentr.h, so make sure we get
9942  * the local version for what we do here.
9943  */
9944 #ifdef readdir
9945 # undef readdir
9946 #endif
9947 #if !defined(PERL_IMPLICIT_CONTEXT)
9948 # define readdir Perl_readdir
9949 #else
9950 # define readdir(a) Perl_readdir(aTHX_ a)
9951 #endif
9952
9953     /* Number of elements in vms_versions array */
9954 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9955
9956 /*
9957  *  Open a directory, return a handle for later use.
9958  */
9959 /*{{{ DIR *opendir(char*name) */
9960 DIR *
9961 Perl_opendir(pTHX_ const char *name)
9962 {
9963     DIR *dd;
9964     char *dir;
9965     Stat_t sb;
9966
9967     Newx(dir, VMS_MAXRSS, char);
9968     if (int_tovmspath(name, dir, NULL) == NULL) {
9969       Safefree(dir);
9970       return NULL;
9971     }
9972     /* Check access before stat; otherwise stat does not
9973      * accurately report whether it's a directory.
9974      */
9975     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9976       /* cando_by_name has already set errno */
9977       Safefree(dir);
9978       return NULL;
9979     }
9980     if (flex_stat(dir,&sb) == -1) return NULL;
9981     if (!S_ISDIR(sb.st_mode)) {
9982       Safefree(dir);
9983       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9984       return NULL;
9985     }
9986     /* Get memory for the handle, and the pattern. */
9987     Newx(dd,1,DIR);
9988     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9989
9990     /* Fill in the fields; mainly playing with the descriptor. */
9991     sprintf(dd->pattern, "%s*.*",dir);
9992     Safefree(dir);
9993     dd->context = 0;
9994     dd->count = 0;
9995     dd->flags = 0;
9996     /* By saying we always want the result of readdir() in unix format, we
9997      * are really saying we want all the escapes removed.  Otherwise the caller,
9998      * having no way to know whether it's already in VMS format, might send it
9999      * through tovmsspec again, thus double escaping.
10000      */
10001     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10002     dd->pat.dsc$a_pointer = dd->pattern;
10003     dd->pat.dsc$w_length = strlen(dd->pattern);
10004     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10005     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10006 #if defined(USE_ITHREADS)
10007     Newx(dd->mutex,1,perl_mutex);
10008     MUTEX_INIT( (perl_mutex *) dd->mutex );
10009 #else
10010     dd->mutex = NULL;
10011 #endif
10012
10013     return dd;
10014 }  /* end of opendir() */
10015 /*}}}*/
10016
10017 /*
10018  *  Set the flag to indicate we want versions or not.
10019  */
10020 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10021 void
10022 vmsreaddirversions(DIR *dd, int flag)
10023 {
10024     if (flag)
10025         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10026     else
10027         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10028 }
10029 /*}}}*/
10030
10031 /*
10032  *  Free up an opened directory.
10033  */
10034 /*{{{ void closedir(DIR *dd)*/
10035 void
10036 Perl_closedir(DIR *dd)
10037 {
10038     int sts;
10039
10040     sts = lib$find_file_end(&dd->context);
10041     Safefree(dd->pattern);
10042 #if defined(USE_ITHREADS)
10043     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10044     Safefree(dd->mutex);
10045 #endif
10046     Safefree(dd);
10047 }
10048 /*}}}*/
10049
10050 /*
10051  *  Collect all the version numbers for the current file.
10052  */
10053 static void
10054 collectversions(pTHX_ DIR *dd)
10055 {
10056     struct dsc$descriptor_s     pat;
10057     struct dsc$descriptor_s     res;
10058     struct dirent *e;
10059     char *p, *text, *buff;
10060     int i;
10061     unsigned long context, tmpsts;
10062
10063     /* Convenient shorthand. */
10064     e = &dd->entry;
10065
10066     /* Add the version wildcard, ignoring the "*.*" put on before */
10067     i = strlen(dd->pattern);
10068     Newx(text,i + e->d_namlen + 3,char);
10069     my_strlcpy(text, dd->pattern, i + 1);
10070     sprintf(&text[i - 3], "%s;*", e->d_name);
10071
10072     /* Set up the pattern descriptor. */
10073     pat.dsc$a_pointer = text;
10074     pat.dsc$w_length = i + e->d_namlen - 1;
10075     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10076     pat.dsc$b_class = DSC$K_CLASS_S;
10077
10078     /* Set up result descriptor. */
10079     Newx(buff, VMS_MAXRSS, char);
10080     res.dsc$a_pointer = buff;
10081     res.dsc$w_length = VMS_MAXRSS - 1;
10082     res.dsc$b_dtype = DSC$K_DTYPE_T;
10083     res.dsc$b_class = DSC$K_CLASS_S;
10084
10085     /* Read files, collecting versions. */
10086     for (context = 0, e->vms_verscount = 0;
10087          e->vms_verscount < VERSIZE(e);
10088          e->vms_verscount++) {
10089         unsigned long rsts;
10090         unsigned long flags = 0;
10091
10092 #ifdef VMS_LONGNAME_SUPPORT
10093         flags = LIB$M_FIL_LONG_NAMES;
10094 #endif
10095         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10096         if (tmpsts == RMS$_NMF || context == 0) break;
10097         _ckvmssts(tmpsts);
10098         buff[VMS_MAXRSS - 1] = '\0';
10099         if ((p = strchr(buff, ';')))
10100             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10101         else
10102             e->vms_versions[e->vms_verscount] = -1;
10103     }
10104
10105     _ckvmssts(lib$find_file_end(&context));
10106     Safefree(text);
10107     Safefree(buff);
10108
10109 }  /* end of collectversions() */
10110
10111 /*
10112  *  Read the next entry from the directory.
10113  */
10114 /*{{{ struct dirent *readdir(DIR *dd)*/
10115 struct dirent *
10116 Perl_readdir(pTHX_ DIR *dd)
10117 {
10118     struct dsc$descriptor_s     res;
10119     char *p, *buff;
10120     unsigned long int tmpsts;
10121     unsigned long rsts;
10122     unsigned long flags = 0;
10123     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10124     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10125
10126     /* Set up result descriptor, and get next file. */
10127     Newx(buff, VMS_MAXRSS, char);
10128     res.dsc$a_pointer = buff;
10129     res.dsc$w_length = VMS_MAXRSS - 1;
10130     res.dsc$b_dtype = DSC$K_DTYPE_T;
10131     res.dsc$b_class = DSC$K_CLASS_S;
10132
10133 #ifdef VMS_LONGNAME_SUPPORT
10134     flags = LIB$M_FIL_LONG_NAMES;
10135 #endif
10136
10137     tmpsts = lib$find_file
10138         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10139     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10140     if (!(tmpsts & 1)) {
10141       set_vaxc_errno(tmpsts);
10142       switch (tmpsts) {
10143         case RMS$_PRV:
10144           set_errno(EACCES); break;
10145         case RMS$_DEV:
10146           set_errno(ENODEV); break;
10147         case RMS$_DIR:
10148           set_errno(ENOTDIR); break;
10149         case RMS$_FNF: case RMS$_DNF:
10150           set_errno(ENOENT); break;
10151         default:
10152           set_errno(EVMSERR);
10153       }
10154       Safefree(buff);
10155       return NULL;
10156     }
10157     dd->count++;
10158     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10159     buff[res.dsc$w_length] = '\0';
10160     p = buff + res.dsc$w_length;
10161     while (--p >= buff) if (!isspace(*p)) break;
10162     *p = '\0';
10163     if (!decc_efs_case_preserve) {
10164       for (p = buff; *p; p++) *p = _tolower(*p);
10165     }
10166
10167     /* Skip any directory component and just copy the name. */
10168     sts = vms_split_path
10169        (buff,
10170         &v_spec,
10171         &v_len,
10172         &r_spec,
10173         &r_len,
10174         &d_spec,
10175         &d_len,
10176         &n_spec,
10177         &n_len,
10178         &e_spec,
10179         &e_len,
10180         &vs_spec,
10181         &vs_len);
10182
10183     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10184
10185         /* In Unix report mode, remove the ".dir;1" from the name */
10186         /* if it is a real directory. */
10187         if (decc_filename_unix_report || decc_efs_charset) {
10188             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10189                 Stat_t statbuf;
10190                 int ret_sts;
10191
10192                 ret_sts = flex_lstat(buff, &statbuf);
10193                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10194                     e_len = 0;
10195                     e_spec[0] = 0;
10196                 }
10197             }
10198         }
10199
10200         /* Drop NULL extensions on UNIX file specification */
10201         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10202             e_len = 0;
10203             e_spec[0] = '\0';
10204         }
10205     }
10206
10207     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10208     dd->entry.d_name[n_len + e_len] = '\0';
10209     dd->entry.d_namlen = strlen(dd->entry.d_name);
10210
10211     /* Convert the filename to UNIX format if needed */
10212     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10213
10214         /* Translate the encoded characters. */
10215         /* Fixme: Unicode handling could result in embedded 0 characters */
10216         if (strchr(dd->entry.d_name, '^') != NULL) {
10217             char new_name[256];
10218             char * q;
10219             p = dd->entry.d_name;
10220             q = new_name;
10221             while (*p != 0) {
10222                 int inchars_read, outchars_added;
10223                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10224                 p += inchars_read;
10225                 q += outchars_added;
10226                 /* fix-me */
10227                 /* if outchars_added > 1, then this is a wide file specification */
10228                 /* Wide file specifications need to be passed in Perl */
10229                 /* counted strings apparently with a Unicode flag */
10230             }
10231             *q = 0;
10232             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10233         }
10234     }
10235
10236     dd->entry.vms_verscount = 0;
10237     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10238     Safefree(buff);
10239     return &dd->entry;
10240
10241 }  /* end of readdir() */
10242 /*}}}*/
10243
10244 /*
10245  *  Read the next entry from the directory -- thread-safe version.
10246  */
10247 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10248 int
10249 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10250 {
10251     int retval;
10252
10253     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10254
10255     entry = readdir(dd);
10256     *result = entry;
10257     retval = ( *result == NULL ? errno : 0 );
10258
10259     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10260
10261     return retval;
10262
10263 }  /* end of readdir_r() */
10264 /*}}}*/
10265
10266 /*
10267  *  Return something that can be used in a seekdir later.
10268  */
10269 /*{{{ long telldir(DIR *dd)*/
10270 long
10271 Perl_telldir(DIR *dd)
10272 {
10273     return dd->count;
10274 }
10275 /*}}}*/
10276
10277 /*
10278  *  Return to a spot where we used to be.  Brute force.
10279  */
10280 /*{{{ void seekdir(DIR *dd,long count)*/
10281 void
10282 Perl_seekdir(pTHX_ DIR *dd, long count)
10283 {
10284     int old_flags;
10285
10286     /* If we haven't done anything yet... */
10287     if (dd->count == 0)
10288         return;
10289
10290     /* Remember some state, and clear it. */
10291     old_flags = dd->flags;
10292     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10293     _ckvmssts(lib$find_file_end(&dd->context));
10294     dd->context = 0;
10295
10296     /* The increment is in readdir(). */
10297     for (dd->count = 0; dd->count < count; )
10298         readdir(dd);
10299
10300     dd->flags = old_flags;
10301
10302 }  /* end of seekdir() */
10303 /*}}}*/
10304
10305 /* VMS subprocess management
10306  *
10307  * my_vfork() - just a vfork(), after setting a flag to record that
10308  * the current script is trying a Unix-style fork/exec.
10309  *
10310  * vms_do_aexec() and vms_do_exec() are called in response to the
10311  * perl 'exec' function.  If this follows a vfork call, then they
10312  * call out the regular perl routines in doio.c which do an
10313  * execvp (for those who really want to try this under VMS).
10314  * Otherwise, they do exactly what the perl docs say exec should
10315  * do - terminate the current script and invoke a new command
10316  * (See below for notes on command syntax.)
10317  *
10318  * do_aspawn() and do_spawn() implement the VMS side of the perl
10319  * 'system' function.
10320  *
10321  * Note on command arguments to perl 'exec' and 'system': When handled
10322  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10323  * are concatenated to form a DCL command string.  If the first non-numeric
10324  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10325  * the command string is handed off to DCL directly.  Otherwise,
10326  * the first token of the command is taken as the filespec of an image
10327  * to run.  The filespec is expanded using a default type of '.EXE' and
10328  * the process defaults for device, directory, etc., and if found, the resultant
10329  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10330  * the command string as parameters.  This is perhaps a bit complicated,
10331  * but I hope it will form a happy medium between what VMS folks expect
10332  * from lib$spawn and what Unix folks expect from exec.
10333  */
10334
10335 static int vfork_called;
10336
10337 /*{{{int my_vfork(void)*/
10338 int
10339 my_vfork(void)
10340 {
10341   vfork_called++;
10342   return vfork();
10343 }
10344 /*}}}*/
10345
10346
10347 static void
10348 vms_execfree(struct dsc$descriptor_s *vmscmd)
10349 {
10350   if (vmscmd) {
10351       if (vmscmd->dsc$a_pointer) {
10352           PerlMem_free(vmscmd->dsc$a_pointer);
10353       }
10354       PerlMem_free(vmscmd);
10355   }
10356 }
10357
10358 static char *
10359 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10360 {
10361   char *junk, *tmps = NULL;
10362   size_t cmdlen = 0;
10363   size_t rlen;
10364   SV **idx;
10365   STRLEN n_a;
10366
10367   idx = mark;
10368   if (really) {
10369     tmps = SvPV(really,rlen);
10370     if (*tmps) {
10371       cmdlen += rlen + 1;
10372       idx++;
10373     }
10374   }
10375
10376   for (idx++; idx <= sp; idx++) {
10377     if (*idx) {
10378       junk = SvPVx(*idx,rlen);
10379       cmdlen += rlen ? rlen + 1 : 0;
10380     }
10381   }
10382   Newx(PL_Cmd, cmdlen+1, char);
10383
10384   if (tmps && *tmps) {
10385     my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10386     mark++;
10387   }
10388   else *PL_Cmd = '\0';
10389   while (++mark <= sp) {
10390     if (*mark) {
10391       char *s = SvPVx(*mark,n_a);
10392       if (!*s) continue;
10393       if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10394       my_strlcat(PL_Cmd, s, cmdlen+1);
10395     }
10396   }
10397   return PL_Cmd;
10398
10399 }  /* end of setup_argstr() */
10400
10401
10402 static unsigned long int
10403 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10404                    struct dsc$descriptor_s **pvmscmd)
10405 {
10406   char * vmsspec;
10407   char * resspec;
10408   char image_name[NAM$C_MAXRSS+1];
10409   char image_argv[NAM$C_MAXRSS+1];
10410   $DESCRIPTOR(defdsc,".EXE");
10411   $DESCRIPTOR(defdsc2,".");
10412   struct dsc$descriptor_s resdsc;
10413   struct dsc$descriptor_s *vmscmd;
10414   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10415   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10416   char *s, *rest, *cp, *wordbreak;
10417   char * cmd;
10418   int cmdlen;
10419   int isdcl;
10420
10421   vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10422   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10423
10424   /* vmsspec is a DCL command buffer, not just a filename */
10425   vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10426   if (vmsspec == NULL)
10427       _ckvmssts_noperl(SS$_INSFMEM);
10428
10429   resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10430   if (resspec == NULL)
10431       _ckvmssts_noperl(SS$_INSFMEM);
10432
10433   /* Make a copy for modification */
10434   cmdlen = strlen(incmd);
10435   cmd = (char *)PerlMem_malloc(cmdlen+1);
10436   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10437   my_strlcpy(cmd, incmd, cmdlen + 1);
10438   image_name[0] = 0;
10439   image_argv[0] = 0;
10440
10441   resdsc.dsc$a_pointer = resspec;
10442   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10443   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10444   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10445
10446   vmscmd->dsc$a_pointer = NULL;
10447   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10448   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10449   vmscmd->dsc$w_length = 0;
10450   if (pvmscmd) *pvmscmd = vmscmd;
10451
10452   if (suggest_quote) *suggest_quote = 0;
10453
10454   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10455     PerlMem_free(cmd);
10456     PerlMem_free(vmsspec);
10457     PerlMem_free(resspec);
10458     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10459   }
10460
10461   s = cmd;
10462
10463   while (*s && isspace(*s)) s++;
10464
10465   if (*s == '@' || *s == '$') {
10466     vmsspec[0] = *s;  rest = s + 1;
10467     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10468   }
10469   else { cp = vmsspec; rest = s; }
10470
10471   /* If the first word is quoted, then we need to unquote it and
10472    * escape spaces within it.  We'll expand into the resspec buffer,
10473    * then copy back into the cmd buffer, expanding the latter if
10474    * necessary.
10475    */
10476   if (*rest == '"') {
10477     char *cp2;
10478     char *r = rest;
10479     bool in_quote = 0;
10480     int clen = cmdlen;
10481     int soff = s - cmd;
10482
10483     for (cp2 = resspec;
10484          *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10485          rest++) {
10486
10487       if (*rest == ' ') {    /* Escape ' ' to '^_'. */
10488         *cp2 = '^';
10489         *(++cp2) = '_';
10490         cp2++;
10491         clen++;
10492       }
10493       else if (*rest == '"') {
10494         clen--;
10495         if (in_quote) {     /* Must be closing quote. */
10496           rest++;
10497           break;
10498         }
10499         in_quote = 1;
10500       }
10501       else {
10502         *cp2 = *rest;
10503         cp2++;
10504       }
10505     }
10506     *cp2 = '\0';
10507
10508     /* Expand the command buffer if necessary. */
10509     if (clen > cmdlen) {
10510       cmd = (char *)PerlMem_realloc(cmd, clen);
10511       if (cmd == NULL)
10512         _ckvmssts_noperl(SS$_INSFMEM);
10513       /* Where we are may have changed, so recompute offsets */
10514       r = cmd + (r - s - soff);
10515       rest = cmd + (rest - s - soff);
10516       s = cmd + soff;
10517     }
10518
10519     /* Shift the non-verb portion of the command (if any) up or
10520      * down as necessary.
10521      */
10522     if (*rest)
10523       memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10524
10525     /* Copy the unquoted and escaped command verb into place. */
10526     memcpy(r, resspec, cp2 - resspec);
10527     cmd[clen] = '\0';
10528     cmdlen = clen;
10529     rest = r;         /* Rewind for subsequent operations. */
10530   }
10531
10532   if (*rest == '.' || *rest == '/') {
10533     char *cp2;
10534     for (cp2 = resspec;
10535          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10536          rest++, cp2++) *cp2 = *rest;
10537     *cp2 = '\0';
10538     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10539       s = vmsspec;
10540
10541       /* When a UNIX spec with no file type is translated to VMS, */
10542       /* A trailing '.' is appended under ODS-5 rules.            */
10543       /* Here we do not want that trailing "." as it prevents     */
10544       /* Looking for a implied ".exe" type. */
10545       if (decc_efs_charset) {
10546           int i;
10547           i = strlen(vmsspec);
10548           if (vmsspec[i-1] == '.') {
10549               vmsspec[i-1] = '\0';
10550           }
10551       }
10552
10553       if (*rest) {
10554         for (cp2 = vmsspec + strlen(vmsspec);
10555              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10556              rest++, cp2++) *cp2 = *rest;
10557         *cp2 = '\0';
10558       }
10559     }
10560   }
10561   /* Intuit whether verb (first word of cmd) is a DCL command:
10562    *   - if first nonspace char is '@', it's a DCL indirection
10563    * otherwise
10564    *   - if verb contains a filespec separator, it's not a DCL command
10565    *   - if it doesn't, caller tells us whether to default to a DCL
10566    *     command, or to a local image unless told it's DCL (by leading '$')
10567    */
10568   if (*s == '@') {
10569       isdcl = 1;
10570       if (suggest_quote) *suggest_quote = 1;
10571   } else {
10572     char *filespec = strpbrk(s,":<[.;");
10573     rest = wordbreak = strpbrk(s," \"\t/");
10574     if (!wordbreak) wordbreak = s + strlen(s);
10575     if (*s == '$') check_img = 0;
10576     if (filespec && (filespec < wordbreak)) isdcl = 0;
10577     else isdcl = !check_img;
10578   }
10579
10580   if (!isdcl) {
10581     int rsts;
10582     imgdsc.dsc$a_pointer = s;
10583     imgdsc.dsc$w_length = wordbreak - s;
10584     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10585     if (!(retsts&1)) {
10586         _ckvmssts_noperl(lib$find_file_end(&cxt));
10587         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10588       if (!(retsts & 1) && *s == '$') {
10589         _ckvmssts_noperl(lib$find_file_end(&cxt));
10590         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10591         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10592         if (!(retsts&1)) {
10593           _ckvmssts_noperl(lib$find_file_end(&cxt));
10594           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10595         }
10596       }
10597     }
10598     _ckvmssts_noperl(lib$find_file_end(&cxt));
10599
10600     if (retsts & 1) {
10601       FILE *fp;
10602       s = resspec;
10603       while (*s && !isspace(*s)) s++;
10604       *s = '\0';
10605
10606       /* check that it's really not DCL with no file extension */
10607       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10608       if (fp) {
10609         char b[256] = {0,0,0,0};
10610         read(fileno(fp), b, 256);
10611         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10612         if (isdcl) {
10613           int shebang_len;
10614
10615           /* Check for script */
10616           shebang_len = 0;
10617           if ((b[0] == '#') && (b[1] == '!'))
10618              shebang_len = 2;
10619 #ifdef ALTERNATE_SHEBANG
10620           else {
10621             shebang_len = strlen(ALTERNATE_SHEBANG);
10622             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10623               char * perlstr;
10624                 perlstr = strstr("perl",b);
10625                 if (perlstr == NULL)
10626                   shebang_len = 0;
10627             }
10628             else
10629               shebang_len = 0;
10630           }
10631 #endif
10632
10633           if (shebang_len > 0) {
10634           int i;
10635           int j;
10636           char tmpspec[NAM$C_MAXRSS + 1];
10637
10638             i = shebang_len;
10639              /* Image is following after white space */
10640             /*--------------------------------------*/
10641             while (isprint(b[i]) && isspace(b[i]))
10642                 i++;
10643
10644             j = 0;
10645             while (isprint(b[i]) && !isspace(b[i])) {
10646                 tmpspec[j++] = b[i++];
10647                 if (j >= NAM$C_MAXRSS)
10648                    break;
10649             }
10650             tmpspec[j] = '\0';
10651
10652              /* There may be some default parameters to the image */
10653             /*---------------------------------------------------*/
10654             j = 0;
10655             while (isprint(b[i])) {
10656                 image_argv[j++] = b[i++];
10657                 if (j >= NAM$C_MAXRSS)
10658                    break;
10659             }
10660             while ((j > 0) && !isprint(image_argv[j-1]))
10661                 j--;
10662             image_argv[j] = 0;
10663
10664             /* It will need to be converted to VMS format and validated */
10665             if (tmpspec[0] != '\0') {
10666               char * iname;
10667
10668                /* Try to find the exact program requested to be run */
10669               /*---------------------------------------------------*/
10670               iname = int_rmsexpand
10671                  (tmpspec, image_name, ".exe",
10672                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10673               if (iname != NULL) {
10674                 if (cando_by_name_int
10675                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10676                   /* MCR prefix needed */
10677                   isdcl = 0;
10678                 }
10679                 else {
10680                    /* Try again with a null type */
10681                   /*----------------------------*/
10682                   iname = int_rmsexpand
10683                     (tmpspec, image_name, ".",
10684                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10685                   if (iname != NULL) {
10686                     if (cando_by_name_int
10687                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10688                       /* MCR prefix needed */
10689                       isdcl = 0;
10690                     }
10691                   }
10692                 }
10693
10694                  /* Did we find the image to run the script? */
10695                 /*------------------------------------------*/
10696                 if (isdcl) {
10697                   char *tchr;
10698
10699                    /* Assume DCL or foreign command exists */
10700                   /*--------------------------------------*/
10701                   tchr = strrchr(tmpspec, '/');
10702                   if (tchr != NULL) {
10703                     tchr++;
10704                   }
10705                   else {
10706                     tchr = tmpspec;
10707                   }
10708                   my_strlcpy(image_name, tchr, sizeof(image_name));
10709                 }
10710               }
10711             }
10712           }
10713         }
10714         fclose(fp);
10715       }
10716       if (check_img && isdcl) {
10717           PerlMem_free(cmd);
10718           PerlMem_free(resspec);
10719           PerlMem_free(vmsspec);
10720           return RMS$_FNF;
10721       }
10722
10723       if (cando_by_name(S_IXUSR,0,resspec)) {
10724         vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10725         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10726         if (!isdcl) {
10727             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10728             if (image_name[0] != 0) {
10729                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10730                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10731             }
10732         } else if (image_name[0] != 0) {
10733             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10734             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10735         } else {
10736             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10737         }
10738         if (suggest_quote) *suggest_quote = 1;
10739
10740         /* If there is an image name, use original command */
10741         if (image_name[0] == 0)
10742             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10743         else {
10744             rest = cmd;
10745             while (*rest && isspace(*rest)) rest++;
10746         }
10747
10748         if (image_argv[0] != 0) {
10749           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10750           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10751         }
10752         if (rest) {
10753            int rest_len;
10754            int vmscmd_len;
10755
10756            rest_len = strlen(rest);
10757            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10758            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10759               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10760            else
10761              retsts = CLI$_BUFOVF;
10762         }
10763         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10764         PerlMem_free(cmd);
10765         PerlMem_free(vmsspec);
10766         PerlMem_free(resspec);
10767         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10768       }
10769       else
10770         retsts = RMS$_PRV;
10771     }
10772   }
10773   /* It's either a DCL command or we couldn't find a suitable image */
10774   vmscmd->dsc$w_length = strlen(cmd);
10775
10776   vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10777   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10778
10779   PerlMem_free(cmd);
10780   PerlMem_free(resspec);
10781   PerlMem_free(vmsspec);
10782
10783   /* check if it's a symbol (for quoting purposes) */
10784   if (suggest_quote && !*suggest_quote) {
10785     int iss;
10786     char equiv[LNM$C_NAMLENGTH];
10787     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10788     eqvdsc.dsc$a_pointer = equiv;
10789
10790     iss = lib$get_symbol(vmscmd,&eqvdsc);
10791     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10792   }
10793   if (!(retsts & 1)) {
10794     /* just hand off status values likely to be due to user error */
10795     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10796         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10797        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10798     else { _ckvmssts_noperl(retsts); }
10799   }
10800
10801   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10802
10803 }  /* end of setup_cmddsc() */
10804
10805
10806 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10807 bool
10808 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10809 {
10810 bool exec_sts;
10811 char * cmd;
10812
10813   if (sp > mark) {
10814     if (vfork_called) {           /* this follows a vfork - act Unixish */
10815       vfork_called--;
10816       if (vfork_called < 0) {
10817         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10818         vfork_called = 0;
10819       }
10820       else return do_aexec(really,mark,sp);
10821     }
10822                                            /* no vfork - act VMSish */
10823     cmd = setup_argstr(aTHX_ really,mark,sp);
10824     exec_sts = vms_do_exec(cmd);
10825     Safefree(cmd);  /* Clean up from setup_argstr() */
10826     return exec_sts;
10827   }
10828
10829   return FALSE;
10830 }  /* end of vms_do_aexec() */
10831 /*}}}*/
10832
10833 /* {{{bool vms_do_exec(char *cmd) */
10834 bool
10835 Perl_vms_do_exec(pTHX_ const char *cmd)
10836 {
10837   struct dsc$descriptor_s *vmscmd;
10838
10839   if (vfork_called) {             /* this follows a vfork - act Unixish */
10840     vfork_called--;
10841     if (vfork_called < 0) {
10842       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10843       vfork_called = 0;
10844     }
10845     else return do_exec(cmd);
10846   }
10847
10848   {                               /* no vfork - act VMSish */
10849     unsigned long int retsts;
10850
10851     TAINT_ENV();
10852     TAINT_PROPER("exec");
10853     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10854       retsts = lib$do_command(vmscmd);
10855
10856     switch (retsts) {
10857       case RMS$_FNF: case RMS$_DNF:
10858         set_errno(ENOENT); break;
10859       case RMS$_DIR:
10860         set_errno(ENOTDIR); break;
10861       case RMS$_DEV:
10862         set_errno(ENODEV); break;
10863       case RMS$_PRV:
10864         set_errno(EACCES); break;
10865       case RMS$_SYN:
10866         set_errno(EINVAL); break;
10867       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10868         set_errno(E2BIG); break;
10869       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10870         _ckvmssts_noperl(retsts); /* fall through */
10871       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10872         set_errno(EVMSERR);
10873     }
10874     set_vaxc_errno(retsts);
10875     if (ckWARN(WARN_EXEC)) {
10876       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10877              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10878     }
10879     vms_execfree(vmscmd);
10880   }
10881
10882   return FALSE;
10883
10884 }  /* end of vms_do_exec() */
10885 /*}}}*/
10886
10887 int do_spawn2(pTHX_ const char *, int);
10888
10889 int
10890 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10891 {
10892 unsigned long int sts;
10893 char * cmd;
10894 int flags = 0;
10895
10896   if (sp > mark) {
10897
10898     /* We'll copy the (undocumented?) Win32 behavior and allow a
10899      * numeric first argument.  But the only value we'll support
10900      * through do_aspawn is a value of 1, which means spawn without
10901      * waiting for completion -- other values are ignored.
10902      */
10903     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10904         ++mark;
10905         flags = SvIVx(*mark);
10906     }
10907
10908     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10909         flags = CLI$M_NOWAIT;
10910     else
10911         flags = 0;
10912
10913     cmd = setup_argstr(aTHX_ really, mark, sp);
10914     sts = do_spawn2(aTHX_ cmd, flags);
10915     /* pp_sys will clean up cmd */
10916     return sts;
10917   }
10918   return SS$_ABORT;
10919 }  /* end of do_aspawn() */
10920 /*}}}*/
10921
10922
10923 /* {{{int do_spawn(char* cmd) */
10924 int
10925 Perl_do_spawn(pTHX_ char* cmd)
10926 {
10927     PERL_ARGS_ASSERT_DO_SPAWN;
10928
10929     return do_spawn2(aTHX_ cmd, 0);
10930 }
10931 /*}}}*/
10932
10933 /* {{{int do_spawn_nowait(char* cmd) */
10934 int
10935 Perl_do_spawn_nowait(pTHX_ char* cmd)
10936 {
10937     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10938
10939     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10940 }
10941 /*}}}*/
10942
10943 /* {{{int do_spawn2(char *cmd) */
10944 int
10945 do_spawn2(pTHX_ const char *cmd, int flags)
10946 {
10947   unsigned long int sts, substs;
10948
10949   /* The caller of this routine expects to Safefree(PL_Cmd) */
10950   Newx(PL_Cmd,10,char);
10951
10952   TAINT_ENV();
10953   TAINT_PROPER("spawn");
10954   if (!cmd || !*cmd) {
10955     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10956     if (!(sts & 1)) {
10957       switch (sts) {
10958         case RMS$_FNF:  case RMS$_DNF:
10959           set_errno(ENOENT); break;
10960         case RMS$_DIR:
10961           set_errno(ENOTDIR); break;
10962         case RMS$_DEV:
10963           set_errno(ENODEV); break;
10964         case RMS$_PRV:
10965           set_errno(EACCES); break;
10966         case RMS$_SYN:
10967           set_errno(EINVAL); break;
10968         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10969           set_errno(E2BIG); break;
10970         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10971           _ckvmssts_noperl(sts); /* fall through */
10972         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10973           set_errno(EVMSERR);
10974       }
10975       set_vaxc_errno(sts);
10976       if (ckWARN(WARN_EXEC)) {
10977         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10978                     Strerror(errno));
10979       }
10980     }
10981     sts = substs;
10982   }
10983   else {
10984     char mode[3];
10985     PerlIO * fp;
10986     if (flags & CLI$M_NOWAIT)
10987         strcpy(mode, "n");
10988     else
10989         strcpy(mode, "nW");
10990
10991     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10992     if (fp != NULL)
10993       my_pclose(fp);
10994     /* sts will be the pid in the nowait case */
10995   }
10996   return sts;
10997 }  /* end of do_spawn2() */
10998 /*}}}*/
10999
11000
11001 static unsigned int *sockflags, sockflagsize;
11002
11003 /*
11004  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11005  * routines found in some versions of the CRTL can't deal with sockets.
11006  * We don't shim the other file open routines since a socket isn't
11007  * likely to be opened by a name.
11008  */
11009 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11010 FILE *my_fdopen(int fd, const char *mode)
11011 {
11012   FILE *fp = fdopen(fd, mode);
11013
11014   if (fp) {
11015     unsigned int fdoff = fd / sizeof(unsigned int);
11016     Stat_t sbuf; /* native stat; we don't need flex_stat */
11017     if (!sockflagsize || fdoff > sockflagsize) {
11018       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11019       else           Newx  (sockflags,fdoff+2,unsigned int);
11020       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11021       sockflagsize = fdoff + 2;
11022     }
11023     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11024       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11025   }
11026   return fp;
11027
11028 }
11029 /*}}}*/
11030
11031
11032 /*
11033  * Clear the corresponding bit when the (possibly) socket stream is closed.
11034  * There still a small hole: we miss an implicit close which might occur
11035  * via freopen().  >> Todo
11036  */
11037 /*{{{ int my_fclose(FILE *fp)*/
11038 int my_fclose(FILE *fp) {
11039   if (fp) {
11040     unsigned int fd = fileno(fp);
11041     unsigned int fdoff = fd / sizeof(unsigned int);
11042
11043     if (sockflagsize && fdoff < sockflagsize)
11044       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11045   }
11046   return fclose(fp);
11047 }
11048 /*}}}*/
11049
11050
11051 /*
11052  * A simple fwrite replacement which outputs itmsz*nitm chars without
11053  * introducing record boundaries every itmsz chars.
11054  * We are using fputs, which depends on a terminating null.  We may
11055  * well be writing binary data, so we need to accommodate not only
11056  * data with nulls sprinkled in the middle but also data with no null
11057  * byte at the end.
11058  */
11059 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11060 int
11061 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11062 {
11063   char *cp, *end, *cpd;
11064   char *data;
11065   unsigned int fd = fileno(dest);
11066   unsigned int fdoff = fd / sizeof(unsigned int);
11067   int retval;
11068   int bufsize = itmsz * nitm + 1;
11069
11070   if (fdoff < sockflagsize &&
11071       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11072     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11073     return nitm;
11074   }
11075
11076   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11077   memcpy( data, src, itmsz*nitm );
11078   data[itmsz*nitm] = '\0';
11079
11080   end = data + itmsz * nitm;
11081   retval = (int) nitm; /* on success return # items written */
11082
11083   cpd = data;
11084   while (cpd <= end) {
11085     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11086     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11087     if (cp < end)
11088       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11089     cpd = cp + 1;
11090   }
11091
11092   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11093   return retval;
11094
11095 }  /* end of my_fwrite() */
11096 /*}}}*/
11097
11098 /*{{{ int my_flush(FILE *fp)*/
11099 int
11100 Perl_my_flush(pTHX_ FILE *fp)
11101 {
11102     int res;
11103     if ((res = fflush(fp)) == 0 && fp) {
11104 #ifdef VMS_DO_SOCKETS
11105         Stat_t s;
11106         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11107 #endif
11108             res = fsync(fileno(fp));
11109     }
11110 /*
11111  * If the flush succeeded but set end-of-file, we need to clear
11112  * the error because our caller may check ferror().  BTW, this
11113  * probably means we just flushed an empty file.
11114  */
11115     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11116
11117     return res;
11118 }
11119 /*}}}*/
11120
11121 /* fgetname() is not returning the correct file specifications when
11122  * decc_filename_unix_report mode is active.  So we have to have it
11123  * aways return filenames in VMS mode and convert it ourselves.
11124  */
11125
11126 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11127 char *
11128 Perl_my_fgetname(FILE *fp, char * buf) {
11129     char * retname;
11130     char * vms_name;
11131
11132     retname = fgetname(fp, buf, 1);
11133
11134     /* If we are in VMS mode, then we are done */
11135     if (!decc_filename_unix_report || (retname == NULL)) {
11136        return retname;
11137     }
11138
11139     /* Convert this to Unix format */
11140     vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11141     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11142     retname = int_tounixspec(vms_name, buf, NULL);
11143     PerlMem_free(vms_name);
11144
11145     return retname;
11146 }
11147 /*}}}*/
11148
11149 /*
11150  * Here are replacements for the following Unix routines in the VMS environment:
11151  *      getpwuid    Get information for a particular UIC or UID
11152  *      getpwnam    Get information for a named user
11153  *      getpwent    Get information for each user in the rights database
11154  *      setpwent    Reset search to the start of the rights database
11155  *      endpwent    Finish searching for users in the rights database
11156  *
11157  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11158  * (defined in pwd.h), which contains the following fields:-
11159  *      struct passwd {
11160  *              char        *pw_name;    Username (in lower case)
11161  *              char        *pw_passwd;  Hashed password
11162  *              unsigned int pw_uid;     UIC
11163  *              unsigned int pw_gid;     UIC group  number
11164  *              char        *pw_unixdir; Default device/directory (VMS-style)
11165  *              char        *pw_gecos;   Owner name
11166  *              char        *pw_dir;     Default device/directory (Unix-style)
11167  *              char        *pw_shell;   Default CLI name (eg. DCL)
11168  *      };
11169  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11170  *
11171  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11172  * not the UIC member number (eg. what's returned by getuid()),
11173  * getpwuid() can accept either as input (if uid is specified, the caller's
11174  * UIC group is used), though it won't recognise gid=0.
11175  *
11176  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11177  * information about other users in your group or in other groups, respectively.
11178  * If the required privilege is not available, then these routines fill only
11179  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11180  * string).
11181  *
11182  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11183  */
11184
11185 /* sizes of various UAF record fields */
11186 #define UAI$S_USERNAME 12
11187 #define UAI$S_IDENT    31
11188 #define UAI$S_OWNER    31
11189 #define UAI$S_DEFDEV   31
11190 #define UAI$S_DEFDIR   63
11191 #define UAI$S_DEFCLI   31
11192 #define UAI$S_PWD       8
11193
11194 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11195                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11196                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11197
11198 static char __empty[]= "";
11199 static struct passwd __passwd_empty=
11200     {(char *) __empty, (char *) __empty, 0, 0,
11201      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11202 static int contxt= 0;
11203 static struct passwd __pwdcache;
11204 static char __pw_namecache[UAI$S_IDENT+1];
11205
11206 /*
11207  * This routine does most of the work extracting the user information.
11208  */
11209 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11210 {
11211     static struct {
11212         unsigned char length;
11213         char pw_gecos[UAI$S_OWNER+1];
11214     } owner;
11215     static union uicdef uic;
11216     static struct {
11217         unsigned char length;
11218         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11219     } defdev;
11220     static struct {
11221         unsigned char length;
11222         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11223     } defdir;
11224     static struct {
11225         unsigned char length;
11226         char pw_shell[UAI$S_DEFCLI+1];
11227     } defcli;
11228     static char pw_passwd[UAI$S_PWD+1];
11229
11230     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11231     struct dsc$descriptor_s name_desc;
11232     unsigned long int sts;
11233
11234     static struct itmlst_3 itmlst[]= {
11235         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11236         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11237         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11238         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11239         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11240         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11241         {0,                0,           NULL,    NULL}};
11242
11243     name_desc.dsc$w_length=  strlen(name);
11244     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11245     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11246     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11247
11248 /*  Note that sys$getuai returns many fields as counted strings. */
11249     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11250     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11251       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11252     }
11253     else { _ckvmssts(sts); }
11254     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11255
11256     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11257     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11258     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11259     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11260     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11261     owner.pw_gecos[lowner]=            '\0';
11262     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11263     defcli.pw_shell[ldefcli]=          '\0';
11264     if (valid_uic(uic)) {
11265         pwd->pw_uid= uic.uic$l_uic;
11266         pwd->pw_gid= uic.uic$v_group;
11267     }
11268     else
11269       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11270     pwd->pw_passwd=  pw_passwd;
11271     pwd->pw_gecos=   owner.pw_gecos;
11272     pwd->pw_dir=     defdev.pw_dir;
11273     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11274     pwd->pw_shell=   defcli.pw_shell;
11275     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11276         int ldir;
11277         ldir= strlen(pwd->pw_unixdir) - 1;
11278         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11279     }
11280     else
11281         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11282     if (!decc_efs_case_preserve)
11283         __mystrtolower(pwd->pw_unixdir);
11284     return 1;
11285 }
11286
11287 /*
11288  * Get information for a named user.
11289 */
11290 /*{{{struct passwd *getpwnam(char *name)*/
11291 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11292 {
11293     struct dsc$descriptor_s name_desc;
11294     union uicdef uic;
11295     unsigned long int sts;
11296
11297     __pwdcache = __passwd_empty;
11298     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11299       /* We still may be able to determine pw_uid and pw_gid */
11300       name_desc.dsc$w_length=  strlen(name);
11301       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11302       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11303       name_desc.dsc$a_pointer= (char *) name;
11304       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11305         __pwdcache.pw_uid= uic.uic$l_uic;
11306         __pwdcache.pw_gid= uic.uic$v_group;
11307       }
11308       else {
11309         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11310           set_vaxc_errno(sts);
11311           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11312           return NULL;
11313         }
11314         else { _ckvmssts(sts); }
11315       }
11316     }
11317     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11318     __pwdcache.pw_name= __pw_namecache;
11319     return &__pwdcache;
11320 }  /* end of my_getpwnam() */
11321 /*}}}*/
11322
11323 /*
11324  * Get information for a particular UIC or UID.
11325  * Called by my_getpwent with uid=-1 to list all users.
11326 */
11327 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11328 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11329 {
11330     const $DESCRIPTOR(name_desc,__pw_namecache);
11331     unsigned short lname;
11332     union uicdef uic;
11333     unsigned long int status;
11334
11335     if (uid == (unsigned int) -1) {
11336       do {
11337         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11338         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11339           set_vaxc_errno(status);
11340           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11341           my_endpwent();
11342           return NULL;
11343         }
11344         else { _ckvmssts(status); }
11345       } while (!valid_uic (uic));
11346     }
11347     else {
11348       uic.uic$l_uic= uid;
11349       if (!uic.uic$v_group)
11350         uic.uic$v_group= PerlProc_getgid();
11351       if (valid_uic(uic))
11352         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11353       else status = SS$_IVIDENT;
11354       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11355           status == RMS$_PRV) {
11356         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11357         return NULL;
11358       }
11359       else { _ckvmssts(status); }
11360     }
11361     __pw_namecache[lname]= '\0';
11362     __mystrtolower(__pw_namecache);
11363
11364     __pwdcache = __passwd_empty;
11365     __pwdcache.pw_name = __pw_namecache;
11366
11367 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11368     The identifier's value is usually the UIC, but it doesn't have to be,
11369     so if we can, we let fillpasswd update this. */
11370     __pwdcache.pw_uid =  uic.uic$l_uic;
11371     __pwdcache.pw_gid =  uic.uic$v_group;
11372
11373     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11374     return &__pwdcache;
11375
11376 }  /* end of my_getpwuid() */
11377 /*}}}*/
11378
11379 /*
11380  * Get information for next user.
11381 */
11382 /*{{{struct passwd *my_getpwent()*/
11383 struct passwd *Perl_my_getpwent(pTHX)
11384 {
11385     return (my_getpwuid((unsigned int) -1));
11386 }
11387 /*}}}*/
11388
11389 /*
11390  * Finish searching rights database for users.
11391 */
11392 /*{{{void my_endpwent()*/
11393 void Perl_my_endpwent(pTHX)
11394 {
11395     if (contxt) {
11396       _ckvmssts(sys$finish_rdb(&contxt));
11397       contxt= 0;
11398     }
11399 }
11400 /*}}}*/
11401
11402 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11403  * my_utime(), and flex_stat(), all of which operate on UTC unless
11404  * VMSISH_TIMES is true.
11405  */
11406 /* method used to handle UTC conversions:
11407  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11408  */
11409 static int gmtime_emulation_type;
11410 /* number of secs to add to UTC POSIX-style time to get local time */
11411 static long int utc_offset_secs;
11412
11413 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11414  * in vmsish.h.  #undef them here so we can call the CRTL routines
11415  * directly.
11416  */
11417 #undef gmtime
11418 #undef localtime
11419 #undef time
11420
11421
11422 static time_t toutc_dst(time_t loc) {
11423   struct tm *rsltmp;
11424
11425   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11426   loc -= utc_offset_secs;
11427   if (rsltmp->tm_isdst) loc -= 3600;
11428   return loc;
11429 }
11430 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11431        ((gmtime_emulation_type || my_time(NULL)), \
11432        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11433        ((secs) - utc_offset_secs))))
11434
11435 static time_t toloc_dst(time_t utc) {
11436   struct tm *rsltmp;
11437
11438   utc += utc_offset_secs;
11439   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11440   if (rsltmp->tm_isdst) utc += 3600;
11441   return utc;
11442 }
11443 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11444        ((gmtime_emulation_type || my_time(NULL)), \
11445        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11446        ((secs) + utc_offset_secs))))
11447
11448 /* my_time(), my_localtime(), my_gmtime()
11449  * By default traffic in UTC time values, using CRTL gmtime() or
11450  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11451  * Note: We need to use these functions even when the CRTL has working
11452  * UTC support, since they also handle C<use vmsish qw(times);>
11453  *
11454  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11455  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11456  */
11457
11458 /*{{{time_t my_time(time_t *timep)*/
11459 time_t Perl_my_time(pTHX_ time_t *timep)
11460 {
11461   time_t when;
11462   struct tm *tm_p;
11463
11464   if (gmtime_emulation_type == 0) {
11465     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11466                               /* results of calls to gmtime() and localtime() */
11467                               /* for same &base */
11468
11469     gmtime_emulation_type++;
11470     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11471       char off[LNM$C_NAMLENGTH+1];;
11472
11473       gmtime_emulation_type++;
11474       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11475         gmtime_emulation_type++;
11476         utc_offset_secs = 0;
11477         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11478       }
11479       else { utc_offset_secs = atol(off); }
11480     }
11481     else { /* We've got a working gmtime() */
11482       struct tm gmt, local;
11483
11484       gmt = *tm_p;
11485       tm_p = localtime(&base);
11486       local = *tm_p;
11487       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11488       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11489       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11490       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11491     }
11492   }
11493
11494   when = time(NULL);
11495 # ifdef VMSISH_TIME
11496   if (VMSISH_TIME) when = _toloc(when);
11497 # endif
11498   if (timep != NULL) *timep = when;
11499   return when;
11500
11501 }  /* end of my_time() */
11502 /*}}}*/
11503
11504
11505 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11506 struct tm *
11507 Perl_my_gmtime(pTHX_ const time_t *timep)
11508 {
11509   time_t when;
11510   struct tm *rsltmp;
11511
11512   if (timep == NULL) {
11513     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11514     return NULL;
11515   }
11516   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11517
11518   when = *timep;
11519 # ifdef VMSISH_TIME
11520   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11521 #  endif
11522   return gmtime(&when);
11523 }  /* end of my_gmtime() */
11524 /*}}}*/
11525
11526
11527 /*{{{struct tm *my_localtime(const time_t *timep)*/
11528 struct tm *
11529 Perl_my_localtime(pTHX_ const time_t *timep)
11530 {
11531   time_t when;
11532
11533   if (timep == NULL) {
11534     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11535     return NULL;
11536   }
11537   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11538   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11539
11540   when = *timep;
11541 # ifdef VMSISH_TIME
11542   if (VMSISH_TIME) when = _toutc(when);
11543 # endif
11544   /* CRTL localtime() wants UTC as input, does tz correction itself */
11545   return localtime(&when);
11546 } /*  end of my_localtime() */
11547 /*}}}*/
11548
11549 /* Reset definitions for later calls */
11550 #define gmtime(t)    my_gmtime(t)
11551 #define localtime(t) my_localtime(t)
11552 #define time(t)      my_time(t)
11553
11554
11555 /* my_utime - update modification/access time of a file
11556  *
11557  * VMS 7.3 and later implementation
11558  * Only the UTC translation is home-grown. The rest is handled by the
11559  * CRTL utime(), which will take into account the relevant feature
11560  * logicals and ODS-5 volume characteristics for true access times.
11561  *
11562  * pre VMS 7.3 implementation:
11563  * The calling sequence is identical to POSIX utime(), but under
11564  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11565  * not maintain access times.  Restrictions differ from the POSIX
11566  * definition in that the time can be changed as long as the
11567  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11568  * no separate checks are made to insure that the caller is the
11569  * owner of the file or has special privs enabled.
11570  * Code here is based on Joe Meadows' FILE utility.
11571  *
11572  */
11573
11574 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11575  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11576  * in 100 ns intervals.
11577  */
11578 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11579
11580 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11581 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11582 {
11583 #if __CRTL_VER >= 70300000
11584   struct utimbuf utc_utimes, *utc_utimesp;
11585
11586   if (utimes != NULL) {
11587     utc_utimes.actime = utimes->actime;
11588     utc_utimes.modtime = utimes->modtime;
11589 # ifdef VMSISH_TIME
11590     /* If input was local; convert to UTC for sys svc */
11591     if (VMSISH_TIME) {
11592       utc_utimes.actime = _toutc(utimes->actime);
11593       utc_utimes.modtime = _toutc(utimes->modtime);
11594     }
11595 # endif
11596     utc_utimesp = &utc_utimes;
11597   }
11598   else {
11599     utc_utimesp = NULL;
11600   }
11601
11602   return utime(file, utc_utimesp);
11603
11604 #else /* __CRTL_VER < 70300000 */
11605
11606   int i;
11607   int sts;
11608   long int bintime[2], len = 2, lowbit, unixtime,
11609            secscale = 10000000; /* seconds --> 100 ns intervals */
11610   unsigned long int chan, iosb[2], retsts;
11611   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11612   struct FAB myfab = cc$rms_fab;
11613   struct NAM mynam = cc$rms_nam;
11614 #if defined (__DECC) && defined (__VAX)
11615   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11616    * at least through VMS V6.1, which causes a type-conversion warning.
11617    */
11618 #  pragma message save
11619 #  pragma message disable cvtdiftypes
11620 #endif
11621   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11622   struct fibdef myfib;
11623 #if defined (__DECC) && defined (__VAX)
11624   /* This should be right after the declaration of myatr, but due
11625    * to a bug in VAX DEC C, this takes effect a statement early.
11626    */
11627 #  pragma message restore
11628 #endif
11629   /* cast ok for read only parameter */
11630   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11631                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11632                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11633
11634   if (file == NULL || *file == '\0') {
11635     SETERRNO(ENOENT, LIB$_INVARG);
11636     return -1;
11637   }
11638
11639   /* Convert to VMS format ensuring that it will fit in 255 characters */
11640   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11641       SETERRNO(ENOENT, LIB$_INVARG);
11642       return -1;
11643   }
11644   if (utimes != NULL) {
11645     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11646      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11647      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11648      * as input, we force the sign bit to be clear by shifting unixtime right
11649      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11650      */
11651     lowbit = (utimes->modtime & 1) ? secscale : 0;
11652     unixtime = (long int) utimes->modtime;
11653 #   ifdef VMSISH_TIME
11654     /* If input was UTC; convert to local for sys svc */
11655     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11656 #   endif
11657     unixtime >>= 1;  secscale <<= 1;
11658     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11659     if (!(retsts & 1)) {
11660       SETERRNO(EVMSERR, retsts);
11661       return -1;
11662     }
11663     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11664     if (!(retsts & 1)) {
11665       SETERRNO(EVMSERR, retsts);
11666       return -1;
11667     }
11668   }
11669   else {
11670     /* Just get the current time in VMS format directly */
11671     retsts = sys$gettim(bintime);
11672     if (!(retsts & 1)) {
11673       SETERRNO(EVMSERR, retsts);
11674       return -1;
11675     }
11676   }
11677
11678   myfab.fab$l_fna = vmsspec;
11679   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11680   myfab.fab$l_nam = &mynam;
11681   mynam.nam$l_esa = esa;
11682   mynam.nam$b_ess = (unsigned char) sizeof esa;
11683   mynam.nam$l_rsa = rsa;
11684   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11685   if (decc_efs_case_preserve)
11686       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11687
11688   /* Look for the file to be affected, letting RMS parse the file
11689    * specification for us as well.  I have set errno using only
11690    * values documented in the utime() man page for VMS POSIX.
11691    */
11692   retsts = sys$parse(&myfab,0,0);
11693   if (!(retsts & 1)) {
11694     set_vaxc_errno(retsts);
11695     if      (retsts == RMS$_PRV) set_errno(EACCES);
11696     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11697     else                         set_errno(EVMSERR);
11698     return -1;
11699   }
11700   retsts = sys$search(&myfab,0,0);
11701   if (!(retsts & 1)) {
11702     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11703     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11704     set_vaxc_errno(retsts);
11705     if      (retsts == RMS$_PRV) set_errno(EACCES);
11706     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11707     else                         set_errno(EVMSERR);
11708     return -1;
11709   }
11710
11711   devdsc.dsc$w_length = mynam.nam$b_dev;
11712   /* cast ok for read only parameter */
11713   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11714
11715   retsts = sys$assign(&devdsc,&chan,0,0);
11716   if (!(retsts & 1)) {
11717     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11718     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11719     set_vaxc_errno(retsts);
11720     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11721     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11722     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11723     else                               set_errno(EVMSERR);
11724     return -1;
11725   }
11726
11727   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11728   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11729
11730   memset((void *) &myfib, 0, sizeof myfib);
11731 #if defined(__DECC) || defined(__DECCXX)
11732   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11733   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11734   /* This prevents the revision time of the file being reset to the current
11735    * time as a result of our IO$_MODIFY $QIO. */
11736   myfib.fib$l_acctl = FIB$M_NORECORD;
11737 #else
11738   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11739   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11740   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11741 #endif
11742   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11743   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11744   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11745   _ckvmssts(sys$dassgn(chan));
11746   if (retsts & 1) retsts = iosb[0];
11747   if (!(retsts & 1)) {
11748     set_vaxc_errno(retsts);
11749     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11750     else                      set_errno(EVMSERR);
11751     return -1;
11752   }
11753
11754   return 0;
11755
11756 #endif /* #if __CRTL_VER >= 70300000 */
11757
11758 }  /* end of my_utime() */
11759 /*}}}*/
11760
11761 /*
11762  * flex_stat, flex_lstat, flex_fstat
11763  * basic stat, but gets it right when asked to stat
11764  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11765  */
11766
11767 #ifndef _USE_STD_STAT
11768 /* encode_dev packs a VMS device name string into an integer to allow
11769  * simple comparisons. This can be used, for example, to check whether two
11770  * files are located on the same device, by comparing their encoded device
11771  * names. Even a string comparison would not do, because stat() reuses the
11772  * device name buffer for each call; so without encode_dev, it would be
11773  * necessary to save the buffer and use strcmp (this would mean a number of
11774  * changes to the standard Perl code, to say nothing of what a Perl script
11775  * would have to do.
11776  *
11777  * The device lock id, if it exists, should be unique (unless perhaps compared
11778  * with lock ids transferred from other nodes). We have a lock id if the disk is
11779  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11780  * device names. Thus we use the lock id in preference, and only if that isn't
11781  * available, do we try to pack the device name into an integer (flagged by
11782  * the sign bit (LOCKID_MASK) being set).
11783  *
11784  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11785  * name and its encoded form, but it seems very unlikely that we will find
11786  * two files on different disks that share the same encoded device names,
11787  * and even more remote that they will share the same file id (if the test
11788  * is to check for the same file).
11789  *
11790  * A better method might be to use sys$device_scan on the first call, and to
11791  * search for the device, returning an index into the cached array.
11792  * The number returned would be more intelligible.
11793  * This is probably not worth it, and anyway would take quite a bit longer
11794  * on the first call.
11795  */
11796 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11797 static mydev_t encode_dev (pTHX_ const char *dev)
11798 {
11799   int i;
11800   unsigned long int f;
11801   mydev_t enc;
11802   char c;
11803   const char *q;
11804
11805   if (!dev || !dev[0]) return 0;
11806
11807 #if LOCKID_MASK
11808   {
11809     struct dsc$descriptor_s dev_desc;
11810     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11811
11812     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11813        can try that first. */
11814     dev_desc.dsc$w_length =  strlen (dev);
11815     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11816     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11817     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11818     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11819     if (!$VMS_STATUS_SUCCESS(status)) {
11820       switch (status) {
11821         case SS$_NOSUCHDEV:
11822           SETERRNO(ENODEV, status);
11823           return 0;
11824         default:
11825           _ckvmssts(status);
11826       }
11827     }
11828     if (lockid) return (lockid & ~LOCKID_MASK);
11829   }
11830 #endif
11831
11832   /* Otherwise we try to encode the device name */
11833   enc = 0;
11834   f = 1;
11835   i = 0;
11836   for (q = dev + strlen(dev); q--; q >= dev) {
11837     if (*q == ':')
11838         break;
11839     if (isdigit (*q))
11840       c= (*q) - '0';
11841     else if (isalpha (toupper (*q)))
11842       c= toupper (*q) - 'A' + (char)10;
11843     else
11844       continue; /* Skip '$'s */
11845     i++;
11846     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11847     if (i>1) f *= 36;
11848     enc += f * (unsigned long int) c;
11849   }
11850   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11851
11852 }  /* end of encode_dev() */
11853 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11854         device_no = encode_dev(aTHX_ devname)
11855 #else
11856 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11857         device_no = new_dev_no
11858 #endif
11859
11860 static int
11861 is_null_device(const char *name)
11862 {
11863   if (decc_bug_devnull != 0) {
11864     if (strncmp("/dev/null", name, 9) == 0)
11865       return 1;
11866   }
11867     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11868        The underscore prefix, controller letter, and unit number are
11869        independently optional; for our purposes, the colon punctuation
11870        is not.  The colon can be trailed by optional directory and/or
11871        filename, but two consecutive colons indicates a nodename rather
11872        than a device.  [pr]  */
11873   if (*name == '_') ++name;
11874   if (tolower(*name++) != 'n') return 0;
11875   if (tolower(*name++) != 'l') return 0;
11876   if (tolower(*name) == 'a') ++name;
11877   if (*name == '0') ++name;
11878   return (*name++ == ':') && (*name != ':');
11879 }
11880
11881 static int
11882 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11883
11884 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11885
11886 static I32
11887 Perl_cando_by_name_int
11888    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11889 {
11890   char usrname[L_cuserid];
11891   struct dsc$descriptor_s usrdsc =
11892          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11893   char *vmsname = NULL, *fileified = NULL;
11894   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11895   unsigned short int retlen, trnlnm_iter_count;
11896   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11897   union prvdef curprv;
11898   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11899          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11900          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11901   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11902          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11903          {0,0,0,0}};
11904   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11905          {0,0,0,0}};
11906   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11907   Stat_t st;
11908   static int profile_context = -1;
11909
11910   if (!fname || !*fname) return FALSE;
11911
11912   /* Make sure we expand logical names, since sys$check_access doesn't */
11913   fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11914   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11915   if (!strpbrk(fname,"/]>:")) {
11916       my_strlcpy(fileified, fname, VMS_MAXRSS);
11917       trnlnm_iter_count = 0;
11918       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11919         trnlnm_iter_count++;
11920         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11921       }
11922       fname = fileified;
11923   }
11924
11925   vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11926   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11927   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11928     /* Don't know if already in VMS format, so make sure */
11929     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11930       PerlMem_free(fileified);
11931       PerlMem_free(vmsname);
11932       return FALSE;
11933     }
11934   }
11935   else {
11936     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11937   }
11938
11939   /* sys$check_access needs a file spec, not a directory spec.
11940    * flex_stat now will handle a null thread context during startup.
11941    */
11942
11943   retlen = namdsc.dsc$w_length = strlen(vmsname);
11944   if (vmsname[retlen-1] == ']'
11945       || vmsname[retlen-1] == '>'
11946       || vmsname[retlen-1] == ':'
11947       || (!flex_stat_int(vmsname, &st, 1) &&
11948           S_ISDIR(st.st_mode))) {
11949
11950       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11951         PerlMem_free(fileified);
11952         PerlMem_free(vmsname);
11953         return FALSE;
11954       }
11955       fname = fileified;
11956   }
11957   else {
11958       fname = vmsname;
11959   }
11960
11961   retlen = namdsc.dsc$w_length = strlen(fname);
11962   namdsc.dsc$a_pointer = (char *)fname;
11963
11964   switch (bit) {
11965     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11966       access = ARM$M_EXECUTE;
11967       flags = CHP$M_READ;
11968       break;
11969     case S_IRUSR: case S_IRGRP: case S_IROTH:
11970       access = ARM$M_READ;
11971       flags = CHP$M_READ | CHP$M_USEREADALL;
11972       break;
11973     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11974       access = ARM$M_WRITE;
11975       flags = CHP$M_READ | CHP$M_WRITE;
11976       break;
11977     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11978       access = ARM$M_DELETE;
11979       flags = CHP$M_READ | CHP$M_WRITE;
11980       break;
11981     default:
11982       if (fileified != NULL)
11983         PerlMem_free(fileified);
11984       if (vmsname != NULL)
11985         PerlMem_free(vmsname);
11986       return FALSE;
11987   }
11988
11989   /* Before we call $check_access, create a user profile with the current
11990    * process privs since otherwise it just uses the default privs from the
11991    * UAF and might give false positives or negatives.  This only works on
11992    * VMS versions v6.0 and later since that's when sys$create_user_profile
11993    * became available.
11994    */
11995
11996   /* get current process privs and username */
11997   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11998   _ckvmssts_noperl(iosb[0]);
11999
12000   /* find out the space required for the profile */
12001   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12002                                     &usrprodsc.dsc$w_length,&profile_context));
12003
12004   /* allocate space for the profile and get it filled in */
12005   usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
12006   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12007   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12008                                     &usrprodsc.dsc$w_length,&profile_context));
12009
12010   /* use the profile to check access to the file; free profile & analyze results */
12011   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12012   PerlMem_free(usrprodsc.dsc$a_pointer);
12013   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12014
12015   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12016       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12017       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12018     set_vaxc_errno(retsts);
12019     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12020     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12021     else set_errno(ENOENT);
12022     if (fileified != NULL)
12023       PerlMem_free(fileified);
12024     if (vmsname != NULL)
12025       PerlMem_free(vmsname);
12026     return FALSE;
12027   }
12028   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12029     if (fileified != NULL)
12030       PerlMem_free(fileified);
12031     if (vmsname != NULL)
12032       PerlMem_free(vmsname);
12033     return TRUE;
12034   }
12035   _ckvmssts_noperl(retsts);
12036
12037   if (fileified != NULL)
12038     PerlMem_free(fileified);
12039   if (vmsname != NULL)
12040     PerlMem_free(vmsname);
12041   return FALSE;  /* Should never get here */
12042
12043 }
12044
12045 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12046 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12047  * subset of the applicable information.
12048  */
12049 bool
12050 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12051 {
12052   return cando_by_name_int
12053         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12054 }  /* end of cando() */
12055 /*}}}*/
12056
12057
12058 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12059 I32
12060 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12061 {
12062    return cando_by_name_int(bit, effective, fname, 0);
12063
12064 }  /* end of cando_by_name() */
12065 /*}}}*/
12066
12067
12068 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12069 int
12070 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12071 {
12072   if (!fstat(fd, &statbufp->crtl_stat)) {
12073     char *cptr;
12074     char *vms_filename;
12075     vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12076     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12077
12078     /* Save name for cando by name in VMS format */
12079     cptr = getname(fd, vms_filename, 1);
12080
12081     /* This should not happen, but just in case */
12082     if (cptr == NULL) {
12083         statbufp->st_devnam[0] = 0;
12084     }
12085     else {
12086         /* Make sure that the saved name fits in 255 characters */
12087         cptr = int_rmsexpand_vms
12088                        (vms_filename,
12089                         statbufp->st_devnam,
12090                         0);
12091         if (cptr == NULL)
12092             statbufp->st_devnam[0] = 0;
12093     }
12094     PerlMem_free(vms_filename);
12095
12096     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12097     VMS_DEVICE_ENCODE
12098         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12099
12100 #   ifdef VMSISH_TIME
12101     if (VMSISH_TIME) {
12102       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12103       statbufp->st_atime = _toloc(statbufp->st_atime);
12104       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12105     }
12106 #   endif
12107     return 0;
12108   }
12109   return -1;
12110
12111 }  /* end of flex_fstat() */
12112 /*}}}*/
12113
12114 static int
12115 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12116 {
12117     char *temp_fspec = NULL;
12118     char *fileified = NULL;
12119     const char *save_spec;
12120     char *ret_spec;
12121     int retval = -1;
12122     char efs_hack = 0;
12123     char already_fileified = 0;
12124     dSAVEDERRNO;
12125
12126     if (!fspec) {
12127         errno = EINVAL;
12128         return retval;
12129     }
12130
12131     if (decc_bug_devnull != 0) {
12132       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12133         memset(statbufp,0,sizeof *statbufp);
12134         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12135         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12136         statbufp->st_uid = 0x00010001;
12137         statbufp->st_gid = 0x0001;
12138         time((time_t *)&statbufp->st_mtime);
12139         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12140         return 0;
12141       }
12142     }
12143
12144     SAVE_ERRNO;
12145
12146 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12147   /*
12148    * If we are in POSIX filespec mode, accept the filename as is.
12149    */
12150   if (decc_posix_compliant_pathnames == 0) {
12151 #endif
12152
12153     /* Try for a simple stat first.  If fspec contains a filename without
12154      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12155      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12156      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12157      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12158      * the file with null type, specify this by calling flex_stat() with
12159      * a '.' at the end of fspec.
12160      */
12161
12162     if (lstat_flag == 0)
12163         retval = stat(fspec, &statbufp->crtl_stat);
12164     else
12165         retval = lstat(fspec, &statbufp->crtl_stat);
12166
12167     if (!retval) {
12168         save_spec = fspec;
12169     }
12170     else {
12171         /* In the odd case where we have write but not read access
12172          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12173          */
12174         fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12175         if (fileified == NULL)
12176               _ckvmssts_noperl(SS$_INSFMEM);
12177
12178         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12179         if (ret_spec != NULL) {
12180             if (lstat_flag == 0)
12181                 retval = stat(fileified, &statbufp->crtl_stat);
12182             else
12183                 retval = lstat(fileified, &statbufp->crtl_stat);
12184             save_spec = fileified;
12185             already_fileified = 1;
12186         }
12187     }
12188
12189     if (retval && vms_bug_stat_filename) {
12190
12191         temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12192         if (temp_fspec == NULL)
12193             _ckvmssts_noperl(SS$_INSFMEM);
12194
12195         /* We should try again as a vmsified file specification. */
12196
12197         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12198         if (ret_spec != NULL) {
12199             if (lstat_flag == 0)
12200                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12201             else
12202                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12203             save_spec = temp_fspec;
12204         }
12205     }
12206
12207     if (retval) {
12208         /* Last chance - allow multiple dots without EFS CHARSET */
12209         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12210          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12211          * enable it if it isn't already.
12212          */
12213 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12214         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12215             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12216 #endif
12217         if (lstat_flag == 0)
12218             retval = stat(fspec, &statbufp->crtl_stat);
12219         else
12220             retval = lstat(fspec, &statbufp->crtl_stat);
12221         save_spec = fspec;
12222 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12223         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12224             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12225             efs_hack = 1;
12226         }
12227 #endif
12228     }
12229
12230 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12231   } else {
12232     if (lstat_flag == 0)
12233       retval = stat(temp_fspec, &statbufp->crtl_stat);
12234     else
12235       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12236       save_spec = temp_fspec;
12237   }
12238 #endif
12239
12240 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12241   /* As you were... */
12242   if (!decc_efs_charset)
12243     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12244 #endif
12245
12246     if (!retval) {
12247       char *cptr;
12248       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12249
12250       /* If this is an lstat, do not follow the link */
12251       if (lstat_flag)
12252         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12253
12254 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12255       /* If we used the efs_hack above, we must also use it here for */
12256       /* perl_cando to work */
12257       if (efs_hack && (decc_efs_charset_index > 0)) {
12258           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12259       }
12260 #endif
12261
12262       /* If we've got a directory, save a fileified, expanded version of it
12263        * in st_devnam.  If not a directory, just an expanded version.
12264        */
12265       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12266           fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12267           if (fileified == NULL)
12268               _ckvmssts_noperl(SS$_INSFMEM);
12269
12270           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12271           if (cptr != NULL)
12272               save_spec = fileified;
12273       }
12274
12275       cptr = int_rmsexpand(save_spec,
12276                            statbufp->st_devnam,
12277                            NULL,
12278                            rmsex_flags,
12279                            0,
12280                            0);
12281
12282 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12283       if (efs_hack && (decc_efs_charset_index > 0)) {
12284           decc$feature_set_value(decc_efs_charset, 1, 0);
12285       }
12286 #endif
12287
12288       /* Fix me: If this is NULL then stat found a file, and we could */
12289       /* not convert the specification to VMS - Should never happen */
12290       if (cptr == NULL)
12291         statbufp->st_devnam[0] = 0;
12292
12293       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12294       VMS_DEVICE_ENCODE
12295         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12296 #     ifdef VMSISH_TIME
12297       if (VMSISH_TIME) {
12298         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12299         statbufp->st_atime = _toloc(statbufp->st_atime);
12300         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12301       }
12302 #     endif
12303     }
12304     /* If we were successful, leave errno where we found it */
12305     if (retval == 0) RESTORE_ERRNO;
12306     if (temp_fspec)
12307         PerlMem_free(temp_fspec);
12308     if (fileified)
12309         PerlMem_free(fileified);
12310     return retval;
12311
12312 }  /* end of flex_stat_int() */
12313
12314
12315 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12316 int
12317 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12318 {
12319    return flex_stat_int(fspec, statbufp, 0);
12320 }
12321 /*}}}*/
12322
12323 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12324 int
12325 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12326 {
12327    return flex_stat_int(fspec, statbufp, 1);
12328 }
12329 /*}}}*/
12330
12331
12332 /*{{{char *my_getlogin()*/
12333 /* VMS cuserid == Unix getlogin, except calling sequence */
12334 char *
12335 my_getlogin(void)
12336 {
12337     static char user[L_cuserid];
12338     return cuserid(user);
12339 }
12340 /*}}}*/
12341
12342
12343 /*  rmscopy - copy a file using VMS RMS routines
12344  *
12345  *  Copies contents and attributes of spec_in to spec_out, except owner
12346  *  and protection information.  Name and type of spec_in are used as
12347  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12348  *  should try to propagate timestamps from the input file to the output file.
12349  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12350  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12351  *  propagated to the output file at creation iff the output file specification
12352  *  did not contain an explicit name or type, and the revision date is always
12353  *  updated at the end of the copy operation.  If it is greater than 0, then
12354  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12355  *  other than the revision date should be propagated, and bit 1 indicates
12356  *  that the revision date should be propagated.
12357  *
12358  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12359  *
12360  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12361  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12362  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12363  * as part of the Perl standard distribution under the terms of the
12364  * GNU General Public License or the Perl Artistic License.  Copies
12365  * of each may be found in the Perl standard distribution.
12366  */ /* FIXME */
12367 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12368 int
12369 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12370 {
12371     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12372          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12373     unsigned long int sts;
12374     int dna_len;
12375     struct FAB fab_in, fab_out;
12376     struct RAB rab_in, rab_out;
12377     rms_setup_nam(nam);
12378     rms_setup_nam(nam_out);
12379     struct XABDAT xabdat;
12380     struct XABFHC xabfhc;
12381     struct XABRDT xabrdt;
12382     struct XABSUM xabsum;
12383
12384     vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12385     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12386     vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12387     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12388     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12389         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12390       PerlMem_free(vmsin);
12391       PerlMem_free(vmsout);
12392       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12393       return 0;
12394     }
12395
12396     esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12397     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12398     esal = NULL;
12399 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12400     esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12401     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12402 #endif
12403     fab_in = cc$rms_fab;
12404     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12405     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12406     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12407     fab_in.fab$l_fop = FAB$M_SQO;
12408     rms_bind_fab_nam(fab_in, nam);
12409     fab_in.fab$l_xab = (void *) &xabdat;
12410
12411     rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12412     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12413     rsal = NULL;
12414 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12415     rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12416     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12417 #endif
12418     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12419     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12420     rms_nam_esl(nam) = 0;
12421     rms_nam_rsl(nam) = 0;
12422     rms_nam_esll(nam) = 0;
12423     rms_nam_rsll(nam) = 0;
12424 #ifdef NAM$M_NO_SHORT_UPCASE
12425     if (decc_efs_case_preserve)
12426         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12427 #endif
12428
12429     xabdat = cc$rms_xabdat;        /* To get creation date */
12430     xabdat.xab$l_nxt = (void *) &xabfhc;
12431
12432     xabfhc = cc$rms_xabfhc;        /* To get record length */
12433     xabfhc.xab$l_nxt = (void *) &xabsum;
12434
12435     xabsum = cc$rms_xabsum;        /* To get key and area information */
12436
12437     if (!((sts = sys$open(&fab_in)) & 1)) {
12438       PerlMem_free(vmsin);
12439       PerlMem_free(vmsout);
12440       PerlMem_free(esa);
12441       if (esal != NULL)
12442         PerlMem_free(esal);
12443       PerlMem_free(rsa);
12444       if (rsal != NULL)
12445         PerlMem_free(rsal);
12446       set_vaxc_errno(sts);
12447       switch (sts) {
12448         case RMS$_FNF: case RMS$_DNF:
12449           set_errno(ENOENT); break;
12450         case RMS$_DIR:
12451           set_errno(ENOTDIR); break;
12452         case RMS$_DEV:
12453           set_errno(ENODEV); break;
12454         case RMS$_SYN:
12455           set_errno(EINVAL); break;
12456         case RMS$_PRV:
12457           set_errno(EACCES); break;
12458         default:
12459           set_errno(EVMSERR);
12460       }
12461       return 0;
12462     }
12463
12464     nam_out = nam;
12465     fab_out = fab_in;
12466     fab_out.fab$w_ifi = 0;
12467     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12468     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12469     fab_out.fab$l_fop = FAB$M_SQO;
12470     rms_bind_fab_nam(fab_out, nam_out);
12471     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12472     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12473     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12474     esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12475     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12476     rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12477     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12478     esal_out = NULL;
12479     rsal_out = NULL;
12480 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12481     esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12482     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12483     rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12484     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12485 #endif
12486     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12487     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12488
12489     if (preserve_dates == 0) {  /* Act like DCL COPY */
12490       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12491       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12492       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12493         PerlMem_free(vmsin);
12494         PerlMem_free(vmsout);
12495         PerlMem_free(esa);
12496         if (esal != NULL)
12497             PerlMem_free(esal);
12498         PerlMem_free(rsa);
12499         if (rsal != NULL)
12500             PerlMem_free(rsal);
12501         PerlMem_free(esa_out);
12502         if (esal_out != NULL)
12503             PerlMem_free(esal_out);
12504         PerlMem_free(rsa_out);
12505         if (rsal_out != NULL)
12506             PerlMem_free(rsal_out);
12507         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12508         set_vaxc_errno(sts);
12509         return 0;
12510       }
12511       fab_out.fab$l_xab = (void *) &xabdat;
12512       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12513         preserve_dates = 1;
12514     }
12515     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12516       preserve_dates =0;      /* bitmask from this point forward   */
12517
12518     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12519     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12520       PerlMem_free(vmsin);
12521       PerlMem_free(vmsout);
12522       PerlMem_free(esa);
12523       if (esal != NULL)
12524           PerlMem_free(esal);
12525       PerlMem_free(rsa);
12526       if (rsal != NULL)
12527           PerlMem_free(rsal);
12528       PerlMem_free(esa_out);
12529       if (esal_out != NULL)
12530           PerlMem_free(esal_out);
12531       PerlMem_free(rsa_out);
12532       if (rsal_out != NULL)
12533           PerlMem_free(rsal_out);
12534       set_vaxc_errno(sts);
12535       switch (sts) {
12536         case RMS$_DNF:
12537           set_errno(ENOENT); break;
12538         case RMS$_DIR:
12539           set_errno(ENOTDIR); break;
12540         case RMS$_DEV:
12541           set_errno(ENODEV); break;
12542         case RMS$_SYN:
12543           set_errno(EINVAL); break;
12544         case RMS$_PRV:
12545           set_errno(EACCES); break;
12546         default:
12547           set_errno(EVMSERR);
12548       }
12549       return 0;
12550     }
12551     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12552     if (preserve_dates & 2) {
12553       /* sys$close() will process xabrdt, not xabdat */
12554       xabrdt = cc$rms_xabrdt;
12555 #ifndef __GNUC__
12556       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12557 #else
12558       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12559        * is unsigned long[2], while DECC & VAXC use a struct */
12560       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12561 #endif
12562       fab_out.fab$l_xab = (void *) &xabrdt;
12563     }
12564
12565     ubf = (char *)PerlMem_malloc(32256);
12566     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12567     rab_in = cc$rms_rab;
12568     rab_in.rab$l_fab = &fab_in;
12569     rab_in.rab$l_rop = RAB$M_BIO;
12570     rab_in.rab$l_ubf = ubf;
12571     rab_in.rab$w_usz = 32256;
12572     if (!((sts = sys$connect(&rab_in)) & 1)) {
12573       sys$close(&fab_in); sys$close(&fab_out);
12574       PerlMem_free(vmsin);
12575       PerlMem_free(vmsout);
12576       PerlMem_free(ubf);
12577       PerlMem_free(esa);
12578       if (esal != NULL)
12579           PerlMem_free(esal);
12580       PerlMem_free(rsa);
12581       if (rsal != NULL)
12582           PerlMem_free(rsal);
12583       PerlMem_free(esa_out);
12584       if (esal_out != NULL)
12585           PerlMem_free(esal_out);
12586       PerlMem_free(rsa_out);
12587       if (rsal_out != NULL)
12588           PerlMem_free(rsal_out);
12589       set_errno(EVMSERR); set_vaxc_errno(sts);
12590       return 0;
12591     }
12592
12593     rab_out = cc$rms_rab;
12594     rab_out.rab$l_fab = &fab_out;
12595     rab_out.rab$l_rbf = ubf;
12596     if (!((sts = sys$connect(&rab_out)) & 1)) {
12597       sys$close(&fab_in); sys$close(&fab_out);
12598       PerlMem_free(vmsin);
12599       PerlMem_free(vmsout);
12600       PerlMem_free(ubf);
12601       PerlMem_free(esa);
12602       if (esal != NULL)
12603           PerlMem_free(esal);
12604       PerlMem_free(rsa);
12605       if (rsal != NULL)
12606           PerlMem_free(rsal);
12607       PerlMem_free(esa_out);
12608       if (esal_out != NULL)
12609           PerlMem_free(esal_out);
12610       PerlMem_free(rsa_out);
12611       if (rsal_out != NULL)
12612           PerlMem_free(rsal_out);
12613       set_errno(EVMSERR); set_vaxc_errno(sts);
12614       return 0;
12615     }
12616
12617     while ((sts = sys$read(&rab_in))) {  /* always true  */
12618       if (sts == RMS$_EOF) break;
12619       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12620       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12621         sys$close(&fab_in); sys$close(&fab_out);
12622         PerlMem_free(vmsin);
12623         PerlMem_free(vmsout);
12624         PerlMem_free(ubf);
12625         PerlMem_free(esa);
12626         if (esal != NULL)
12627             PerlMem_free(esal);
12628         PerlMem_free(rsa);
12629         if (rsal != NULL)
12630             PerlMem_free(rsal);
12631         PerlMem_free(esa_out);
12632         if (esal_out != NULL)
12633             PerlMem_free(esal_out);
12634         PerlMem_free(rsa_out);
12635         if (rsal_out != NULL)
12636             PerlMem_free(rsal_out);
12637         set_errno(EVMSERR); set_vaxc_errno(sts);
12638         return 0;
12639       }
12640     }
12641
12642
12643     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12644     sys$close(&fab_in);  sys$close(&fab_out);
12645     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12646
12647     PerlMem_free(vmsin);
12648     PerlMem_free(vmsout);
12649     PerlMem_free(ubf);
12650     PerlMem_free(esa);
12651     if (esal != NULL)
12652         PerlMem_free(esal);
12653     PerlMem_free(rsa);
12654     if (rsal != NULL)
12655         PerlMem_free(rsal);
12656     PerlMem_free(esa_out);
12657     if (esal_out != NULL)
12658         PerlMem_free(esal_out);
12659     PerlMem_free(rsa_out);
12660     if (rsal_out != NULL)
12661         PerlMem_free(rsal_out);
12662
12663     if (!(sts & 1)) {
12664       set_errno(EVMSERR); set_vaxc_errno(sts);
12665       return 0;
12666     }
12667
12668     return 1;
12669
12670 }  /* end of rmscopy() */
12671 /*}}}*/
12672
12673
12674 /***  The following glue provides 'hooks' to make some of the routines
12675  * from this file available from Perl.  These routines are sufficiently
12676  * basic, and are required sufficiently early in the build process,
12677  * that's it's nice to have them available to miniperl as well as the
12678  * full Perl, so they're set up here instead of in an extension.  The
12679  * Perl code which handles importation of these names into a given
12680  * package lives in [.VMS]Filespec.pm in @INC.
12681  */
12682
12683 void
12684 rmsexpand_fromperl(pTHX_ CV *cv)
12685 {
12686   dXSARGS;
12687   char *fspec, *defspec = NULL, *rslt;
12688   STRLEN n_a;
12689   int fs_utf8, dfs_utf8;
12690
12691   fs_utf8 = 0;
12692   dfs_utf8 = 0;
12693   if (!items || items > 2)
12694     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12695   fspec = SvPV(ST(0),n_a);
12696   fs_utf8 = SvUTF8(ST(0));
12697   if (!fspec || !*fspec) XSRETURN_UNDEF;
12698   if (items == 2) {
12699     defspec = SvPV(ST(1),n_a);
12700     dfs_utf8 = SvUTF8(ST(1));
12701   }
12702   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12703   ST(0) = sv_newmortal();
12704   if (rslt != NULL) {
12705     sv_usepvn(ST(0),rslt,strlen(rslt));
12706     if (fs_utf8) {
12707         SvUTF8_on(ST(0));
12708     }
12709   }
12710   XSRETURN(1);
12711 }
12712
12713 void
12714 vmsify_fromperl(pTHX_ CV *cv)
12715 {
12716   dXSARGS;
12717   char *vmsified;
12718   STRLEN n_a;
12719   int utf8_fl;
12720
12721   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12722   utf8_fl = SvUTF8(ST(0));
12723   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12724   ST(0) = sv_newmortal();
12725   if (vmsified != NULL) {
12726     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12727     if (utf8_fl) {
12728         SvUTF8_on(ST(0));
12729     }
12730   }
12731   XSRETURN(1);
12732 }
12733
12734 void
12735 unixify_fromperl(pTHX_ CV *cv)
12736 {
12737   dXSARGS;
12738   char *unixified;
12739   STRLEN n_a;
12740   int utf8_fl;
12741
12742   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12743   utf8_fl = SvUTF8(ST(0));
12744   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12745   ST(0) = sv_newmortal();
12746   if (unixified != NULL) {
12747     sv_usepvn(ST(0),unixified,strlen(unixified));
12748     if (utf8_fl) {
12749         SvUTF8_on(ST(0));
12750     }
12751   }
12752   XSRETURN(1);
12753 }
12754
12755 void
12756 fileify_fromperl(pTHX_ CV *cv)
12757 {
12758   dXSARGS;
12759   char *fileified;
12760   STRLEN n_a;
12761   int utf8_fl;
12762
12763   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12764   utf8_fl = SvUTF8(ST(0));
12765   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12766   ST(0) = sv_newmortal();
12767   if (fileified != NULL) {
12768     sv_usepvn(ST(0),fileified,strlen(fileified));
12769     if (utf8_fl) {
12770         SvUTF8_on(ST(0));
12771     }
12772   }
12773   XSRETURN(1);
12774 }
12775
12776 void
12777 pathify_fromperl(pTHX_ CV *cv)
12778 {
12779   dXSARGS;
12780   char *pathified;
12781   STRLEN n_a;
12782   int utf8_fl;
12783
12784   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12785   utf8_fl = SvUTF8(ST(0));
12786   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12787   ST(0) = sv_newmortal();
12788   if (pathified != NULL) {
12789     sv_usepvn(ST(0),pathified,strlen(pathified));
12790     if (utf8_fl) {
12791         SvUTF8_on(ST(0));
12792     }
12793   }
12794   XSRETURN(1);
12795 }
12796
12797 void
12798 vmspath_fromperl(pTHX_ CV *cv)
12799 {
12800   dXSARGS;
12801   char *vmspath;
12802   STRLEN n_a;
12803   int utf8_fl;
12804
12805   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12806   utf8_fl = SvUTF8(ST(0));
12807   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12808   ST(0) = sv_newmortal();
12809   if (vmspath != NULL) {
12810     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12811     if (utf8_fl) {
12812         SvUTF8_on(ST(0));
12813     }
12814   }
12815   XSRETURN(1);
12816 }
12817
12818 void
12819 unixpath_fromperl(pTHX_ CV *cv)
12820 {
12821   dXSARGS;
12822   char *unixpath;
12823   STRLEN n_a;
12824   int utf8_fl;
12825
12826   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12827   utf8_fl = SvUTF8(ST(0));
12828   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12829   ST(0) = sv_newmortal();
12830   if (unixpath != NULL) {
12831     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12832     if (utf8_fl) {
12833         SvUTF8_on(ST(0));
12834     }
12835   }
12836   XSRETURN(1);
12837 }
12838
12839 void
12840 candelete_fromperl(pTHX_ CV *cv)
12841 {
12842   dXSARGS;
12843   char *fspec, *fsp;
12844   SV *mysv;
12845   IO *io;
12846   STRLEN n_a;
12847
12848   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12849
12850   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12851   Newx(fspec, VMS_MAXRSS, char);
12852   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12853   if (isGV_with_GP(mysv)) {
12854     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12855       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12856       ST(0) = &PL_sv_no;
12857       Safefree(fspec);
12858       XSRETURN(1);
12859     }
12860     fsp = fspec;
12861   }
12862   else {
12863     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12864       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12865       ST(0) = &PL_sv_no;
12866       Safefree(fspec);
12867       XSRETURN(1);
12868     }
12869   }
12870
12871   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12872   Safefree(fspec);
12873   XSRETURN(1);
12874 }
12875
12876 void
12877 rmscopy_fromperl(pTHX_ CV *cv)
12878 {
12879   dXSARGS;
12880   char *inspec, *outspec, *inp, *outp;
12881   int date_flag;
12882   SV *mysv;
12883   IO *io;
12884   STRLEN n_a;
12885
12886   if (items < 2 || items > 3)
12887     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12888
12889   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12890   Newx(inspec, VMS_MAXRSS, char);
12891   if (isGV_with_GP(mysv)) {
12892     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12893       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12894       ST(0) = sv_2mortal(newSViv(0));
12895       Safefree(inspec);
12896       XSRETURN(1);
12897     }
12898     inp = inspec;
12899   }
12900   else {
12901     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12902       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12903       ST(0) = sv_2mortal(newSViv(0));
12904       Safefree(inspec);
12905       XSRETURN(1);
12906     }
12907   }
12908   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12909   Newx(outspec, VMS_MAXRSS, char);
12910   if (isGV_with_GP(mysv)) {
12911     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12912       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12913       ST(0) = sv_2mortal(newSViv(0));
12914       Safefree(inspec);
12915       Safefree(outspec);
12916       XSRETURN(1);
12917     }
12918     outp = outspec;
12919   }
12920   else {
12921     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12922       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12923       ST(0) = sv_2mortal(newSViv(0));
12924       Safefree(inspec);
12925       Safefree(outspec);
12926       XSRETURN(1);
12927     }
12928   }
12929   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12930
12931   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12932   Safefree(inspec);
12933   Safefree(outspec);
12934   XSRETURN(1);
12935 }
12936
12937 /* The mod2fname is limited to shorter filenames by design, so it should
12938  * not be modified to support longer EFS pathnames
12939  */
12940 void
12941 mod2fname(pTHX_ CV *cv)
12942 {
12943   dXSARGS;
12944   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12945        workbuff[NAM$C_MAXRSS*1 + 1];
12946   int counter, num_entries;
12947   /* ODS-5 ups this, but we want to be consistent, so... */
12948   int max_name_len = 39;
12949   AV *in_array = (AV *)SvRV(ST(0));
12950
12951   num_entries = av_len(in_array);
12952
12953   /* All the names start with PL_. */
12954   strcpy(ultimate_name, "PL_");
12955
12956   /* Clean up our working buffer */
12957   Zero(work_name, sizeof(work_name), char);
12958
12959   /* Run through the entries and build up a working name */
12960   for(counter = 0; counter <= num_entries; counter++) {
12961     /* If it's not the first name then tack on a __ */
12962     if (counter) {
12963       my_strlcat(work_name, "__", sizeof(work_name));
12964     }
12965     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12966   }
12967
12968   /* Check to see if we actually have to bother...*/
12969   if (strlen(work_name) + 3 <= max_name_len) {
12970     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12971   } else {
12972     /* It's too darned big, so we need to go strip. We use the same */
12973     /* algorithm as xsubpp does. First, strip out doubled __ */
12974     char *source, *dest, last;
12975     dest = workbuff;
12976     last = 0;
12977     for (source = work_name; *source; source++) {
12978       if (last == *source && last == '_') {
12979         continue;
12980       }
12981       *dest++ = *source;
12982       last = *source;
12983     }
12984     /* Go put it back */
12985     my_strlcpy(work_name, workbuff, sizeof(work_name));
12986     /* Is it still too big? */
12987     if (strlen(work_name) + 3 > max_name_len) {
12988       /* Strip duplicate letters */
12989       last = 0;
12990       dest = workbuff;
12991       for (source = work_name; *source; source++) {
12992         if (last == toupper(*source)) {
12993         continue;
12994         }
12995         *dest++ = *source;
12996         last = toupper(*source);
12997       }
12998       my_strlcpy(work_name, workbuff, sizeof(work_name));
12999     }
13000
13001     /* Is it *still* too big? */
13002     if (strlen(work_name) + 3 > max_name_len) {
13003       /* Too bad, we truncate */
13004       work_name[max_name_len - 2] = 0;
13005     }
13006     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
13007   }
13008
13009   /* Okay, return it */
13010   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13011   XSRETURN(1);
13012 }
13013
13014 void
13015 hushexit_fromperl(pTHX_ CV *cv)
13016 {
13017     dXSARGS;
13018
13019     if (items > 0) {
13020         VMSISH_HUSHED = SvTRUE(ST(0));
13021     }
13022     ST(0) = boolSV(VMSISH_HUSHED);
13023     XSRETURN(1);
13024 }
13025
13026
13027 PerlIO *
13028 Perl_vms_start_glob
13029    (pTHX_ SV *tmpglob,
13030     IO *io)
13031 {
13032     PerlIO *fp;
13033     struct vs_str_st *rslt;
13034     char *vmsspec;
13035     char *rstr;
13036     char *begin, *cp;
13037     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13038     PerlIO *tmpfp;
13039     STRLEN i;
13040     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13041     struct dsc$descriptor_vs rsdsc;
13042     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13043     unsigned long hasver = 0, isunix = 0;
13044     unsigned long int lff_flags = 0;
13045     int rms_sts;
13046     int vms_old_glob = 1;
13047
13048     if (!SvOK(tmpglob)) {
13049         SETERRNO(ENOENT,RMS$_FNF);
13050         return NULL;
13051     }
13052
13053     vms_old_glob = !decc_filename_unix_report;
13054
13055 #ifdef VMS_LONGNAME_SUPPORT
13056     lff_flags = LIB$M_FIL_LONG_NAMES;
13057 #endif
13058     /* The Newx macro will not allow me to assign a smaller array
13059      * to the rslt pointer, so we will assign it to the begin char pointer
13060      * and then copy the value into the rslt pointer.
13061      */
13062     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13063     rslt = (struct vs_str_st *)begin;
13064     rslt->length = 0;
13065     rstr = &rslt->str[0];
13066     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13067     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13068     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13069     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13070
13071     Newx(vmsspec, VMS_MAXRSS, char);
13072
13073         /* We could find out if there's an explicit dev/dir or version
13074            by peeking into lib$find_file's internal context at
13075            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13076            but that's unsupported, so I don't want to do it now and
13077            have it bite someone in the future. */
13078         /* Fix-me: vms_split_path() is the only way to do this, the
13079            existing method will fail with many legal EFS or UNIX specifications
13080          */
13081
13082     cp = SvPV(tmpglob,i);
13083
13084     for (; i; i--) {
13085         if (cp[i] == ';') hasver = 1;
13086         if (cp[i] == '.') {
13087             if (sts) hasver = 1;
13088             else sts = 1;
13089         }
13090         if (cp[i] == '/') {
13091             hasdir = isunix = 1;
13092             break;
13093         }
13094         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13095             hasdir = 1;
13096             break;
13097         }
13098     }
13099
13100     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13101     if ((hasdir == 0) && decc_filename_unix_report) {
13102         isunix = 1;
13103     }
13104
13105     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13106         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13107         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13108         int wildstar = 0;
13109         int wildquery = 0;
13110         int found = 0;
13111         Stat_t st;
13112         int stat_sts;
13113         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13114         if (!stat_sts && S_ISDIR(st.st_mode)) {
13115             char * vms_dir;
13116             const char * fname;
13117             STRLEN fname_len;
13118
13119             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13120             /* path delimiter of ':>]', if so, then the old behavior has */
13121             /* obviously been specifically requested */
13122
13123             fname = SvPVX_const(tmpglob);
13124             fname_len = strlen(fname);
13125             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13126             if (vms_old_glob || (vms_dir != NULL)) {
13127                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13128                                             SvPVX(tmpglob),vmsspec,NULL);
13129                 ok = (wilddsc.dsc$a_pointer != NULL);
13130                 /* maybe passed 'foo' rather than '[.foo]', thus not
13131                    detected above */
13132                 hasdir = 1;
13133             } else {
13134                 /* Operate just on the directory, the special stat/fstat for */
13135                 /* leaves the fileified  specification in the st_devnam */
13136                 /* member. */
13137                 wilddsc.dsc$a_pointer = st.st_devnam;
13138                 ok = 1;
13139             }
13140         }
13141         else {
13142             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13143             ok = (wilddsc.dsc$a_pointer != NULL);
13144         }
13145         if (ok)
13146             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13147
13148         /* If not extended character set, replace ? with % */
13149         /* With extended character set, ? is a wildcard single character */
13150         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13151             if (*cp == '?') {
13152                 wildquery = 1;
13153                 if (!decc_efs_charset)
13154                     *cp = '%';
13155             } else if (*cp == '%') {
13156                 wildquery = 1;
13157             } else if (*cp == '*') {
13158                 wildstar = 1;
13159             }
13160         }
13161
13162         if (ok) {
13163             wv_sts = vms_split_path(
13164                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13165                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13166                 &wvs_spec, &wvs_len);
13167         } else {
13168             wn_spec = NULL;
13169             wn_len = 0;
13170             we_spec = NULL;
13171             we_len = 0;
13172         }
13173
13174         sts = SS$_NORMAL;
13175         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13176          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13177          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13178          int valid_find;
13179
13180             valid_find = 0;
13181             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13182                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13183             if (!$VMS_STATUS_SUCCESS(sts))
13184                 break;
13185
13186             /* with varying string, 1st word of buffer contains result length */
13187             rstr[rslt->length] = '\0';
13188
13189              /* Find where all the components are */
13190              v_sts = vms_split_path
13191                        (rstr,
13192                         &v_spec,
13193                         &v_len,
13194                         &r_spec,
13195                         &r_len,
13196                         &d_spec,
13197                         &d_len,
13198                         &n_spec,
13199                         &n_len,
13200                         &e_spec,
13201                         &e_len,
13202                         &vs_spec,
13203                         &vs_len);
13204
13205             /* If no version on input, truncate the version on output */
13206             if (!hasver && (vs_len > 0)) {
13207                 *vs_spec = '\0';
13208                 vs_len = 0;
13209             }
13210
13211             if (isunix) {
13212
13213                 /* In Unix report mode, remove the ".dir;1" from the name */
13214                 /* if it is a real directory */
13215                 if (decc_filename_unix_report || decc_efs_charset) {
13216                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13217                         Stat_t statbuf;
13218                         int ret_sts;
13219
13220                         ret_sts = flex_lstat(rstr, &statbuf);
13221                         if ((ret_sts == 0) &&
13222                             S_ISDIR(statbuf.st_mode)) {
13223                             e_len = 0;
13224                             e_spec[0] = 0;
13225                         }
13226                     }
13227                 }
13228
13229                 /* No version & a null extension on UNIX handling */
13230                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13231                     e_len = 0;
13232                     *e_spec = '\0';
13233                 }
13234             }
13235
13236             if (!decc_efs_case_preserve) {
13237                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13238             }
13239
13240             /* Find File treats a Null extension as return all extensions */
13241             /* This is contrary to Perl expectations */
13242
13243             if (wildstar || wildquery || vms_old_glob) {
13244                 /* really need to see if the returned file name matched */
13245                 /* but for now will assume that it matches */
13246                 valid_find = 1;
13247             } else {
13248                 /* Exact Match requested */
13249                 /* How are directories handled? - like a file */
13250                 if ((e_len == we_len) && (n_len == wn_len)) {
13251                     int t1;
13252                     t1 = e_len;
13253                     if (t1 > 0)
13254                         t1 = strncmp(e_spec, we_spec, e_len);
13255                     if (t1 == 0) {
13256                        t1 = n_len;
13257                        if (t1 > 0)
13258                            t1 = strncmp(n_spec, we_spec, n_len);
13259                        if (t1 == 0)
13260                            valid_find = 1;
13261                     }
13262                 }
13263             }
13264
13265             if (valid_find) {
13266                 found++;
13267
13268                 if (hasdir) {
13269                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13270                     begin = rstr;
13271                 }
13272                 else {
13273                     /* Start with the name */
13274                     begin = n_spec;
13275                 }
13276                 strcat(begin,"\n");
13277                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13278             }
13279         }
13280         if (cxt) (void)lib$find_file_end(&cxt);
13281
13282         if (!found) {
13283             /* Be POSIXish: return the input pattern when no matches */
13284             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13285             strcat(rstr,"\n");
13286             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13287         }
13288
13289         if (ok && sts != RMS$_NMF &&
13290             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13291         if (!ok) {
13292             if (!(sts & 1)) {
13293                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13294             }
13295             PerlIO_close(tmpfp);
13296             fp = NULL;
13297         }
13298         else {
13299             PerlIO_rewind(tmpfp);
13300             IoTYPE(io) = IoTYPE_RDONLY;
13301             IoIFP(io) = fp = tmpfp;
13302             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13303         }
13304     }
13305     Safefree(vmsspec);
13306     Safefree(rslt);
13307     return fp;
13308 }
13309
13310
13311 static char *
13312 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13313                    int *utf8_fl);
13314
13315 void
13316 unixrealpath_fromperl(pTHX_ CV *cv)
13317 {
13318     dXSARGS;
13319     char *fspec, *rslt_spec, *rslt;
13320     STRLEN n_a;
13321
13322     if (!items || items != 1)
13323         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13324
13325     fspec = SvPV(ST(0),n_a);
13326     if (!fspec || !*fspec) XSRETURN_UNDEF;
13327
13328     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13329     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13330
13331     ST(0) = sv_newmortal();
13332     if (rslt != NULL)
13333         sv_usepvn(ST(0),rslt,strlen(rslt));
13334     else
13335         Safefree(rslt_spec);
13336         XSRETURN(1);
13337 }
13338
13339 static char *
13340 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13341                    int *utf8_fl);
13342
13343 void
13344 vmsrealpath_fromperl(pTHX_ CV *cv)
13345 {
13346     dXSARGS;
13347     char *fspec, *rslt_spec, *rslt;
13348     STRLEN n_a;
13349
13350     if (!items || items != 1)
13351         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13352
13353     fspec = SvPV(ST(0),n_a);
13354     if (!fspec || !*fspec) XSRETURN_UNDEF;
13355
13356     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13357     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13358
13359     ST(0) = sv_newmortal();
13360     if (rslt != NULL)
13361         sv_usepvn(ST(0),rslt,strlen(rslt));
13362     else
13363         Safefree(rslt_spec);
13364         XSRETURN(1);
13365 }
13366
13367 #ifdef HAS_SYMLINK
13368 /*
13369  * A thin wrapper around decc$symlink to make sure we follow the
13370  * standard and do not create a symlink with a zero-length name,
13371  * and convert the target to Unix format, as the CRTL can't handle
13372  * targets in VMS format.
13373  */
13374 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13375 int
13376 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13377 {
13378     int sts;
13379     char * utarget;
13380
13381     if (!link_name || !*link_name) {
13382       SETERRNO(ENOENT, SS$_NOSUCHFILE);
13383       return -1;
13384     }
13385
13386     utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13387     /* An untranslatable filename should be passed through. */
13388     (void) int_tounixspec(contents, utarget, NULL);
13389     sts = symlink(utarget, link_name);
13390     PerlMem_free(utarget);
13391     return sts;
13392 }
13393 /*}}}*/
13394
13395 #endif /* HAS_SYMLINK */
13396
13397 int do_vms_case_tolerant(void);
13398
13399 void
13400 case_tolerant_process_fromperl(pTHX_ CV *cv)
13401 {
13402   dXSARGS;
13403   ST(0) = boolSV(do_vms_case_tolerant());
13404   XSRETURN(1);
13405 }
13406
13407 #ifdef USE_ITHREADS
13408
13409 void
13410 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13411                           struct interp_intern *dst)
13412 {
13413     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13414
13415     memcpy(dst,src,sizeof(struct interp_intern));
13416 }
13417
13418 #endif
13419
13420 void
13421 Perl_sys_intern_clear(pTHX)
13422 {
13423 }
13424
13425 void
13426 Perl_sys_intern_init(pTHX)
13427 {
13428     unsigned int ix = RAND_MAX;
13429     double x;
13430
13431     VMSISH_HUSHED = 0;
13432
13433     MY_POSIX_EXIT = vms_posix_exit;
13434
13435     x = (float)ix;
13436     MY_INV_RAND_MAX = 1./x;
13437 }
13438
13439 void
13440 init_os_extras(void)
13441 {
13442   dTHX;
13443   char* file = __FILE__;
13444   if (decc_disable_to_vms_logname_translation) {
13445     no_translate_barewords = TRUE;
13446   } else {
13447     no_translate_barewords = FALSE;
13448   }
13449
13450   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13451   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13452   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13453   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13454   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13455   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13456   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13457   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13458   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13459   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13460   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13461   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13462   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13463   newXSproto("VMS::Filespec::case_tolerant_process",
13464       case_tolerant_process_fromperl,file,"");
13465
13466   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13467
13468   return;
13469 }
13470
13471 #if __CRTL_VER == 80200000
13472 /* This missed getting in to the DECC SDK for 8.2 */
13473 char *realpath(const char *file_name, char * resolved_name, ...);
13474 #endif
13475
13476 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13477 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13478  * The perl fallback routine to provide realpath() is not as efficient
13479  * on OpenVMS.
13480  */
13481
13482 #ifdef __cplusplus
13483 extern "C" {
13484 #endif
13485
13486 /* Hack, use old stat() as fastest way of getting ino_t and device */
13487 int decc$stat(const char *name, void * statbuf);
13488 #if !defined(__VAX) && __CRTL_VER >= 80200000
13489 int decc$lstat(const char *name, void * statbuf);
13490 #else
13491 #define decc$lstat decc$stat
13492 #endif
13493
13494 #ifdef __cplusplus
13495 }
13496 #endif
13497
13498
13499 /* Realpath is fragile.  In 8.3 it does not work if the feature
13500  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13501  * links are implemented in RMS, not the CRTL. It also can fail if the
13502  * user does not have read/execute access to some of the directories.
13503  * So in order for Do What I Mean mode to work, if realpath() fails,
13504  * fall back to looking up the filename by the device name and FID.
13505  */
13506
13507 int vms_fid_to_name(char * outname, int outlen,
13508                     const char * name, int lstat_flag, mode_t * mode)
13509 {
13510 #pragma message save
13511 #pragma message disable MISALGNDSTRCT
13512 #pragma message disable MISALGNDMEM
13513 #pragma member_alignment save
13514 #pragma nomember_alignment
13515 struct statbuf_t {
13516     char           * st_dev;
13517     unsigned short st_ino[3];
13518     unsigned short old_st_mode;
13519     unsigned long  padl[30];  /* plenty of room */
13520 } statbuf;
13521 #pragma message restore
13522 #pragma member_alignment restore
13523
13524     int sts;
13525     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13526     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13527     char *fileified;
13528     char *temp_fspec;
13529     char *ret_spec;
13530
13531     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13532      * unexpected answers
13533      */
13534
13535     fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13536     if (fileified == NULL)
13537         _ckvmssts_noperl(SS$_INSFMEM);
13538
13539     temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13540     if (temp_fspec == NULL)
13541         _ckvmssts_noperl(SS$_INSFMEM);
13542
13543     sts = -1;
13544     /* First need to try as a directory */
13545     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13546     if (ret_spec != NULL) {
13547         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13548         if (ret_spec != NULL) {
13549             if (lstat_flag == 0)
13550                 sts = decc$stat(fileified, &statbuf);
13551             else
13552                 sts = decc$lstat(fileified, &statbuf);
13553         }
13554     }
13555
13556     /* Then as a VMS file spec */
13557     if (sts != 0) {
13558         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13559         if (ret_spec != NULL) {
13560             if (lstat_flag == 0) {
13561                 sts = decc$stat(temp_fspec, &statbuf);
13562             } else {
13563                 sts = decc$lstat(temp_fspec, &statbuf);
13564             }
13565         }
13566     }
13567
13568     if (sts) {
13569         /* Next try - allow multiple dots with out EFS CHARSET */
13570         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13571          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13572          * enable it if it isn't already.
13573          */
13574 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13575         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13576             decc$feature_set_value(decc_efs_charset_index, 1, 1);
13577 #endif
13578         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13579         if (lstat_flag == 0) {
13580             sts = decc$stat(name, &statbuf);
13581         } else {
13582             sts = decc$lstat(name, &statbuf);
13583         }
13584 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13585         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13586             decc$feature_set_value(decc_efs_charset_index, 1, 0);
13587 #endif
13588     }
13589
13590
13591     /* and then because the Perl Unix to VMS conversion is not perfect */
13592     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13593     /* characters from filenames so we need to try it as-is */
13594     if (sts) {
13595         if (lstat_flag == 0) {
13596             sts = decc$stat(name, &statbuf);
13597         } else {
13598             sts = decc$lstat(name, &statbuf);
13599         }
13600     }
13601
13602     if (sts == 0) {
13603         int vms_sts;
13604
13605         dvidsc.dsc$a_pointer=statbuf.st_dev;
13606         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13607
13608         specdsc.dsc$a_pointer = outname;
13609         specdsc.dsc$w_length = outlen-1;
13610
13611         vms_sts = lib$fid_to_name
13612             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13613         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13614             outname[specdsc.dsc$w_length] = 0;
13615
13616             /* Return the mode */
13617             if (mode) {
13618                 *mode = statbuf.old_st_mode;
13619             }
13620         }
13621     }
13622     PerlMem_free(temp_fspec);
13623     PerlMem_free(fileified);
13624     return sts;
13625 }
13626
13627
13628
13629 static char *
13630 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13631                    int *utf8_fl)
13632 {
13633     char * rslt = NULL;
13634
13635 #ifdef HAS_SYMLINK
13636     if (decc_posix_compliant_pathnames > 0 ) {
13637         /* realpath currently only works if posix compliant pathnames are
13638          * enabled.  It may start working when they are not, but in that
13639          * case we still want the fallback behavior for backwards compatibility
13640          */
13641         rslt = realpath(filespec, outbuf);
13642     }
13643 #endif
13644
13645     if (rslt == NULL) {
13646         char * vms_spec;
13647         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13648         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13649         mode_t my_mode;
13650
13651         /* Fall back to fid_to_name */
13652
13653         Newx(vms_spec, VMS_MAXRSS + 1, char);
13654
13655         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13656         if (sts == 0) {
13657
13658
13659             /* Now need to trim the version off */
13660             sts = vms_split_path
13661                   (vms_spec,
13662                    &v_spec,
13663                    &v_len,
13664                    &r_spec,
13665                    &r_len,
13666                    &d_spec,
13667                    &d_len,
13668                    &n_spec,
13669                    &n_len,
13670                    &e_spec,
13671                    &e_len,
13672                    &vs_spec,
13673                    &vs_len);
13674
13675
13676                 if (sts == 0) {
13677                     int haslower = 0;
13678                     const char *cp;
13679
13680                     /* Trim off the version */
13681                     int file_len = v_len + r_len + d_len + n_len + e_len;
13682                     vms_spec[file_len] = 0;
13683
13684                     /* Trim off the .DIR if this is a directory */
13685                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13686                         if (S_ISDIR(my_mode)) {
13687                             e_len = 0;
13688                             e_spec[0] = 0;
13689                         }
13690                     }
13691
13692                     /* Drop NULL extensions on UNIX file specification */
13693                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
13694                         e_len = 0;
13695                         e_spec[0] = '\0';
13696                     }
13697
13698                     /* The result is expected to be in UNIX format */
13699                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13700
13701                     /* Downcase if input had any lower case letters and
13702                      * case preservation is not in effect.
13703                      */
13704                     if (!decc_efs_case_preserve) {
13705                         for (cp = filespec; *cp; cp++)
13706                             if (islower(*cp)) { haslower = 1; break; }
13707
13708                         if (haslower) __mystrtolower(rslt);
13709                     }
13710                 }
13711         } else {
13712
13713             /* Now for some hacks to deal with backwards and forward */
13714             /* compatibility */
13715             if (!decc_efs_charset) {
13716
13717                 /* 1. ODS-2 mode wants to do a syntax only translation */
13718                 rslt = int_rmsexpand(filespec, outbuf,
13719                                     NULL, 0, NULL, utf8_fl);
13720
13721             } else {
13722                 if (decc_filename_unix_report) {
13723                     char * dir_name;
13724                     char * vms_dir_name;
13725                     char * file_name;
13726
13727                     /* 2. ODS-5 / UNIX report mode should return a failure */
13728                     /*    if the parent directory also does not exist */
13729                     /*    Otherwise, get the real path for the parent */
13730                     /*    and add the child to it. */
13731
13732                     /* basename / dirname only available for VMS 7.0+ */
13733                     /* So we may need to implement them as common routines */
13734
13735                     Newx(dir_name, VMS_MAXRSS + 1, char);
13736                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13737                     dir_name[0] = '\0';
13738                     file_name = NULL;
13739
13740                     /* First try a VMS parse */
13741                     sts = vms_split_path
13742                           (filespec,
13743                            &v_spec,
13744                            &v_len,
13745                            &r_spec,
13746                            &r_len,
13747                            &d_spec,
13748                            &d_len,
13749                            &n_spec,
13750                            &n_len,
13751                            &e_spec,
13752                            &e_len,
13753                            &vs_spec,
13754                            &vs_len);
13755
13756                     if (sts == 0) {
13757                         /* This is VMS */
13758
13759                         int dir_len = v_len + r_len + d_len + n_len;
13760                         if (dir_len > 0) {
13761                            memcpy(dir_name, filespec, dir_len);
13762                            dir_name[dir_len] = '\0';
13763                            file_name = (char *)&filespec[dir_len + 1];
13764                         }
13765                     } else {
13766                         /* This must be UNIX */
13767                         char * tchar;
13768
13769                         tchar = strrchr(filespec, '/');
13770
13771                         if (tchar != NULL) {
13772                             int dir_len = tchar - filespec;
13773                             memcpy(dir_name, filespec, dir_len);
13774                             dir_name[dir_len] = '\0';
13775                             file_name = (char *) &filespec[dir_len + 1];
13776                         }
13777                     }
13778
13779                     /* Dir name is defaulted */
13780                     if (dir_name[0] == 0) {
13781                         dir_name[0] = '.';
13782                         dir_name[1] = '\0';
13783                     }
13784
13785                     /* Need realpath for the directory */
13786                     sts = vms_fid_to_name(vms_dir_name,
13787                                           VMS_MAXRSS + 1,
13788                                           dir_name, 0, NULL);
13789
13790                     if (sts == 0) {
13791                         /* Now need to pathify it. */
13792                         char *tdir = int_pathify_dirspec(vms_dir_name,
13793                                                          outbuf);
13794
13795                         /* And now add the original filespec to it */
13796                         if (file_name != NULL) {
13797                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13798                         }
13799                         return outbuf;
13800                     }
13801                     Safefree(vms_dir_name);
13802                     Safefree(dir_name);
13803                 }
13804             }
13805         }
13806         Safefree(vms_spec);
13807     }
13808     return rslt;
13809 }
13810
13811 static char *
13812 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13813                    int *utf8_fl)
13814 {
13815     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13816     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13817
13818     /* Fall back to fid_to_name */
13819
13820     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13821     if (sts != 0) {
13822         return NULL;
13823     }
13824     else {
13825
13826
13827         /* Now need to trim the version off */
13828         sts = vms_split_path
13829                   (outbuf,
13830                    &v_spec,
13831                    &v_len,
13832                    &r_spec,
13833                    &r_len,
13834                    &d_spec,
13835                    &d_len,
13836                    &n_spec,
13837                    &n_len,
13838                    &e_spec,
13839                    &e_len,
13840                    &vs_spec,
13841                    &vs_len);
13842
13843
13844         if (sts == 0) {
13845             int haslower = 0;
13846             const char *cp;
13847
13848             /* Trim off the version */
13849             int file_len = v_len + r_len + d_len + n_len + e_len;
13850             outbuf[file_len] = 0;
13851
13852             /* Downcase if input had any lower case letters and
13853              * case preservation is not in effect.
13854              */
13855             if (!decc_efs_case_preserve) {
13856                 for (cp = filespec; *cp; cp++)
13857                     if (islower(*cp)) { haslower = 1; break; }
13858
13859                 if (haslower) __mystrtolower(outbuf);
13860             }
13861         }
13862     }
13863     return outbuf;
13864 }
13865
13866
13867 /*}}}*/
13868 /* External entry points */
13869 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13870 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13871
13872 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13873 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13874
13875 /* case_tolerant */
13876
13877 /*{{{int do_vms_case_tolerant(void)*/
13878 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13879  * controlled by a process setting.
13880  */
13881 int do_vms_case_tolerant(void)
13882 {
13883     return vms_process_case_tolerant;
13884 }
13885 /*}}}*/
13886 /* External entry points */
13887 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13888 int Perl_vms_case_tolerant(void)
13889 { return do_vms_case_tolerant(); }
13890 #else
13891 int Perl_vms_case_tolerant(void)
13892 { return vms_process_case_tolerant; }
13893 #endif
13894
13895
13896  /* Start of DECC RTL Feature handling */
13897
13898
13899 /* C RTL Feature settings */
13900
13901 #if defined(__DECC) || defined(__DECCXX)
13902
13903 #ifdef __cplusplus
13904 extern "C" {
13905 #endif
13906
13907 extern void
13908 vmsperl_set_features(void)
13909 {
13910     int status;
13911     int s;
13912     char val_str[10];
13913 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13914     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13915     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13916     unsigned long case_perm;
13917     unsigned long case_image;
13918 #endif
13919
13920     /* Allow an exception to bring Perl into the VMS debugger */
13921     vms_debug_on_exception = 0;
13922     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13923     if ($VMS_STATUS_SUCCESS(status)) {
13924        val_str[0] = _toupper(val_str[0]);
13925        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13926          vms_debug_on_exception = 1;
13927        else
13928          vms_debug_on_exception = 0;
13929     }
13930
13931     /* Debug unix/vms file translation routines */
13932     vms_debug_fileify = 0;
13933     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13934     if ($VMS_STATUS_SUCCESS(status)) {
13935         val_str[0] = _toupper(val_str[0]);
13936         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13937             vms_debug_fileify = 1;
13938         else
13939             vms_debug_fileify = 0;
13940     }
13941
13942
13943     /* Historically PERL has been doing vmsify / stat differently than */
13944     /* the CRTL.  In particular, under some conditions the CRTL will   */
13945     /* remove some illegal characters like spaces from filenames       */
13946     /* resulting in some differences.  The stat()/lstat() wrapper has  */
13947     /* been reporting such file names as invalid and fails to stat them */
13948     /* fixing this bug so that stat()/lstat() accept these like the     */
13949     /* CRTL does will result in several tests failing.                  */
13950     /* This should really be fixed, but for now, set up a feature to    */
13951     /* enable it so that the impact can be studied.                     */
13952     vms_bug_stat_filename = 0;
13953     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13954     if ($VMS_STATUS_SUCCESS(status)) {
13955         val_str[0] = _toupper(val_str[0]);
13956         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13957             vms_bug_stat_filename = 1;
13958         else
13959             vms_bug_stat_filename = 0;
13960     }
13961
13962
13963     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13964     vms_vtf7_filenames = 0;
13965     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13966     if ($VMS_STATUS_SUCCESS(status)) {
13967        val_str[0] = _toupper(val_str[0]);
13968        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13969          vms_vtf7_filenames = 1;
13970        else
13971          vms_vtf7_filenames = 0;
13972     }
13973
13974     /* unlink all versions on unlink() or rename() */
13975     vms_unlink_all_versions = 0;
13976     status = simple_trnlnm
13977         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13978     if ($VMS_STATUS_SUCCESS(status)) {
13979        val_str[0] = _toupper(val_str[0]);
13980        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13981          vms_unlink_all_versions = 1;
13982        else
13983          vms_unlink_all_versions = 0;
13984     }
13985
13986     /* Dectect running under GNV Bash or other UNIX like shell */
13987 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13988     gnv_unix_shell = 0;
13989     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13990     if ($VMS_STATUS_SUCCESS(status)) {
13991          gnv_unix_shell = 1;
13992          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13993          set_feature_default("DECC$EFS_CHARSET", 1);
13994          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13995          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13996          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13997          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13998          vms_unlink_all_versions = 1;
13999          vms_posix_exit = 1;
14000     }
14001 #endif
14002
14003     /* hacks to see if known bugs are still present for testing */
14004
14005     /* PCP mode requires creating /dev/null special device file */
14006     decc_bug_devnull = 0;
14007     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14008     if ($VMS_STATUS_SUCCESS(status)) {
14009        val_str[0] = _toupper(val_str[0]);
14010        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14011           decc_bug_devnull = 1;
14012        else
14013           decc_bug_devnull = 0;
14014     }
14015
14016     /* UNIX directory names with no paths are broken in a lot of places */
14017     decc_dir_barename = 1;
14018     status = simple_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14019     if ($VMS_STATUS_SUCCESS(status)) {
14020       val_str[0] = _toupper(val_str[0]);
14021       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14022         decc_dir_barename = 1;
14023       else
14024         decc_dir_barename = 0;
14025     }
14026
14027 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14028     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14029     if (s >= 0) {
14030         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14031         if (decc_disable_to_vms_logname_translation < 0)
14032             decc_disable_to_vms_logname_translation = 0;
14033     }
14034
14035     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14036     if (s >= 0) {
14037         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14038         if (decc_efs_case_preserve < 0)
14039             decc_efs_case_preserve = 0;
14040     }
14041
14042     s = decc$feature_get_index("DECC$EFS_CHARSET");
14043     decc_efs_charset_index = s;
14044     if (s >= 0) {
14045         decc_efs_charset = decc$feature_get_value(s, 1);
14046         if (decc_efs_charset < 0)
14047             decc_efs_charset = 0;
14048     }
14049
14050     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14051     if (s >= 0) {
14052         decc_filename_unix_report = decc$feature_get_value(s, 1);
14053         if (decc_filename_unix_report > 0) {
14054             decc_filename_unix_report = 1;
14055             vms_posix_exit = 1;
14056         }
14057         else
14058             decc_filename_unix_report = 0;
14059     }
14060
14061     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14062     if (s >= 0) {
14063         decc_filename_unix_only = decc$feature_get_value(s, 1);
14064         if (decc_filename_unix_only > 0) {
14065             decc_filename_unix_only = 1;
14066         }
14067         else {
14068             decc_filename_unix_only = 0;
14069         }
14070     }
14071
14072     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14073     if (s >= 0) {
14074         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14075         if (decc_filename_unix_no_version < 0)
14076             decc_filename_unix_no_version = 0;
14077     }
14078
14079     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14080     if (s >= 0) {
14081         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14082         if (decc_readdir_dropdotnotype < 0)
14083             decc_readdir_dropdotnotype = 0;
14084     }
14085
14086 #if __CRTL_VER >= 80200000
14087     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14088     if (s >= 0) {
14089         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14090         if (decc_posix_compliant_pathnames < 0)
14091             decc_posix_compliant_pathnames = 0;
14092         if (decc_posix_compliant_pathnames > 4)
14093             decc_posix_compliant_pathnames = 0;
14094     }
14095
14096 #endif
14097 #else
14098     status = simple_trnlnm
14099         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14100     if ($VMS_STATUS_SUCCESS(status)) {
14101         val_str[0] = _toupper(val_str[0]);
14102         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14103            decc_disable_to_vms_logname_translation = 1;
14104         }
14105     }
14106
14107 #ifndef __VAX
14108     status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14109     if ($VMS_STATUS_SUCCESS(status)) {
14110         val_str[0] = _toupper(val_str[0]);
14111         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14112            decc_efs_case_preserve = 1;
14113         }
14114     }
14115 #endif
14116
14117     status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14118     if ($VMS_STATUS_SUCCESS(status)) {
14119         val_str[0] = _toupper(val_str[0]);
14120         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14121            decc_filename_unix_report = 1;
14122         }
14123     }
14124     status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14125     if ($VMS_STATUS_SUCCESS(status)) {
14126         val_str[0] = _toupper(val_str[0]);
14127         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14128            decc_filename_unix_only = 1;
14129            decc_filename_unix_report = 1;
14130         }
14131     }
14132     status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14133     if ($VMS_STATUS_SUCCESS(status)) {
14134         val_str[0] = _toupper(val_str[0]);
14135         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14136            decc_filename_unix_no_version = 1;
14137         }
14138     }
14139     status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14140     if ($VMS_STATUS_SUCCESS(status)) {
14141         val_str[0] = _toupper(val_str[0]);
14142         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14143            decc_readdir_dropdotnotype = 1;
14144         }
14145     }
14146 #endif
14147
14148 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14149
14150      /* Report true case tolerance */
14151     /*----------------------------*/
14152     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14153     if (!$VMS_STATUS_SUCCESS(status))
14154         case_perm = PPROP$K_CASE_BLIND;
14155     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14156     if (!$VMS_STATUS_SUCCESS(status))
14157         case_image = PPROP$K_CASE_BLIND;
14158     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14159         (case_image == PPROP$K_CASE_SENSITIVE))
14160         vms_process_case_tolerant = 0;
14161
14162 #endif
14163
14164     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14165     /* for strict backward compatibility */
14166     status = simple_trnlnm
14167         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14168     if ($VMS_STATUS_SUCCESS(status)) {
14169        val_str[0] = _toupper(val_str[0]);
14170        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14171          vms_posix_exit = 1;
14172        else
14173          vms_posix_exit = 0;
14174     }
14175 }
14176
14177 /* Use 32-bit pointers because that's what the image activator
14178  * assumes for the LIB$INITIALZE psect.
14179  */
14180 #if __INITIAL_POINTER_SIZE
14181 #pragma pointer_size save
14182 #pragma pointer_size 32
14183 #endif
14184
14185 /* Create a reference to the LIB$INITIALIZE function. */
14186 extern void LIB$INITIALIZE(void);
14187 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14188
14189 /* Create an array of pointers to the init functions in the special
14190  * LIB$INITIALIZE section. In our case, the array only has one entry.
14191  */
14192 #pragma extern_model save
14193 #pragma extern_model strict_refdef "LIB$INITIALIZE" gbl,noexe,nowrt,noshr,long
14194 extern void (* const vmsperl_unused_global_2[])() =
14195 {
14196    vmsperl_set_features,
14197 };
14198 #pragma extern_model restore
14199
14200 #if __INITIAL_POINTER_SIZE
14201 #pragma pointer_size restore
14202 #endif
14203
14204 #ifdef __cplusplus
14205 }
14206 #endif
14207
14208 #endif /* defined(__DECC) || defined(__DECCXX) */
14209 /*  End of vms.c */