vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
   6  *    2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
   7  *
   8  *    You may distribute under the terms of either the GNU General Public
   9  *    License or the Artistic License, as specified in the README file.
  10  *
  11  *    Please see Changes*.* or the Perl Repository Browser for revision history.
  12  */
  13
  14 /*
  15  *   Yet small as was their hunted band
  16  *   still fell and fearless was each hand,
  17  *   and strong deeds they wrought yet oft,
  18  *   and loved the woods, whose ways more soft
  19  *   them seemed than thralls of that black throne
  20  *   to live and languish in halls of stone.
  21  *        "The Lay of Leithian", Canto II, lines 135-40
  22  *
  23  *     [p.162 of _The Lays of Beleriand_]
  24  */
  25
  26 #include <acedef.h>
  27 #include <acldef.h>
  28 #include <armdef.h>
  29 #if __CRTL_VER < 70300000
  30 /* needed for home-rolled utime() */
  31 #include <atrdef.h>
  32 #include <fibdef.h>
  33 #endif
  34 #include <chpdef.h>
  35 #include <clidef.h>
  36 #include <climsgdef.h>
  37 #include <dcdef.h>
  38 #include <descrip.h>
  39 #include <devdef.h>
  40 #include <dvidef.h>
  41 #include <float.h>
  42 #include <fscndef.h>
  43 #include <iodef.h>
  44 #include <jpidef.h>
  45 #include <kgbdef.h>
  46 #include <libclidef.h>
  47 #include <libdef.h>
  48 #include <lib$routines.h>
  49 #include <lnmdef.h>
  50 #include <ossdef.h>
  51 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  52 #include <ppropdef.h>
  53 #endif
  54 #include <prvdef.h>
  55 #include <psldef.h>
  56 #include <rms.h>
  57 #include <shrdef.h>
  58 #include <ssdef.h>
  59 #include <starlet.h>
  60 #include <strdef.h>
  61 #include <str$routines.h>
  62 #include <syidef.h>
  63 #include <uaidef.h>
  64 #include <uicdef.h>
  65 #include <stsdef.h>
  66 #include <efndef.h>
  67 #define NO_EFN EFN$C_ENF
  68
  69 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  70 int   decc$feature_get_index(const char *name);
  71 char* decc$feature_get_name(int index);
  72 int   decc$feature_get_value(int index, int mode);
  73 int   decc$feature_set_value(int index, int mode, int value);
  74 #else
  75 #include <unixlib.h>
  76 #endif
  77
  78 #pragma member_alignment save
  79 #pragma nomember_alignment longword
  80 struct item_list_3 {
  81         unsigned short len;
  82         unsigned short code;
  83         void * bufadr;
  84         unsigned short * retadr;
  85 };
  86 #pragma member_alignment restore
  87
  88 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  89
  90 static int set_feature_default(const char *name, int value)
  91 {
  92     int status;
  93     int index;
  94
  95     index = decc$feature_get_index(name);
  96
  97     status = decc$feature_set_value(index, 1, value);
  98     if (index == -1 || (status == -1)) {
  99       return -1;
 100     }
 101
 102     status = decc$feature_get_value(index, 1);
 103     if (status != value) {
 104       return -1;
 105     }
 106
 107 return 0;
 108 }
 109 #endif
 110
 111 /* Older versions of ssdef.h don't have these */
 112 #ifndef SS$_INVFILFOROP
 113 #  define SS$_INVFILFOROP 3930
 114 #endif
 115 #ifndef SS$_NOSUCHOBJECT
 116 #  define SS$_NOSUCHOBJECT 2696
 117 #endif
 118
 119 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 120 #define PERLIO_NOT_STDIO 0
 121
 122 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 123  * code below needs to get to the underlying CRTL routines. */
 124 #define DONT_MASK_RTL_CALLS
 125 #include "EXTERN.h"
 126 #include "perl.h"
 127 #include "XSUB.h"
 128 /* Anticipating future expansion in lexical warnings . . . */
 129 #ifndef WARN_INTERNAL
 130 #  define WARN_INTERNAL WARN_MISC
 131 #endif
 132
 133 #ifdef VMS_LONGNAME_SUPPORT
 134 #include <libfildef.h>
 135 #endif
 136
 137 #if !defined(__VAX) && __CRTL_VER >= 80200000
 138 #ifdef lstat
 139 #undef lstat
 140 #endif
 141 #else
 142 #ifdef lstat
 143 #undef lstat
 144 #endif
 145 #define lstat(_x, _y) stat(_x, _y)
 146 #endif
 147
 148 /* Routine to create a decterm for use with the Perl debugger */
 149 /* No headers, this information was found in the Programming Concepts Manual */
 150
 151 static int (*decw_term_port)
 152    (const struct dsc$descriptor_s * display,
 153     const struct dsc$descriptor_s * setup_file,
 154     const struct dsc$descriptor_s * customization,
 155     struct dsc$descriptor_s * result_device_name,
 156     unsigned short * result_device_name_length,
 157     void * controller,
 158     void * char_buffer,
 159     void * char_change_buffer) = 0;
 160
 161 /* gcc's header files don't #define direct access macros
 162  * corresponding to VAXC's variant structs */
 163 #ifdef __GNUC__
 164 #  define uic$v_format uic$r_uic_form.uic$v_format
 165 #  define uic$v_group uic$r_uic_form.uic$v_group
 166 #  define uic$v_member uic$r_uic_form.uic$v_member
 167 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 168 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 169 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 170 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 171 #endif
 172
 173 #if defined(NEED_AN_H_ERRNO)
 174 dEXT int h_errno;
 175 #endif
 176
 177 #ifdef __DECC
 178 #pragma message disable pragma
 179 #pragma member_alignment save
 180 #pragma nomember_alignment longword
 181 #pragma message save
 182 #pragma message disable misalgndmem
 183 #endif
 184 struct itmlst_3 {
 185   unsigned short int buflen;
 186   unsigned short int itmcode;
 187   void *bufadr;
 188   unsigned short int *retlen;
 189 };
 190
 191 struct filescan_itmlst_2 {
 192     unsigned short length;
 193     unsigned short itmcode;
 194     char * component;
 195 };
 196
 197 struct vs_str_st {
 198     unsigned short length;
 199     char str[65536];
 200 };
 201
 202 #ifdef __DECC
 203 #pragma message restore
 204 #pragma member_alignment restore
 205 #endif
 206
 207 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 208 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 209 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 210 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 211 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 212 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 213 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 214 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 215 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 216 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 217 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 218 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 219
 220 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 221 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 222 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 223 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 224
 225 static char *  int_rmsexpand_vms(
 226     const char * filespec, char * outbuf, unsigned opts);
 227 static char * int_rmsexpand_tovms(
 228     const char * filespec, char * outbuf, unsigned opts);
 229 static char *int_tovmsspec
 230    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 231 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 232 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 233 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 234
 235 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 236 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 237
 238 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 239  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 240  * the Perl facility.
 241  */
 242 #define PERL_LNM_MAX_ITER 10
 243
 244   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 245 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 246 #define MAX_DCL_SYMBOL          (8192)
 247 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 248 #else
 249 #define MAX_DCL_SYMBOL          (1024)
 250 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 251 #endif
 252
 253 static char *__mystrtolower(char *str)
 254 {
 255   if (str) for (; *str; ++str) *str= tolower(*str);
 256   return str;
 257 }
 258
 259 static struct dsc$descriptor_s fildevdsc =
 260   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 261 static struct dsc$descriptor_s crtlenvdsc =
 262   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 263 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 264 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 265 static struct dsc$descriptor_s **env_tables = defenv;
 266 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 267
 268 /* True if we shouldn't treat barewords as logicals during directory */
 269 /* munching */
 270 static int no_translate_barewords;
 271
 272 /* DECC Features that may need to affect how Perl interprets
 273  * displays filename information
 274  */
 275 static int decc_disable_to_vms_logname_translation = 1;
 276 static int decc_disable_posix_root = 1;
 277 int decc_efs_case_preserve = 0;
 278 static int decc_efs_charset = 0;
 279 static int decc_efs_charset_index = -1;
 280 static int decc_filename_unix_no_version = 0;
 281 static int decc_filename_unix_only = 0;
 282 int decc_filename_unix_report = 0;
 283 int decc_posix_compliant_pathnames = 0;
 284 int decc_readdir_dropdotnotype = 0;
 285 static int vms_process_case_tolerant = 1;
 286 int vms_vtf7_filenames = 0;
 287 int gnv_unix_shell = 0;
 288 static int vms_unlink_all_versions = 0;
 289 static int vms_posix_exit = 0;
 290
 291 /* bug workarounds if needed */
 292 int decc_bug_devnull = 1;
 293 int decc_dir_barename = 0;
 294 int vms_bug_stat_filename = 0;
 295
 296 static int vms_debug_on_exception = 0;
 297 static int vms_debug_fileify = 0;
 298
 299 /* Simple logical name translation */
 300 static int simple_trnlnm
 301    (const char * logname,
 302     char * value,
 303     int value_len)
 304 {
 305     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 306     const unsigned long attr = LNM$M_CASE_BLIND;
 307     struct dsc$descriptor_s name_dsc;
 308     int status;
 309     unsigned short result;
 310     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 311                                 {0, 0, 0, 0}};
 312
 313     name_dsc.dsc$w_length = strlen(logname);
 314     name_dsc.dsc$a_pointer = (char *)logname;
 315     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 316     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 317
 318     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 319
 320     if ($VMS_STATUS_SUCCESS(status)) {
 321
 322          /* Null terminate and return the string */
 323         /*--------------------------------------*/
 324         value[result] = 0;
 325         return result;
 326     }
 327
 328     return 0;
 329 }
 330
 331
 332 /* Is this a UNIX file specification?
 333  *   No longer a simple check with EFS file specs
 334  *   For now, not a full check, but need to
 335  *   handle POSIX ^UP^ specifications
 336  *   Fixing to handle ^/ cases would require
 337  *   changes to many other conversion routines.
 338  */
 339
 340 static int is_unix_filespec(const char *path)
 341 {
 342 int ret_val;
 343 const char * pch1;
 344
 345     ret_val = 0;
 346     if (strncmp(path,"\"^UP^",5) != 0) {
 347         pch1 = strchr(path, '/');
 348         if (pch1 != NULL)
 349             ret_val = 1;
 350         else {
 351
 352             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 353             if (decc_filename_unix_report || decc_filename_unix_only) {
 354             if (strcmp(path,".") == 0)
 355                 ret_val = 1;
 356             }
 357         }
 358     }
 359     return ret_val;
 360 }
 361
 362 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 363  */
 364
 365 static void ucs2_to_vtf7
 366    (char *outspec,
 367     unsigned long ucs2_char,
 368     int * output_cnt)
 369 {
 370 unsigned char * ucs_ptr;
 371 int hex;
 372
 373     ucs_ptr = (unsigned char *)&ucs2_char;
 374
 375     outspec[0] = '^';
 376     outspec[1] = 'U';
 377     hex = (ucs_ptr[1] >> 4) & 0xf;
 378     if (hex < 0xA)
 379         outspec[2] = hex + '0';
 380     else
 381         outspec[2] = (hex - 9) + 'A';
 382     hex = ucs_ptr[1] & 0xF;
 383     if (hex < 0xA)
 384         outspec[3] = hex + '0';
 385     else {
 386         outspec[3] = (hex - 9) + 'A';
 387     }
 388     hex = (ucs_ptr[0] >> 4) & 0xf;
 389     if (hex < 0xA)
 390         outspec[4] = hex + '0';
 391     else
 392         outspec[4] = (hex - 9) + 'A';
 393     hex = ucs_ptr[1] & 0xF;
 394     if (hex < 0xA)
 395         outspec[5] = hex + '0';
 396     else {
 397         outspec[5] = (hex - 9) + 'A';
 398     }
 399     *output_cnt = 6;
 400 }
 401
 402
 403 /* This handles the conversion of a UNIX extended character set to a ^
 404  * escaped VMS character.
 405  * in a UNIX file specification.
 406  *
 407  * The output count variable contains the number of characters added
 408  * to the output string.
 409  *
 410  * The return value is the number of characters read from the input string
 411  */
 412 static int copy_expand_unix_filename_escape
 413   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 414 {
 415 int count;
 416 int utf8_flag;
 417
 418     utf8_flag = 0;
 419     if (utf8_fl)
 420       utf8_flag = *utf8_fl;
 421
 422     count = 0;
 423     *output_cnt = 0;
 424     if (*inspec >= 0x80) {
 425         if (utf8_fl && vms_vtf7_filenames) {
 426         unsigned long ucs_char;
 427
 428             ucs_char = 0;
 429
 430             if ((*inspec & 0xE0) == 0xC0) {
 431                 /* 2 byte Unicode */
 432                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 433                 if (ucs_char >= 0x80) {
 434                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 435                     return 2;
 436                 }
 437             } else if ((*inspec & 0xF0) == 0xE0) {
 438                 /* 3 byte Unicode */
 439                 ucs_char = ((inspec[0] & 0xF) << 12) +
 440                    ((inspec[1] & 0x3f) << 6) +
 441                    (inspec[2] & 0x3f);
 442                 if (ucs_char >= 0x800) {
 443                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 444                     return 3;
 445                 }
 446
 447 #if 0 /* I do not see longer sequences supported by OpenVMS */
 448       /* Maybe some one can fix this later */
 449             } else if ((*inspec & 0xF8) == 0xF0) {
 450                 /* 4 byte Unicode */
 451                 /* UCS-4 to UCS-2 */
 452             } else if ((*inspec & 0xFC) == 0xF8) {
 453                 /* 5 byte Unicode */
 454                 /* UCS-4 to UCS-2 */
 455             } else if ((*inspec & 0xFE) == 0xFC) {
 456                 /* 6 byte Unicode */
 457                 /* UCS-4 to UCS-2 */
 458 #endif
 459             }
 460         }
 461
 462         /* High bit set, but not a Unicode character! */
 463
 464         /* Non printing DECMCS or ISO Latin-1 character? */
 465         if ((unsigned char)*inspec <= 0x9F) {
 466             int hex;
 467             outspec[0] = '^';
 468             outspec++;
 469             hex = (*inspec >> 4) & 0xF;
 470             if (hex < 0xA)
 471                 outspec[1] = hex + '0';
 472             else {
 473                 outspec[1] = (hex - 9) + 'A';
 474             }
 475             hex = *inspec & 0xF;
 476             if (hex < 0xA)
 477                 outspec[2] = hex + '0';
 478             else {
 479                 outspec[2] = (hex - 9) + 'A';
 480             }
 481             *output_cnt = 3;
 482             return 1;
 483         } else if ((unsigned char)*inspec == 0xA0) {
 484             outspec[0] = '^';
 485             outspec[1] = 'A';
 486             outspec[2] = '0';
 487             *output_cnt = 3;
 488             return 1;
 489         } else if ((unsigned char)*inspec == 0xFF) {
 490             outspec[0] = '^';
 491             outspec[1] = 'F';
 492             outspec[2] = 'F';
 493             *output_cnt = 3;
 494             return 1;
 495         }
 496         *outspec = *inspec;
 497         *output_cnt = 1;
 498         return 1;
 499     }
 500
 501     /* Is this a macro that needs to be passed through?
 502      * Macros start with $( and an alpha character, followed
 503      * by a string of alpha numeric characters ending with a )
 504      * If this does not match, then encode it as ODS-5.
 505      */
 506     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 507     int tcnt;
 508
 509         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 510             tcnt = 3;
 511             outspec[0] = inspec[0];
 512             outspec[1] = inspec[1];
 513             outspec[2] = inspec[2];
 514
 515             while(isalnum(inspec[tcnt]) ||
 516                   (inspec[2] == '.') || (inspec[2] == '_')) {
 517                 outspec[tcnt] = inspec[tcnt];
 518                 tcnt++;
 519             }
 520             if (inspec[tcnt] == ')') {
 521                 outspec[tcnt] = inspec[tcnt];
 522                 tcnt++;
 523                 *output_cnt = tcnt;
 524                 return tcnt;
 525             }
 526         }
 527     }
 528
 529     switch (*inspec) {
 530     case 0x7f:
 531         outspec[0] = '^';
 532         outspec[1] = '7';
 533         outspec[2] = 'F';
 534         *output_cnt = 3;
 535         return 1;
 536         break;
 537     case '?':
 538         if (decc_efs_charset == 0)
 539           outspec[0] = '%';
 540         else
 541           outspec[0] = '?';
 542         *output_cnt = 1;
 543         return 1;
 544         break;
 545     case '.':
 546     case '~':
 547     case '!':
 548     case '#':
 549     case '&':
 550     case '\'':
 551     case '`':
 552     case '(':
 553     case ')':
 554     case '+':
 555     case '@':
 556     case '{':
 557     case '}':
 558     case ',':
 559     case ';':
 560     case '[':
 561     case ']':
 562     case '%':
 563     case '^':
 564     case '\\':
 565         /* Don't escape again if following character is
 566          * already something we escape.
 567          */
 568         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 569             *outspec = *inspec;
 570             *output_cnt = 1;
 571             return 1;
 572             break;
 573         }
 574         /* But otherwise fall through and escape it. */
 575     case '=':
 576         /* Assume that this is to be escaped */
 577         outspec[0] = '^';
 578         outspec[1] = *inspec;
 579         *output_cnt = 2;
 580         return 1;
 581         break;
 582     case ' ': /* space */
 583         /* Assume that this is to be escaped */
 584         outspec[0] = '^';
 585         outspec[1] = '_';
 586         *output_cnt = 2;
 587         return 1;
 588         break;
 589     default:
 590         *outspec = *inspec;
 591         *output_cnt = 1;
 592         return 1;
 593         break;
 594     }
 595 }
 596
 597
 598 /* This handles the expansion of a '^' prefix to the proper character
 599  * in a UNIX file specification.
 600  *
 601  * The output count variable contains the number of characters added
 602  * to the output string.
 603  *
 604  * The return value is the number of characters read from the input
 605  * string
 606  */
 607 static int copy_expand_vms_filename_escape
 608   (char *outspec, const char *inspec, int *output_cnt)
 609 {
 610 int count;
 611 int scnt;
 612
 613     count = 0;
 614     *output_cnt = 0;
 615     if (*inspec == '^') {
 616         inspec++;
 617         switch (*inspec) {
 618         /* Spaces and non-trailing dots should just be passed through,
 619          * but eat the escape character.
 620          */
 621         case '.':
 622             *outspec = *inspec;
 623             count += 2;
 624             (*output_cnt)++;
 625             break;
 626         case '_': /* space */
 627             *outspec = ' ';
 628             count += 2;
 629             (*output_cnt)++;
 630             break;
 631         case '^':
 632             /* Hmm.  Better leave the escape escaped. */
 633             outspec[0] = '^';
 634             outspec[1] = '^';
 635             count += 2;
 636             (*output_cnt) += 2;
 637             break;
 638         case 'U': /* Unicode - FIX-ME this is wrong. */
 639             inspec++;
 640             count++;
 641             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 642             if (scnt == 4) {
 643                 unsigned int c1, c2;
 644                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 645                 outspec[0] = c1 & 0xff;
 646                 outspec[1] = c2 & 0xff;
 647                 if (scnt > 1) {
 648                     (*output_cnt) += 2;
 649                     count += 4;
 650                 }
 651             }
 652             else {
 653                 /* Error - do best we can to continue */
 654                 *outspec = 'U';
 655                 outspec++;
 656                 (*output_cnt++);
 657                 *outspec = *inspec;
 658                 count++;
 659                 (*output_cnt++);
 660             }
 661             break;
 662         default:
 663             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 664             if (scnt == 2) {
 665                 /* Hex encoded */
 666                 unsigned int c1;
 667                 scnt = sscanf(inspec, "%2x", &c1);
 668                 outspec[0] = c1 & 0xff;
 669                 if (scnt > 0) {
 670                     (*output_cnt++);
 671                     count += 2;
 672                 }
 673             }
 674             else {
 675                 *outspec = *inspec;
 676                 count++;
 677                 (*output_cnt++);
 678             }
 679         }
 680     }
 681     else {
 682         *outspec = *inspec;
 683         count++;
 684         (*output_cnt)++;
 685     }
 686     return count;
 687 }
 688
 689 /* vms_split_path - Verify that the input file specification is a
 690  * VMS format file specification, and provide pointers to the components of
 691  * it.  With EFS format filenames, this is virtually the only way to
 692  * parse a VMS path specification into components.
 693  *
 694  * If the sum of the components do not add up to the length of the
 695  * string, then the passed file specification is probably a UNIX style
 696  * path.
 697  */
 698 static int vms_split_path
 699    (const char * path,
 700     char * * volume,
 701     int * vol_len,
 702     char * * root,
 703     int * root_len,
 704     char * * dir,
 705     int * dir_len,
 706     char * * name,
 707     int * name_len,
 708     char * * ext,
 709     int * ext_len,
 710     char * * version,
 711     int * ver_len)
 712 {
 713 struct dsc$descriptor path_desc;
 714 int status;
 715 unsigned long flags;
 716 int ret_stat;
 717 struct filescan_itmlst_2 item_list[9];
 718 const int filespec = 0;
 719 const int nodespec = 1;
 720 const int devspec = 2;
 721 const int rootspec = 3;
 722 const int dirspec = 4;
 723 const int namespec = 5;
 724 const int typespec = 6;
 725 const int verspec = 7;
 726
 727     /* Assume the worst for an easy exit */
 728     ret_stat = -1;
 729     *volume = NULL;
 730     *vol_len = 0;
 731     *root = NULL;
 732     *root_len = 0;
 733     *dir = NULL;
 734     *name = NULL;
 735     *name_len = 0;
 736     *ext = NULL;
 737     *ext_len = 0;
 738     *version = NULL;
 739     *ver_len = 0;
 740
 741     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 742     path_desc.dsc$w_length = strlen(path);
 743     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 744     path_desc.dsc$b_class = DSC$K_CLASS_S;
 745
 746     /* Get the total length, if it is shorter than the string passed
 747      * then this was probably not a VMS formatted file specification
 748      */
 749     item_list[filespec].itmcode = FSCN$_FILESPEC;
 750     item_list[filespec].length = 0;
 751     item_list[filespec].component = NULL;
 752
 753     /* If the node is present, then it gets considered as part of the
 754      * volume name to hopefully make things simple.
 755      */
 756     item_list[nodespec].itmcode = FSCN$_NODE;
 757     item_list[nodespec].length = 0;
 758     item_list[nodespec].component = NULL;
 759
 760     item_list[devspec].itmcode = FSCN$_DEVICE;
 761     item_list[devspec].length = 0;
 762     item_list[devspec].component = NULL;
 763
 764     /* root is a special case,  adding it to either the directory or
 765      * the device components will probably complicate things for the
 766      * callers of this routine, so leave it separate.
 767      */
 768     item_list[rootspec].itmcode = FSCN$_ROOT;
 769     item_list[rootspec].length = 0;
 770     item_list[rootspec].component = NULL;
 771
 772     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 773     item_list[dirspec].length = 0;
 774     item_list[dirspec].component = NULL;
 775
 776     item_list[namespec].itmcode = FSCN$_NAME;
 777     item_list[namespec].length = 0;
 778     item_list[namespec].component = NULL;
 779
 780     item_list[typespec].itmcode = FSCN$_TYPE;
 781     item_list[typespec].length = 0;
 782     item_list[typespec].component = NULL;
 783
 784     item_list[verspec].itmcode = FSCN$_VERSION;
 785     item_list[verspec].length = 0;
 786     item_list[verspec].component = NULL;
 787
 788     item_list[8].itmcode = 0;
 789     item_list[8].length = 0;
 790     item_list[8].component = NULL;
 791
 792     status = sys$filescan
 793        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 794         &flags, NULL, NULL);
 795     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 796
 797     /* If we parsed it successfully these two lengths should be the same */
 798     if (path_desc.dsc$w_length != item_list[filespec].length)
 799         return ret_stat;
 800
 801     /* If we got here, then it is a VMS file specification */
 802     ret_stat = 0;
 803
 804     /* set the volume name */
 805     if (item_list[nodespec].length > 0) {
 806         *volume = item_list[nodespec].component;
 807         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 808     }
 809     else {
 810         *volume = item_list[devspec].component;
 811         *vol_len = item_list[devspec].length;
 812     }
 813
 814     *root = item_list[rootspec].component;
 815     *root_len = item_list[rootspec].length;
 816
 817     *dir = item_list[dirspec].component;
 818     *dir_len = item_list[dirspec].length;
 819
 820     /* Now fun with versions and EFS file specifications
 821      * The parser can not tell the difference when a "." is a version
 822      * delimiter or a part of the file specification.
 823      */
 824     if ((decc_efs_charset) &&
 825         (item_list[verspec].length > 0) &&
 826         (item_list[verspec].component[0] == '.')) {
 827         *name = item_list[namespec].component;
 828         *name_len = item_list[namespec].length + item_list[typespec].length;
 829         *ext = item_list[verspec].component;
 830         *ext_len = item_list[verspec].length;
 831         *version = NULL;
 832         *ver_len = 0;
 833     }
 834     else {
 835         *name = item_list[namespec].component;
 836         *name_len = item_list[namespec].length;
 837         *ext = item_list[typespec].component;
 838         *ext_len = item_list[typespec].length;
 839         *version = item_list[verspec].component;
 840         *ver_len = item_list[verspec].length;
 841     }
 842     return ret_stat;
 843 }
 844
 845 /* Routine to determine if the file specification ends with .dir */
 846 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 847
 848     /* e_len must be 4, and version must be <= 2 characters */
 849     if (e_len != 4 || vs_len > 2)
 850         return 0;
 851
 852     /* If a version number is present, it needs to be one */
 853     if ((vs_len == 2) && (vs_spec[1] != '1'))
 854         return 0;
 855
 856     /* Look for the DIR on the extension */
 857     if (vms_process_case_tolerant) {
 858         if ((toupper(e_spec[1]) == 'D') &&
 859             (toupper(e_spec[2]) == 'I') &&
 860             (toupper(e_spec[3]) == 'R')) {
 861             return 1;
 862         }
 863     } else {
 864         /* Directory extensions are supposed to be in upper case only */
 865         /* I would not be surprised if this rule can not be enforced */
 866         /* if and when someone fully debugs the case sensitive mode */
 867         if ((e_spec[1] == 'D') &&
 868             (e_spec[2] == 'I') &&
 869             (e_spec[3] == 'R')) {
 870             return 1;
 871         }
 872     }
 873     return 0;
 874 }
 875
 876
 877 /* my_maxidx
 878  * Routine to retrieve the maximum equivalence index for an input
 879  * logical name.  Some calls to this routine have no knowledge if
 880  * the variable is a logical or not.  So on error we return a max
 881  * index of zero.
 882  */
 883 /*{{{int my_maxidx(const char *lnm) */
 884 static int
 885 my_maxidx(const char *lnm)
 886 {
 887     int status;
 888     int midx;
 889     int attr = LNM$M_CASE_BLIND;
 890     struct dsc$descriptor lnmdsc;
 891     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 892                                 {0, 0, 0, 0}};
 893
 894     lnmdsc.dsc$w_length = strlen(lnm);
 895     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 896     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 897     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 898
 899     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 900     if ((status & 1) == 0)
 901        midx = 0;
 902
 903     return (midx);
 904 }
 905 /*}}}*/
 906
 907 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 908 int
 909 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 910   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 911 {
 912     const char *cp1;
 913     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 914     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 915     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 916     int midx;
 917     unsigned char acmode;
 918     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 919                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 920     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 921                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 922                                  {0, 0, 0, 0}};
 923     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 924 #if defined(PERL_IMPLICIT_CONTEXT)
 925     pTHX = NULL;
 926     if (PL_curinterp) {
 927       aTHX = PERL_GET_INTERP;
 928     } else {
 929       aTHX = NULL;
 930     }
 931 #endif
 932
 933     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 934       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 935     }
 936     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 937       *cp2 = _toupper(*cp1);
 938       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 939         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 940         return 0;
 941       }
 942     }
 943     lnmdsc.dsc$w_length = cp1 - lnm;
 944     lnmdsc.dsc$a_pointer = uplnm;
 945     uplnm[lnmdsc.dsc$w_length] = '\0';
 946     secure = flags & PERL__TRNENV_SECURE;
 947     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 948     if (!tabvec || !*tabvec) tabvec = env_tables;
 949
 950     for (curtab = 0; tabvec[curtab]; curtab++) {
 951       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 952         if (!ivenv && !secure) {
 953           char *eq;
 954           int i;
 955           if (!environ) {
 956             ivenv = 1;
 957 #if defined(PERL_IMPLICIT_CONTEXT)
 958             if (aTHX == NULL) {
 959                 fprintf(stderr,
 960                     "Can't read CRTL environ\n");
 961             } else
 962 #endif
 963                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 964             continue;
 965           }
 966           retsts = SS$_NOLOGNAM;
 967           for (i = 0; environ[i]; i++) {
 968             if ((eq = strchr(environ[i],'=')) &&
 969                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 970                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 971               eq++;
 972               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 973               if (!eqvlen) continue;
 974               retsts = SS$_NORMAL;
 975               break;
 976             }
 977           }
 978           if (retsts != SS$_NOLOGNAM) break;
 979         }
 980       }
 981       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 982                !str$case_blind_compare(&tmpdsc,&clisym)) {
 983         if (!ivsym && !secure) {
 984           unsigned short int deflen = LNM$C_NAMLENGTH;
 985           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 986           /* dynamic dsc to accommodate possible long value */
 987           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 988           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 989           if (retsts & 1) {
 990             if (eqvlen > MAX_DCL_SYMBOL) {
 991               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 992               eqvlen = MAX_DCL_SYMBOL;
 993               /* Special hack--we might be called before the interpreter's */
 994               /* fully initialized, in which case either thr or PL_curcop */
 995               /* might be bogus. We have to check, since ckWARN needs them */
 996               /* both to be valid if running threaded */
 997 #if defined(PERL_IMPLICIT_CONTEXT)
 998               if (aTHX == NULL) {
 999                   fprintf(stderr,
1000                      "Value of CLI symbol \"%s\" too long",lnm);
1001               } else
1002 #endif
1003                 if (ckWARN(WARN_MISC)) {
1004                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1005                 }
1006             }
1007             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1008           }
1009           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1010           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1011           if (retsts == LIB$_NOSUCHSYM) continue;
1012           break;
1013         }
1014       }
1015       else if (!ivlnm) {
1016         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1017           midx = my_maxidx(lnm);
1018           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1019             lnmlst[1].bufadr = cp2;
1020             eqvlen = 0;
1021             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1022             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1023             if (retsts == SS$_NOLOGNAM) break;
1024             /* PPFs have a prefix */
1025             if (
1026 #if INTSIZE == 4
1027                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1028 #endif
1029                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1030                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1031                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1032                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1033                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1034               memmove(eqv,eqv+4,eqvlen-4);
1035               eqvlen -= 4;
1036             }
1037             cp2 += eqvlen;
1038             *cp2 = '\0';
1039           }
1040           if ((retsts == SS$_IVLOGNAM) ||
1041               (retsts == SS$_NOLOGNAM)) { continue; }
1042         }
1043         else {
1044           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1045           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1046           if (retsts == SS$_NOLOGNAM) continue;
1047           eqv[eqvlen] = '\0';
1048         }
1049         eqvlen = strlen(eqv);
1050         break;
1051       }
1052     }
1053     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1054     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1055              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1056              retsts == SS$_NOLOGNAM) {
1057       set_errno(EINVAL);  set_vaxc_errno(retsts);
1058     }
1059     else _ckvmssts_noperl(retsts);
1060     return 0;
1061 }  /* end of vmstrnenv */
1062 /*}}}*/
1063
1064 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1065 /* Define as a function so we can access statics. */
1066 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1067 {
1068     int flags = 0;
1069
1070 #if defined(PERL_IMPLICIT_CONTEXT)
1071     if (aTHX != NULL)
1072 #endif
1073 #ifdef SECURE_INTERNAL_GETENV
1074         flags = (PL_curinterp ? PL_tainting : will_taint) ?
1075                  PERL__TRNENV_SECURE : 0;
1076 #endif
1077
1078     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1079 }
1080 /*}}}*/
1081
1082 /* my_getenv
1083  * Note: Uses Perl temp to store result so char * can be returned to
1084  * caller; this pointer will be invalidated at next Perl statement
1085  * transition.
1086  * We define this as a function rather than a macro in terms of my_getenv_len()
1087  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1088  * allocate SVs).
1089  */
1090 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1091 char *
1092 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1093 {
1094     const char *cp1;
1095     static char *__my_getenv_eqv = NULL;
1096     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1097     unsigned long int idx = 0;
1098     int success, secure, saverr, savvmserr;
1099     int midx, flags;
1100     SV *tmpsv;
1101
1102     midx = my_maxidx(lnm) + 1;
1103
1104     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1105       /* Set up a temporary buffer for the return value; Perl will
1106        * clean it up at the next statement transition */
1107       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1108       if (!tmpsv) return NULL;
1109       eqv = SvPVX(tmpsv);
1110     }
1111     else {
1112       /* Assume no interpreter ==> single thread */
1113       if (__my_getenv_eqv != NULL) {
1114         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1115       }
1116       else {
1117         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1118       }
1119       eqv = __my_getenv_eqv;
1120     }
1121
1122     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1123     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1124       int len;
1125       getcwd(eqv,LNM$C_NAMLENGTH);
1126
1127       len = strlen(eqv);
1128
1129       /* Get rid of "000000/ in rooted filespecs */
1130       if (len > 7) {
1131         char * zeros;
1132         zeros = strstr(eqv, "/000000/");
1133         if (zeros != NULL) {
1134           int mlen;
1135           mlen = len - (zeros - eqv) - 7;
1136           memmove(zeros, &zeros[7], mlen);
1137           len = len - 7;
1138           eqv[len] = '\0';
1139         }
1140       }
1141       return eqv;
1142     }
1143     else {
1144       /* Impose security constraints only if tainting */
1145       if (sys) {
1146         /* Impose security constraints only if tainting */
1147         secure = PL_curinterp ? PL_tainting : will_taint;
1148         saverr = errno;  savvmserr = vaxc$errno;
1149       }
1150       else {
1151         secure = 0;
1152       }
1153
1154       flags =
1155 #ifdef SECURE_INTERNAL_GETENV
1156               secure ? PERL__TRNENV_SECURE : 0
1157 #else
1158               0
1159 #endif
1160       ;
1161
1162       /* For the getenv interface we combine all the equivalence names
1163        * of a search list logical into one value to acquire a maximum
1164        * value length of 255*128 (assuming %ENV is using logicals).
1165        */
1166       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1167
1168       /* If the name contains a semicolon-delimited index, parse it
1169        * off and make sure we only retrieve the equivalence name for
1170        * that index.  */
1171       if ((cp2 = strchr(lnm,';')) != NULL) {
1172         my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1173         idx = strtoul(cp2+1,NULL,0);
1174         lnm = uplnm;
1175         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1176       }
1177
1178       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1179
1180       /* Discard NOLOGNAM on internal calls since we're often looking
1181        * for an optional name, and this "error" often shows up as the
1182        * (bogus) exit status for a die() call later on.  */
1183       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1184       return success ? eqv : NULL;
1185     }
1186
1187 }  /* end of my_getenv() */
1188 /*}}}*/
1189
1190
1191 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1192 char *
1193 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1194 {
1195     const char *cp1;
1196     char *buf, *cp2;
1197     unsigned long idx = 0;
1198     int midx, flags;
1199     static char *__my_getenv_len_eqv = NULL;
1200     int secure, saverr, savvmserr;
1201     SV *tmpsv;
1202
1203     midx = my_maxidx(lnm) + 1;
1204
1205     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1206       /* Set up a temporary buffer for the return value; Perl will
1207        * clean it up at the next statement transition */
1208       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1209       if (!tmpsv) return NULL;
1210       buf = SvPVX(tmpsv);
1211     }
1212     else {
1213       /* Assume no interpreter ==> single thread */
1214       if (__my_getenv_len_eqv != NULL) {
1215         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1216       }
1217       else {
1218         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1219       }
1220       buf = __my_getenv_len_eqv;
1221     }
1222
1223     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1224     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1225     char * zeros;
1226
1227       getcwd(buf,LNM$C_NAMLENGTH);
1228       *len = strlen(buf);
1229
1230       /* Get rid of "000000/ in rooted filespecs */
1231       if (*len > 7) {
1232       zeros = strstr(buf, "/000000/");
1233       if (zeros != NULL) {
1234         int mlen;
1235         mlen = *len - (zeros - buf) - 7;
1236         memmove(zeros, &zeros[7], mlen);
1237         *len = *len - 7;
1238         buf[*len] = '\0';
1239         }
1240       }
1241       return buf;
1242     }
1243     else {
1244       if (sys) {
1245         /* Impose security constraints only if tainting */
1246         secure = PL_curinterp ? PL_tainting : will_taint;
1247         saverr = errno;  savvmserr = vaxc$errno;
1248       }
1249       else {
1250         secure = 0;
1251       }
1252
1253       flags =
1254 #ifdef SECURE_INTERNAL_GETENV
1255               secure ? PERL__TRNENV_SECURE : 0
1256 #else
1257               0
1258 #endif
1259       ;
1260
1261       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1262
1263       if ((cp2 = strchr(lnm,';')) != NULL) {
1264         my_strlcpy(buf, lnm, cp2 - lnm + 1);
1265         idx = strtoul(cp2+1,NULL,0);
1266         lnm = buf;
1267         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1268       }
1269
1270       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1271
1272       /* Get rid of "000000/ in rooted filespecs */
1273       if (*len > 7) {
1274       char * zeros;
1275         zeros = strstr(buf, "/000000/");
1276         if (zeros != NULL) {
1277           int mlen;
1278           mlen = *len - (zeros - buf) - 7;
1279           memmove(zeros, &zeros[7], mlen);
1280           *len = *len - 7;
1281           buf[*len] = '\0';
1282         }
1283       }
1284
1285       /* Discard NOLOGNAM on internal calls since we're often looking
1286        * for an optional name, and this "error" often shows up as the
1287        * (bogus) exit status for a die() call later on.  */
1288       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1289       return *len ? buf : NULL;
1290     }
1291
1292 }  /* end of my_getenv_len() */
1293 /*}}}*/
1294
1295 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1296
1297 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1298
1299 /*{{{ void prime_env_iter() */
1300 void
1301 prime_env_iter(void)
1302 /* Fill the %ENV associative array with all logical names we can
1303  * find, in preparation for iterating over it.
1304  */
1305 {
1306   static int primed = 0;
1307   HV *seenhv = NULL, *envhv;
1308   SV *sv = NULL;
1309   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1310   unsigned short int chan;
1311 #ifndef CLI$M_TRUSTED
1312 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1313 #endif
1314   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1315   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1316   long int i;
1317   bool have_sym = FALSE, have_lnm = FALSE;
1318   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1319   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1320   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1321   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1322   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1323 #if defined(PERL_IMPLICIT_CONTEXT)
1324   pTHX;
1325 #endif
1326 #if defined(USE_ITHREADS)
1327   static perl_mutex primenv_mutex;
1328   MUTEX_INIT(&primenv_mutex);
1329 #endif
1330
1331 #if defined(PERL_IMPLICIT_CONTEXT)
1332     /* We jump through these hoops because we can be called at */
1333     /* platform-specific initialization time, which is before anything is */
1334     /* set up--we can't even do a plain dTHX since that relies on the */
1335     /* interpreter structure to be initialized */
1336     if (PL_curinterp) {
1337       aTHX = PERL_GET_INTERP;
1338     } else {
1339       /* we never get here because the NULL pointer will cause the */
1340       /* several of the routines called by this routine to access violate */
1341
1342       /* This routine is only called by hv.c/hv_iterinit which has a */
1343       /* context, so the real fix may be to pass it through instead of */
1344       /* the hoops above */
1345       aTHX = NULL;
1346     }
1347 #endif
1348
1349   if (primed || !PL_envgv) return;
1350   MUTEX_LOCK(&primenv_mutex);
1351   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1352   envhv = GvHVn(PL_envgv);
1353   /* Perform a dummy fetch as an lval to insure that the hash table is
1354    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1355   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1356
1357   for (i = 0; env_tables[i]; i++) {
1358      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1359          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1360      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1361   }
1362   if (have_sym || have_lnm) {
1363     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1364     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1365     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1366     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1367   }
1368
1369   for (i--; i >= 0; i--) {
1370     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1371       char *start;
1372       int j;
1373       for (j = 0; environ[j]; j++) {
1374         if (!(start = strchr(environ[j],'='))) {
1375           if (ckWARN(WARN_INTERNAL))
1376             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1377         }
1378         else {
1379           start++;
1380           sv = newSVpv(start,0);
1381           SvTAINTED_on(sv);
1382           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1383         }
1384       }
1385       continue;
1386     }
1387     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1388              !str$case_blind_compare(&tmpdsc,&clisym)) {
1389       my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1390       cmddsc.dsc$w_length = 20;
1391       if (env_tables[i]->dsc$w_length == 12 &&
1392           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1393           !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local  *", sizeof(cmd)-12);
1394       flags = defflags | CLI$M_NOLOGNAM;
1395     }
1396     else {
1397       my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1398       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1399         my_strlcat(cmd," /Table=", sizeof(cmd));
1400         cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, env_tables[i]->dsc$w_length + 1);
1401       }
1402       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1403       flags = defflags | CLI$M_NOCLISYM;
1404     }
1405
1406     /* Create a new subprocess to execute each command, to exclude the
1407      * remote possibility that someone could subvert a mbx or file used
1408      * to write multiple commands to a single subprocess.
1409      */
1410     do {
1411       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1412                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1413       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1414       defflags &= ~CLI$M_TRUSTED;
1415     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1416     _ckvmssts(retsts);
1417     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1418     if (seenhv) SvREFCNT_dec(seenhv);
1419     seenhv = newHV();
1420     while (1) {
1421       char *cp1, *cp2, *key;
1422       unsigned long int sts, iosb[2], retlen, keylen;
1423       register U32 hash;
1424
1425       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1426       if (sts & 1) sts = iosb[0] & 0xffff;
1427       if (sts == SS$_ENDOFFILE) {
1428         int wakect = 0;
1429         while (substs == 0) { sys$hiber(); wakect++;}
1430         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1431         _ckvmssts(substs);
1432         break;
1433       }
1434       _ckvmssts(sts);
1435       retlen = iosb[0] >> 16;
1436       if (!retlen) continue;  /* blank line */
1437       buf[retlen] = '\0';
1438       if (iosb[1] != subpid) {
1439         if (iosb[1]) {
1440           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1441         }
1442         continue;
1443       }
1444       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1445         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1446
1447       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1448       if (*cp1 == '(' || /* Logical name table name */
1449           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1450       if (*cp1 == '"') cp1++;
1451       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1452       key = cp1;  keylen = cp2 - cp1;
1453       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1454       while (*cp2 && *cp2 != '=') cp2++;
1455       while (*cp2 && *cp2 == '=') cp2++;
1456       while (*cp2 && *cp2 == ' ') cp2++;
1457       if (*cp2 == '"') {  /* String translation; may embed "" */
1458         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1459         cp2++;  cp1--; /* Skip "" surrounding translation */
1460       }
1461       else {  /* Numeric translation */
1462         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1463         cp1--;  /* stop on last non-space char */
1464       }
1465       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1466         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1467         continue;
1468       }
1469       PERL_HASH(hash,key,keylen);
1470
1471       if (cp1 == cp2 && *cp2 == '.') {
1472         /* A single dot usually means an unprintable character, such as a null
1473          * to indicate a zero-length value.  Get the actual value to make sure.
1474          */
1475         char lnm[LNM$C_NAMLENGTH+1];
1476         char eqv[MAX_DCL_SYMBOL+1];
1477         int trnlen;
1478         strncpy(lnm, key, keylen);
1479         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1480         sv = newSVpvn(eqv, strlen(eqv));
1481       }
1482       else {
1483         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1484       }
1485
1486       SvTAINTED_on(sv);
1487       hv_store(envhv,key,keylen,sv,hash);
1488       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1489     }
1490     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1491       /* get the PPFs for this process, not the subprocess */
1492       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1493       char eqv[LNM$C_NAMLENGTH+1];
1494       int trnlen, i;
1495       for (i = 0; ppfs[i]; i++) {
1496         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1497         sv = newSVpv(eqv,trnlen);
1498         SvTAINTED_on(sv);
1499         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1500       }
1501     }
1502   }
1503   primed = 1;
1504   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1505   if (buf) Safefree(buf);
1506   if (seenhv) SvREFCNT_dec(seenhv);
1507   MUTEX_UNLOCK(&primenv_mutex);
1508   return;
1509
1510 }  /* end of prime_env_iter */
1511 /*}}}*/
1512
1513
1514 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1515 /* Define or delete an element in the same "environment" as
1516  * vmstrnenv().  If an element is to be deleted, it's removed from
1517  * the first place it's found.  If it's to be set, it's set in the
1518  * place designated by the first element of the table vector.
1519  * Like setenv() returns 0 for success, non-zero on error.
1520  */
1521 int
1522 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1523 {
1524     const char *cp1;
1525     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1526     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1527     int nseg = 0, j;
1528     unsigned long int retsts, usermode = PSL$C_USER;
1529     struct itmlst_3 *ile, *ilist;
1530     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1531                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1532                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1533     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1534     $DESCRIPTOR(local,"_LOCAL");
1535
1536     if (!lnm) {
1537         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1538         return SS$_IVLOGNAM;
1539     }
1540
1541     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1542       *cp2 = _toupper(*cp1);
1543       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1544         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1545         return SS$_IVLOGNAM;
1546       }
1547     }
1548     lnmdsc.dsc$w_length = cp1 - lnm;
1549     if (!tabvec || !*tabvec) tabvec = env_tables;
1550
1551     if (!eqv) {  /* we're deleting n element */
1552       for (curtab = 0; tabvec[curtab]; curtab++) {
1553         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1554         int i;
1555           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1556             if ((cp1 = strchr(environ[i],'=')) &&
1557                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1558                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1559 #ifdef HAS_SETENV
1560               return setenv(lnm,"",1) ? vaxc$errno : 0;
1561             }
1562           }
1563           ivenv = 1; retsts = SS$_NOLOGNAM;
1564 #else
1565               if (ckWARN(WARN_INTERNAL))
1566                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1567               ivenv = 1; retsts = SS$_NOSUCHPGM;
1568               break;
1569             }
1570           }
1571 #endif
1572         }
1573         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1574                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1575           unsigned int symtype;
1576           if (tabvec[curtab]->dsc$w_length == 12 &&
1577               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1578               !str$case_blind_compare(&tmpdsc,&local))
1579             symtype = LIB$K_CLI_LOCAL_SYM;
1580           else symtype = LIB$K_CLI_GLOBAL_SYM;
1581           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1582           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1583           if (retsts == LIB$_NOSUCHSYM) continue;
1584           break;
1585         }
1586         else if (!ivlnm) {
1587           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1588           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1589           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1590           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1591           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1592         }
1593       }
1594     }
1595     else {  /* we're defining a value */
1596       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1597 #ifdef HAS_SETENV
1598         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1599 #else
1600         if (ckWARN(WARN_INTERNAL))
1601           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1602         retsts = SS$_NOSUCHPGM;
1603 #endif
1604       }
1605       else {
1606         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1607         eqvdsc.dsc$w_length  = strlen(eqv);
1608         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1609             !str$case_blind_compare(&tmpdsc,&clisym)) {
1610           unsigned int symtype;
1611           if (tabvec[0]->dsc$w_length == 12 &&
1612               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1613                !str$case_blind_compare(&tmpdsc,&local))
1614             symtype = LIB$K_CLI_LOCAL_SYM;
1615           else symtype = LIB$K_CLI_GLOBAL_SYM;
1616           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1617         }
1618         else {
1619           if (!*eqv) eqvdsc.dsc$w_length = 1;
1620           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1621
1622             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1623             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1624               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1625                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1626               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1627               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1628             }
1629
1630             Newx(ilist,nseg+1,struct itmlst_3);
1631             ile = ilist;
1632             if (!ile) {
1633               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1634               return SS$_INSFMEM;
1635             }
1636             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1637
1638             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1639               ile->itmcode = LNM$_STRING;
1640               ile->bufadr = c;
1641               if ((j+1) == nseg) {
1642                 ile->buflen = strlen(c);
1643                 /* in case we are truncating one that's too long */
1644                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1645               }
1646               else {
1647                 ile->buflen = LNM$C_NAMLENGTH;
1648               }
1649             }
1650
1651             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1652             Safefree (ilist);
1653           }
1654           else {
1655             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1656           }
1657         }
1658       }
1659     }
1660     if (!(retsts & 1)) {
1661       switch (retsts) {
1662         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1663         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1664           set_errno(EVMSERR); break;
1665         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1666         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1667           set_errno(EINVAL); break;
1668         case SS$_NOPRIV:
1669           set_errno(EACCES); break;
1670         default:
1671           _ckvmssts(retsts);
1672           set_errno(EVMSERR);
1673        }
1674        set_vaxc_errno(retsts);
1675        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1676     }
1677     else {
1678       /* We reset error values on success because Perl does an hv_fetch()
1679        * before each hv_store(), and if the thing we're setting didn't
1680        * previously exist, we've got a leftover error message.  (Of course,
1681        * this fails in the face of
1682        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1683        * in that the error reported in $! isn't spurious,
1684        * but it's right more often than not.)
1685        */
1686       set_errno(0); set_vaxc_errno(retsts);
1687       return 0;
1688     }
1689
1690 }  /* end of vmssetenv() */
1691 /*}}}*/
1692
1693 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1694 /* This has to be a function since there's a prototype for it in proto.h */
1695 void
1696 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1697 {
1698     if (lnm && *lnm) {
1699       int len = strlen(lnm);
1700       if  (len == 7) {
1701         char uplnm[8];
1702         int i;
1703         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1704         if (!strcmp(uplnm,"DEFAULT")) {
1705           if (eqv && *eqv) my_chdir(eqv);
1706           return;
1707         }
1708     }
1709   }
1710   (void) vmssetenv(lnm,eqv,NULL);
1711 }
1712 /*}}}*/
1713
1714 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1715 /*  vmssetuserlnm
1716  *  sets a user-mode logical in the process logical name table
1717  *  used for redirection of sys$error
1718  *
1719  *  Fix-me: The pTHX is not needed for this routine, however doio.c
1720  *          is calling it with one instead of using a macro.
1721  *          A macro needs to be added to vmsish.h and doio.c updated to use it.
1722  *
1723  */
1724 void
1725 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1726 {
1727     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1728     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1729     unsigned long int iss, attr = LNM$M_CONFINE;
1730     unsigned char acmode = PSL$C_USER;
1731     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1732                                  {0, 0, 0, 0}};
1733     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1734     d_name.dsc$w_length = strlen(name);
1735
1736     lnmlst[0].buflen = strlen(eqv);
1737     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1738
1739     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1740     if (!(iss&1)) lib$signal(iss);
1741 }
1742 /*}}}*/
1743
1744
1745 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1746 /* my_crypt - VMS password hashing
1747  * my_crypt() provides an interface compatible with the Unix crypt()
1748  * C library function, and uses sys$hash_password() to perform VMS
1749  * password hashing.  The quadword hashed password value is returned
1750  * as a NUL-terminated 8 character string.  my_crypt() does not change
1751  * the case of its string arguments; in order to match the behavior
1752  * of LOGINOUT et al., alphabetic characters in both arguments must
1753  *  be upcased by the caller.
1754  *
1755  * - fix me to call ACM services when available
1756  */
1757 char *
1758 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1759 {
1760 #   ifndef UAI$C_PREFERRED_ALGORITHM
1761 #     define UAI$C_PREFERRED_ALGORITHM 127
1762 #   endif
1763     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1764     unsigned short int salt = 0;
1765     unsigned long int sts;
1766     struct const_dsc {
1767         unsigned short int dsc$w_length;
1768         unsigned char      dsc$b_type;
1769         unsigned char      dsc$b_class;
1770         const char *       dsc$a_pointer;
1771     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1772        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1773     struct itmlst_3 uailst[3] = {
1774         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1775         { sizeof salt, UAI$_SALT,    &salt, 0},
1776         { 0,           0,            NULL,  NULL}};
1777     static char hash[9];
1778
1779     usrdsc.dsc$w_length = strlen(usrname);
1780     usrdsc.dsc$a_pointer = usrname;
1781     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1782       switch (sts) {
1783         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1784           set_errno(EACCES);
1785           break;
1786         case RMS$_RNF:
1787           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1788           break;
1789         default:
1790           set_errno(EVMSERR);
1791       }
1792       set_vaxc_errno(sts);
1793       if (sts != RMS$_RNF) return NULL;
1794     }
1795
1796     txtdsc.dsc$w_length = strlen(textpasswd);
1797     txtdsc.dsc$a_pointer = textpasswd;
1798     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1799       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1800     }
1801
1802     return (char *) hash;
1803
1804 }  /* end of my_crypt() */
1805 /*}}}*/
1806
1807
1808 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1809 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1810 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1811
1812 /* fixup barenames that are directories for internal use.
1813  * There have been problems with the consistent handling of UNIX
1814  * style directory names when routines are presented with a name that
1815  * has no directory delimiters at all.  So this routine will eventually
1816  * fix the issue.
1817  */
1818 static char * fixup_bare_dirnames(const char * name)
1819 {
1820   if (decc_disable_to_vms_logname_translation) {
1821 /* fix me */
1822   }
1823   return NULL;
1824 }
1825
1826 /* 8.3, remove() is now broken on symbolic links */
1827 static int rms_erase(const char * vmsname);
1828
1829
1830 /* mp_do_kill_file
1831  * A little hack to get around a bug in some implementation of remove()
1832  * that do not know how to delete a directory
1833  *
1834  * Delete any file to which user has control access, regardless of whether
1835  * delete access is explicitly allowed.
1836  * Limitations: User must have write access to parent directory.
1837  *              Does not block signals or ASTs; if interrupted in midstream
1838  *              may leave file with an altered ACL.
1839  * HANDLE WITH CARE!
1840  */
1841 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1842 static int
1843 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1844 {
1845     char *vmsname;
1846     char *rslt;
1847     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1848     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1849     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1850     struct myacedef {
1851       unsigned char myace$b_length;
1852       unsigned char myace$b_type;
1853       unsigned short int myace$w_flags;
1854       unsigned long int myace$l_access;
1855       unsigned long int myace$l_ident;
1856     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1857                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1858       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1859      struct itmlst_3
1860        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1861                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1862        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1863        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1864        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1865        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1866
1867     /* Expand the input spec using RMS, since the CRTL remove() and
1868      * system services won't do this by themselves, so we may miss
1869      * a file "hiding" behind a logical name or search list. */
1870     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1871     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1872
1873     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1874     if (rslt == NULL) {
1875         PerlMem_free(vmsname);
1876         return -1;
1877       }
1878
1879     /* Erase the file */
1880     rmsts = rms_erase(vmsname);
1881
1882     /* Did it succeed */
1883     if ($VMS_STATUS_SUCCESS(rmsts)) {
1884         PerlMem_free(vmsname);
1885         return 0;
1886       }
1887
1888     /* If not, can changing protections help? */
1889     if (rmsts != RMS$_PRV) {
1890       set_vaxc_errno(rmsts);
1891       PerlMem_free(vmsname);
1892       return -1;
1893     }
1894
1895     /* No, so we get our own UIC to use as a rights identifier,
1896      * and the insert an ACE at the head of the ACL which allows us
1897      * to delete the file.
1898      */
1899     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1900     fildsc.dsc$w_length = strlen(vmsname);
1901     fildsc.dsc$a_pointer = vmsname;
1902     cxt = 0;
1903     newace.myace$l_ident = oldace.myace$l_ident;
1904     rmsts = -1;
1905     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1906       switch (aclsts) {
1907         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1908           set_errno(ENOENT); break;
1909         case RMS$_DIR:
1910           set_errno(ENOTDIR); break;
1911         case RMS$_DEV:
1912           set_errno(ENODEV); break;
1913         case RMS$_SYN: case SS$_INVFILFOROP:
1914           set_errno(EINVAL); break;
1915         case RMS$_PRV:
1916           set_errno(EACCES); break;
1917         default:
1918           _ckvmssts_noperl(aclsts);
1919       }
1920       set_vaxc_errno(aclsts);
1921       PerlMem_free(vmsname);
1922       return -1;
1923     }
1924     /* Grab any existing ACEs with this identifier in case we fail */
1925     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1926     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1927                     || fndsts == SS$_NOMOREACE ) {
1928       /* Add the new ACE . . . */
1929       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1930         goto yourroom;
1931
1932       rmsts = rms_erase(vmsname);
1933       if ($VMS_STATUS_SUCCESS(rmsts)) {
1934         rmsts = 0;
1935         }
1936         else {
1937         rmsts = -1;
1938         /* We blew it - dir with files in it, no write priv for
1939          * parent directory, etc.  Put things back the way they were. */
1940         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1941           goto yourroom;
1942         if (fndsts & 1) {
1943           addlst[0].bufadr = &oldace;
1944           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1945             goto yourroom;
1946         }
1947       }
1948     }
1949
1950     yourroom:
1951     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1952     /* We just deleted it, so of course it's not there.  Some versions of
1953      * VMS seem to return success on the unlock operation anyhow (after all
1954      * the unlock is successful), but others don't.
1955      */
1956     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1957     if (aclsts & 1) aclsts = fndsts;
1958     if (!(aclsts & 1)) {
1959       set_errno(EVMSERR);
1960       set_vaxc_errno(aclsts);
1961     }
1962
1963     PerlMem_free(vmsname);
1964     return rmsts;
1965
1966 }  /* end of kill_file() */
1967 /*}}}*/
1968
1969
1970 /*{{{int do_rmdir(char *name)*/
1971 int
1972 Perl_do_rmdir(pTHX_ const char *name)
1973 {
1974     char * dirfile;
1975     int retval;
1976     Stat_t st;
1977
1978     /* lstat returns a VMS fileified specification of the name */
1979     /* that is looked up, and also lets verifies that this is a directory */
1980
1981     retval = flex_lstat(name, &st);
1982     if (retval != 0) {
1983         char * ret_spec;
1984
1985         /* Due to a historical feature, flex_stat/lstat can not see some */
1986         /* Unix format file names that the rest of the CRTL can see */
1987         /* Fixing that feature will cause some perl tests to fail */
1988         /* So try this one more time. */
1989
1990         retval = lstat(name, &st.crtl_stat);
1991         if (retval != 0)
1992             return -1;
1993
1994         /* force it to a file spec for the kill file to work. */
1995         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1996         if (ret_spec == NULL) {
1997             errno = EIO;
1998             return -1;
1999         }
2000     }
2001
2002     if (!S_ISDIR(st.st_mode)) {
2003         errno = ENOTDIR;
2004         retval = -1;
2005     }
2006     else {
2007         dirfile = st.st_devnam;
2008
2009         /* It may be possible for flex_stat to find a file and vmsify() to */
2010         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
2011         /* with that case, so fail it */
2012         if (dirfile[0] == 0) {
2013             errno = EIO;
2014             return -1;
2015         }
2016
2017         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2018     }
2019
2020     return retval;
2021
2022 }  /* end of do_rmdir */
2023 /*}}}*/
2024
2025 /* kill_file
2026  * Delete any file to which user has control access, regardless of whether
2027  * delete access is explicitly allowed.
2028  * Limitations: User must have write access to parent directory.
2029  *              Does not block signals or ASTs; if interrupted in midstream
2030  *              may leave file with an altered ACL.
2031  * HANDLE WITH CARE!
2032  */
2033 /*{{{int kill_file(char *name)*/
2034 int
2035 Perl_kill_file(pTHX_ const char *name)
2036 {
2037     char * vmsfile;
2038     Stat_t st;
2039     int rmsts;
2040
2041     /* Convert the filename to VMS format and see if it is a directory */
2042     /* flex_lstat returns a vmsified file specification */
2043     rmsts = flex_lstat(name, &st);
2044     if (rmsts != 0) {
2045
2046         /* Due to a historical feature, flex_stat/lstat can not see some */
2047         /* Unix format file names that the rest of the CRTL can see when */
2048         /* ODS-2 file specifications are in use. */
2049         /* Fixing that feature will cause some perl tests to fail */
2050         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2051         st.st_mode = 0;
2052         vmsfile = (char *) name; /* cast ok */
2053
2054     } else {
2055         vmsfile = st.st_devnam;
2056         if (vmsfile[0] == 0) {
2057             /* It may be possible for flex_stat to find a file and vmsify() */
2058             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2059             /* deal with that case, so fail it */
2060             errno = EIO;
2061             return -1;
2062         }
2063     }
2064
2065     /* Remove() is allowed to delete directories, according to the X/Open
2066      * specifications.
2067      * This may need special handling to work with the ACL hacks.
2068      */
2069     if (S_ISDIR(st.st_mode)) {
2070         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2071         return rmsts;
2072     }
2073
2074     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2075
2076     /* Need to delete all versions ? */
2077     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2078         int i = 0;
2079
2080         /* Just use lstat() here as do not need st_dev */
2081         /* and we know that the file is in VMS format or that */
2082         /* because of a historical bug, flex_stat can not see the file */
2083         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2084             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2085             if (rmsts != 0)
2086                 break;
2087             i++;
2088
2089             /* Make sure that we do not loop forever */
2090             if (i > 32767) {
2091                 errno = EIO;
2092                 rmsts = -1;
2093                 break;
2094             }
2095         }
2096     }
2097
2098     return rmsts;
2099
2100 }  /* end of kill_file() */
2101 /*}}}*/
2102
2103
2104 /*{{{int my_mkdir(char *,Mode_t)*/
2105 int
2106 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2107 {
2108   STRLEN dirlen = strlen(dir);
2109
2110   /* zero length string sometimes gives ACCVIO */
2111   if (dirlen == 0) return -1;
2112
2113   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2114    * null file name/type.  However, it's commonplace under Unix,
2115    * so we'll allow it for a gain in portability.
2116    */
2117   if (dir[dirlen-1] == '/') {
2118     char *newdir = savepvn(dir,dirlen-1);
2119     int ret = mkdir(newdir,mode);
2120     Safefree(newdir);
2121     return ret;
2122   }
2123   else return mkdir(dir,mode);
2124 }  /* end of my_mkdir */
2125 /*}}}*/
2126
2127 /*{{{int my_chdir(char *)*/
2128 int
2129 Perl_my_chdir(pTHX_ const char *dir)
2130 {
2131   STRLEN dirlen = strlen(dir);
2132
2133   /* zero length string sometimes gives ACCVIO */
2134   if (dirlen == 0) return -1;
2135   const char *dir1;
2136
2137   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2138    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2139    * so that existing scripts do not need to be changed.
2140    */
2141   dir1 = dir;
2142   while ((dirlen > 0) && (*dir1 == ' ')) {
2143     dir1++;
2144     dirlen--;
2145   }
2146
2147   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2148    * that implies
2149    * null file name/type.  However, it's commonplace under Unix,
2150    * so we'll allow it for a gain in portability.
2151    *
2152    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2153    */
2154   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2155       char *newdir;
2156       int ret;
2157       newdir = PerlMem_malloc(dirlen);
2158       if (newdir ==NULL)
2159           _ckvmssts_noperl(SS$_INSFMEM);
2160       memcpy(newdir, dir1, dirlen-1);
2161       newdir[dirlen-1] = '\0';
2162       ret = chdir(newdir);
2163       PerlMem_free(newdir);
2164       return ret;
2165   }
2166   else return chdir(dir1);
2167 }  /* end of my_chdir */
2168 /*}}}*/
2169
2170
2171 /*{{{int my_chmod(char *, mode_t)*/
2172 int
2173 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2174 {
2175   Stat_t st;
2176   int ret = -1;
2177   char * changefile;
2178   STRLEN speclen = strlen(file_spec);
2179
2180   /* zero length string sometimes gives ACCVIO */
2181   if (speclen == 0) return -1;
2182
2183   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2184    * that implies null file name/type.  However, it's commonplace under Unix,
2185    * so we'll allow it for a gain in portability.
2186    *
2187    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2188    * in VMS file.dir notation.
2189    */
2190   changefile = (char *) file_spec; /* cast ok */
2191   ret = flex_lstat(file_spec, &st);
2192   if (ret != 0) {
2193
2194         /* Due to a historical feature, flex_stat/lstat can not see some */
2195         /* Unix format file names that the rest of the CRTL can see when */
2196         /* ODS-2 file specifications are in use. */
2197         /* Fixing that feature will cause some perl tests to fail */
2198         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2199         st.st_mode = 0;
2200
2201   } else {
2202       /* It may be possible to get here with nothing in st_devname */
2203       /* chmod still may work though */
2204       if (st.st_devnam[0] != 0) {
2205           changefile = st.st_devnam;
2206       }
2207   }
2208   ret = chmod(changefile, mode);
2209   return ret;
2210 }  /* end of my_chmod */
2211 /*}}}*/
2212
2213
2214 /*{{{FILE *my_tmpfile()*/
2215 FILE *
2216 my_tmpfile(void)
2217 {
2218   FILE *fp;
2219   char *cp;
2220
2221   if ((fp = tmpfile())) return fp;
2222
2223   cp = PerlMem_malloc(L_tmpnam+24);
2224   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2225
2226   if (decc_filename_unix_only == 0)
2227     strcpy(cp,"Sys$Scratch:");
2228   else
2229     strcpy(cp,"/tmp/");
2230   tmpnam(cp+strlen(cp));
2231   strcat(cp,".Perltmp");
2232   fp = fopen(cp,"w+","fop=dlt");
2233   PerlMem_free(cp);
2234   return fp;
2235 }
2236 /*}}}*/
2237
2238
2239 /*
2240  * The C RTL's sigaction fails to check for invalid signal numbers so we
2241  * help it out a bit.  The docs are correct, but the actual routine doesn't
2242  * do what the docs say it will.
2243  */
2244 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2245 int
2246 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2247                    struct sigaction* oact)
2248 {
2249   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2250         SETERRNO(EINVAL, SS$_INVARG);
2251         return -1;
2252   }
2253   return sigaction(sig, act, oact);
2254 }
2255 /*}}}*/
2256
2257 #ifdef KILL_BY_SIGPRC
2258 #include <errnodef.h>
2259
2260 /* We implement our own kill() using the undocumented system service
2261    sys$sigprc for one of two reasons:
2262
2263    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2264    target process to do a sys$exit, which usually can't be handled
2265    gracefully...certainly not by Perl and the %SIG{} mechanism.
2266
2267    2.) If the kill() in the CRTL can't be called from a signal
2268    handler without disappearing into the ether, i.e., the signal
2269    it purportedly sends is never trapped. Still true as of VMS 7.3.
2270
2271    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2272    in the target process rather than calling sys$exit.
2273
2274    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2275    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2276    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2277    with condition codes C$_SIG0+nsig*8, catching the exception on the
2278    target process and resignaling with appropriate arguments.
2279
2280    But we don't have that VMS 7.0+ exception handler, so if you
2281    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2282
2283    Also note that SIGTERM is listed in the docs as being "unimplemented",
2284    yet always seems to be signaled with a VMS condition code of 4 (and
2285    correctly handled for that code).  So we hardwire it in.
2286
2287    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2288    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2289    than signalling with an unrecognized (and unhandled by CRTL) code.
2290 */
2291
2292 #define _MY_SIG_MAX 28
2293
2294 static unsigned int
2295 Perl_sig_to_vmscondition_int(int sig)
2296 {
2297     static unsigned int sig_code[_MY_SIG_MAX+1] =
2298     {
2299         0,                  /*  0 ZERO     */
2300         SS$_HANGUP,         /*  1 SIGHUP   */
2301         SS$_CONTROLC,       /*  2 SIGINT   */
2302         SS$_CONTROLY,       /*  3 SIGQUIT  */
2303         SS$_RADRMOD,        /*  4 SIGILL   */
2304         SS$_BREAK,          /*  5 SIGTRAP  */
2305         SS$_OPCCUS,         /*  6 SIGABRT  */
2306         SS$_COMPAT,         /*  7 SIGEMT   */
2307 #ifdef __VAX
2308         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2309 #else
2310         SS$_HPARITH,        /*  8 SIGFPE AXP */
2311 #endif
2312         SS$_ABORT,          /*  9 SIGKILL  */
2313         SS$_ACCVIO,         /* 10 SIGBUS   */
2314         SS$_ACCVIO,         /* 11 SIGSEGV  */
2315         SS$_BADPARAM,       /* 12 SIGSYS   */
2316         SS$_NOMBX,          /* 13 SIGPIPE  */
2317         SS$_ASTFLT,         /* 14 SIGALRM  */
2318         4,                  /* 15 SIGTERM  */
2319         0,                  /* 16 SIGUSR1  */
2320         0,                  /* 17 SIGUSR2  */
2321         0,                  /* 18 */
2322         0,                  /* 19 */
2323         0,                  /* 20 SIGCHLD  */
2324         0,                  /* 21 SIGCONT  */
2325         0,                  /* 22 SIGSTOP  */
2326         0,                  /* 23 SIGTSTP  */
2327         0,                  /* 24 SIGTTIN  */
2328         0,                  /* 25 SIGTTOU  */
2329         0,                  /* 26 */
2330         0,                  /* 27 */
2331         0                   /* 28 SIGWINCH  */
2332     };
2333
2334     static int initted = 0;
2335     if (!initted) {
2336         initted = 1;
2337         sig_code[16] = C$_SIGUSR1;
2338         sig_code[17] = C$_SIGUSR2;
2339         sig_code[20] = C$_SIGCHLD;
2340 #if __CRTL_VER >= 70300000
2341         sig_code[28] = C$_SIGWINCH;
2342 #endif
2343     }
2344
2345     if (sig < _SIG_MIN) return 0;
2346     if (sig > _MY_SIG_MAX) return 0;
2347     return sig_code[sig];
2348 }
2349
2350 unsigned int
2351 Perl_sig_to_vmscondition(int sig)
2352 {
2353 #ifdef SS$_DEBUG
2354     if (vms_debug_on_exception != 0)
2355         lib$signal(SS$_DEBUG);
2356 #endif
2357     return Perl_sig_to_vmscondition_int(sig);
2358 }
2359
2360
2361 int
2362 Perl_my_kill(int pid, int sig)
2363 {
2364     int iss;
2365     unsigned int code;
2366 #define sys$sigprc SYS$SIGPRC
2367     int sys$sigprc(unsigned int *pidadr,
2368                      struct dsc$descriptor_s *prcname,
2369                      unsigned int code);
2370
2371      /* sig 0 means validate the PID */
2372     /*------------------------------*/
2373     if (sig == 0) {
2374         const unsigned long int jpicode = JPI$_PID;
2375         pid_t ret_pid;
2376         int status;
2377         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2378         if ($VMS_STATUS_SUCCESS(status))
2379            return 0;
2380         switch (status) {
2381         case SS$_NOSUCHNODE:
2382         case SS$_UNREACHABLE:
2383         case SS$_NONEXPR:
2384            errno = ESRCH;
2385            break;
2386         case SS$_NOPRIV:
2387            errno = EPERM;
2388            break;
2389         default:
2390            errno = EVMSERR;
2391         }
2392         vaxc$errno=status;
2393         return -1;
2394     }
2395
2396     code = Perl_sig_to_vmscondition_int(sig);
2397
2398     if (!code) {
2399         SETERRNO(EINVAL, SS$_BADPARAM);
2400         return -1;
2401     }
2402
2403     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2404      * signals are to be sent to multiple processes.
2405      *  pid = 0 - all processes in group except ones that the system exempts
2406      *  pid = -1 - all processes except ones that the system exempts
2407      *  pid = -n - all processes in group (abs(n)) except ...
2408      * For now, just report as not supported.
2409      */
2410
2411     if (pid <= 0) {
2412         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2413         return -1;
2414     }
2415
2416     iss = sys$sigprc((unsigned int *)&pid,0,code);
2417     if (iss&1) return 0;
2418
2419     switch (iss) {
2420       case SS$_NOPRIV:
2421         set_errno(EPERM);  break;
2422       case SS$_NONEXPR:
2423       case SS$_NOSUCHNODE:
2424       case SS$_UNREACHABLE:
2425         set_errno(ESRCH);  break;
2426       case SS$_INSFMEM:
2427         set_errno(ENOMEM); break;
2428       default:
2429         _ckvmssts_noperl(iss);
2430         set_errno(EVMSERR);
2431     }
2432     set_vaxc_errno(iss);
2433
2434     return -1;
2435 }
2436 #endif
2437
2438 /* Routine to convert a VMS status code to a UNIX status code.
2439 ** More tricky than it appears because of conflicting conventions with
2440 ** existing code.
2441 **
2442 ** VMS status codes are a bit mask, with the least significant bit set for
2443 ** success.
2444 **
2445 ** Special UNIX status of EVMSERR indicates that no translation is currently
2446 ** available, and programs should check the VMS status code.
2447 **
2448 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2449 ** decoding.
2450 */
2451
2452 #ifndef C_FACILITY_NO
2453 #define C_FACILITY_NO 0x350000
2454 #endif
2455 #ifndef DCL_IVVERB
2456 #define DCL_IVVERB 0x38090
2457 #endif
2458
2459 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2460 {
2461 int facility;
2462 int fac_sp;
2463 int msg_no;
2464 int msg_status;
2465 int unix_status;
2466
2467   /* Assume the best or the worst */
2468   if (vms_status & STS$M_SUCCESS)
2469     unix_status = 0;
2470   else
2471     unix_status = EVMSERR;
2472
2473   msg_status = vms_status & ~STS$M_CONTROL;
2474
2475   facility = vms_status & STS$M_FAC_NO;
2476   fac_sp = vms_status & STS$M_FAC_SP;
2477   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2478
2479   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2480     switch(msg_no) {
2481     case SS$_NORMAL:
2482         unix_status = 0;
2483         break;
2484     case SS$_ACCVIO:
2485         unix_status = EFAULT;
2486         break;
2487     case SS$_DEVOFFLINE:
2488         unix_status = EBUSY;
2489         break;
2490     case SS$_CLEARED:
2491         unix_status = ENOTCONN;
2492         break;
2493     case SS$_IVCHAN:
2494     case SS$_IVLOGNAM:
2495     case SS$_BADPARAM:
2496     case SS$_IVLOGTAB:
2497     case SS$_NOLOGNAM:
2498     case SS$_NOLOGTAB:
2499     case SS$_INVFILFOROP:
2500     case SS$_INVARG:
2501     case SS$_NOSUCHID:
2502     case SS$_IVIDENT:
2503         unix_status = EINVAL;
2504         break;
2505     case SS$_UNSUPPORTED:
2506         unix_status = ENOTSUP;
2507         break;
2508     case SS$_FILACCERR:
2509     case SS$_NOGRPPRV:
2510     case SS$_NOSYSPRV:
2511         unix_status = EACCES;
2512         break;
2513     case SS$_DEVICEFULL:
2514         unix_status = ENOSPC;
2515         break;
2516     case SS$_NOSUCHDEV:
2517         unix_status = ENODEV;
2518         break;
2519     case SS$_NOSUCHFILE:
2520     case SS$_NOSUCHOBJECT:
2521         unix_status = ENOENT;
2522         break;
2523     case SS$_ABORT:                                 /* Fatal case */
2524     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2525     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2526         unix_status = EINTR;
2527         break;
2528     case SS$_BUFFEROVF:
2529         unix_status = E2BIG;
2530         break;
2531     case SS$_INSFMEM:
2532         unix_status = ENOMEM;
2533         break;
2534     case SS$_NOPRIV:
2535         unix_status = EPERM;
2536         break;
2537     case SS$_NOSUCHNODE:
2538     case SS$_UNREACHABLE:
2539         unix_status = ESRCH;
2540         break;
2541     case SS$_NONEXPR:
2542         unix_status = ECHILD;
2543         break;
2544     default:
2545         if ((facility == 0) && (msg_no < 8)) {
2546           /* These are not real VMS status codes so assume that they are
2547           ** already UNIX status codes
2548           */
2549           unix_status = msg_no;
2550           break;
2551         }
2552     }
2553   }
2554   else {
2555     /* Translate a POSIX exit code to a UNIX exit code */
2556     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2557         unix_status = (msg_no & 0x07F8) >> 3;
2558     }
2559     else {
2560
2561          /* Documented traditional behavior for handling VMS child exits */
2562         /*--------------------------------------------------------------*/
2563         if (child_flag != 0) {
2564
2565              /* Success / Informational return 0 */
2566             /*----------------------------------*/
2567             if (msg_no & STS$K_SUCCESS)
2568                 return 0;
2569
2570              /* Warning returns 1 */
2571             /*-------------------*/
2572             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2573                 return 1;
2574
2575              /* Everything else pass through the severity bits */
2576             /*------------------------------------------------*/
2577             return (msg_no & STS$M_SEVERITY);
2578         }
2579
2580          /* Normal VMS status to ERRNO mapping attempt */
2581         /*--------------------------------------------*/
2582         switch(msg_status) {
2583         /* case RMS$_EOF: */ /* End of File */
2584         case RMS$_FNF:  /* File Not Found */
2585         case RMS$_DNF:  /* Dir Not Found */
2586                 unix_status = ENOENT;
2587                 break;
2588         case RMS$_RNF:  /* Record Not Found */
2589                 unix_status = ESRCH;
2590                 break;
2591         case RMS$_DIR:
2592                 unix_status = ENOTDIR;
2593                 break;
2594         case RMS$_DEV:
2595                 unix_status = ENODEV;
2596                 break;
2597         case RMS$_IFI:
2598         case RMS$_FAC:
2599         case RMS$_ISI:
2600                 unix_status = EBADF;
2601                 break;
2602         case RMS$_FEX:
2603                 unix_status = EEXIST;
2604                 break;
2605         case RMS$_SYN:
2606         case RMS$_FNM:
2607         case LIB$_INVSTRDES:
2608         case LIB$_INVARG:
2609         case LIB$_NOSUCHSYM:
2610         case LIB$_INVSYMNAM:
2611         case DCL_IVVERB:
2612                 unix_status = EINVAL;
2613                 break;
2614         case CLI$_BUFOVF:
2615         case RMS$_RTB:
2616         case CLI$_TKNOVF:
2617         case CLI$_RSLOVF:
2618                 unix_status = E2BIG;
2619                 break;
2620         case RMS$_PRV:  /* No privilege */
2621         case RMS$_ACC:  /* ACP file access failed */
2622         case RMS$_WLK:  /* Device write locked */
2623                 unix_status = EACCES;
2624                 break;
2625         case RMS$_MKD:  /* Failed to mark for delete */
2626                 unix_status = EPERM;
2627                 break;
2628         /* case RMS$_NMF: */  /* No more files */
2629         }
2630     }
2631   }
2632
2633   return unix_status;
2634 }
2635
2636 /* Try to guess at what VMS error status should go with a UNIX errno
2637  * value.  This is hard to do as there could be many possible VMS
2638  * error statuses that caused the errno value to be set.
2639  */
2640
2641 int Perl_unix_status_to_vms(int unix_status)
2642 {
2643 int test_unix_status;
2644
2645      /* Trivial cases first */
2646     /*---------------------*/
2647     if (unix_status == EVMSERR)
2648         return vaxc$errno;
2649
2650      /* Is vaxc$errno sane? */
2651     /*---------------------*/
2652     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2653     if (test_unix_status == unix_status)
2654         return vaxc$errno;
2655
2656      /* If way out of range, must be VMS code already */
2657     /*-----------------------------------------------*/
2658     if (unix_status > EVMSERR)
2659         return unix_status;
2660
2661      /* If out of range, punt */
2662     /*-----------------------*/
2663     if (unix_status > __ERRNO_MAX)
2664         return SS$_ABORT;
2665
2666
2667      /* Ok, now we have to do it the hard way. */
2668     /*----------------------------------------*/
2669     switch(unix_status) {
2670     case 0:     return SS$_NORMAL;
2671     case EPERM: return SS$_NOPRIV;
2672     case ENOENT: return SS$_NOSUCHOBJECT;
2673     case ESRCH: return SS$_UNREACHABLE;
2674     case EINTR: return SS$_ABORT;
2675     /* case EIO: */
2676     /* case ENXIO:  */
2677     case E2BIG: return SS$_BUFFEROVF;
2678     /* case ENOEXEC */
2679     case EBADF: return RMS$_IFI;
2680     case ECHILD: return SS$_NONEXPR;
2681     /* case EAGAIN */
2682     case ENOMEM: return SS$_INSFMEM;
2683     case EACCES: return SS$_FILACCERR;
2684     case EFAULT: return SS$_ACCVIO;
2685     /* case ENOTBLK */
2686     case EBUSY: return SS$_DEVOFFLINE;
2687     case EEXIST: return RMS$_FEX;
2688     /* case EXDEV */
2689     case ENODEV: return SS$_NOSUCHDEV;
2690     case ENOTDIR: return RMS$_DIR;
2691     /* case EISDIR */
2692     case EINVAL: return SS$_INVARG;
2693     /* case ENFILE */
2694     /* case EMFILE */
2695     /* case ENOTTY */
2696     /* case ETXTBSY */
2697     /* case EFBIG */
2698     case ENOSPC: return SS$_DEVICEFULL;
2699     case ESPIPE: return LIB$_INVARG;
2700     /* case EROFS: */
2701     /* case EMLINK: */
2702     /* case EPIPE: */
2703     /* case EDOM */
2704     case ERANGE: return LIB$_INVARG;
2705     /* case EWOULDBLOCK */
2706     /* case EINPROGRESS */
2707     /* case EALREADY */
2708     /* case ENOTSOCK */
2709     /* case EDESTADDRREQ */
2710     /* case EMSGSIZE */
2711     /* case EPROTOTYPE */
2712     /* case ENOPROTOOPT */
2713     /* case EPROTONOSUPPORT */
2714     /* case ESOCKTNOSUPPORT */
2715     /* case EOPNOTSUPP */
2716     /* case EPFNOSUPPORT */
2717     /* case EAFNOSUPPORT */
2718     /* case EADDRINUSE */
2719     /* case EADDRNOTAVAIL */
2720     /* case ENETDOWN */
2721     /* case ENETUNREACH */
2722     /* case ENETRESET */
2723     /* case ECONNABORTED */
2724     /* case ECONNRESET */
2725     /* case ENOBUFS */
2726     /* case EISCONN */
2727     case ENOTCONN: return SS$_CLEARED;
2728     /* case ESHUTDOWN */
2729     /* case ETOOMANYREFS */
2730     /* case ETIMEDOUT */
2731     /* case ECONNREFUSED */
2732     /* case ELOOP */
2733     /* case ENAMETOOLONG */
2734     /* case EHOSTDOWN */
2735     /* case EHOSTUNREACH */
2736     /* case ENOTEMPTY */
2737     /* case EPROCLIM */
2738     /* case EUSERS  */
2739     /* case EDQUOT  */
2740     /* case ENOMSG  */
2741     /* case EIDRM */
2742     /* case EALIGN */
2743     /* case ESTALE */
2744     /* case EREMOTE */
2745     /* case ENOLCK */
2746     /* case ENOSYS */
2747     /* case EFTYPE */
2748     /* case ECANCELED */
2749     /* case EFAIL */
2750     /* case EINPROG */
2751     case ENOTSUP:
2752         return SS$_UNSUPPORTED;
2753     /* case EDEADLK */
2754     /* case ENWAIT */
2755     /* case EILSEQ */
2756     /* case EBADCAT */
2757     /* case EBADMSG */
2758     /* case EABANDONED */
2759     default:
2760         return SS$_ABORT; /* punt */
2761     }
2762 }
2763
2764
2765 /* default piping mailbox size */
2766 #ifdef __VAX
2767 #  define PERL_BUFSIZ        512
2768 #else
2769 #  define PERL_BUFSIZ        8192
2770 #endif
2771
2772
2773 static void
2774 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2775 {
2776   unsigned long int mbxbufsiz;
2777   static unsigned long int syssize = 0;
2778   unsigned long int dviitm = DVI$_DEVNAM;
2779   char csize[LNM$C_NAMLENGTH+1];
2780   int sts;
2781
2782   if (!syssize) {
2783     unsigned long syiitm = SYI$_MAXBUF;
2784     /*
2785      * Get the SYSGEN parameter MAXBUF
2786      *
2787      * If the logical 'PERL_MBX_SIZE' is defined
2788      * use the value of the logical instead of PERL_BUFSIZ, but
2789      * keep the size between 128 and MAXBUF.
2790      *
2791      */
2792     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2793   }
2794
2795   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2796       mbxbufsiz = atoi(csize);
2797   } else {
2798       mbxbufsiz = PERL_BUFSIZ;
2799   }
2800   if (mbxbufsiz < 128) mbxbufsiz = 128;
2801   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2802
2803   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2804
2805   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2806   _ckvmssts_noperl(sts);
2807   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2808
2809 }  /* end of create_mbx() */
2810
2811
2812 /*{{{  my_popen and my_pclose*/
2813
2814 typedef struct _iosb           IOSB;
2815 typedef struct _iosb*         pIOSB;
2816 typedef struct _pipe           Pipe;
2817 typedef struct _pipe*         pPipe;
2818 typedef struct pipe_details    Info;
2819 typedef struct pipe_details*  pInfo;
2820 typedef struct _srqp            RQE;
2821 typedef struct _srqp*          pRQE;
2822 typedef struct _tochildbuf      CBuf;
2823 typedef struct _tochildbuf*    pCBuf;
2824
2825 struct _iosb {
2826     unsigned short status;
2827     unsigned short count;
2828     unsigned long  dvispec;
2829 };
2830
2831 #pragma member_alignment save
2832 #pragma nomember_alignment quadword
2833 struct _srqp {          /* VMS self-relative queue entry */
2834     unsigned long qptr[2];
2835 };
2836 #pragma member_alignment restore
2837 static RQE  RQE_ZERO = {0,0};
2838
2839 struct _tochildbuf {
2840     RQE             q;
2841     int             eof;
2842     unsigned short  size;
2843     char            *buf;
2844 };
2845
2846 struct _pipe {
2847     RQE            free;
2848     RQE            wait;
2849     int            fd_out;
2850     unsigned short chan_in;
2851     unsigned short chan_out;
2852     char          *buf;
2853     unsigned int   bufsize;
2854     IOSB           iosb;
2855     IOSB           iosb2;
2856     int           *pipe_done;
2857     int            retry;
2858     int            type;
2859     int            shut_on_empty;
2860     int            need_wake;
2861     pPipe         *home;
2862     pInfo          info;
2863     pCBuf          curr;
2864     pCBuf          curr2;
2865 #if defined(PERL_IMPLICIT_CONTEXT)
2866     void            *thx;           /* Either a thread or an interpreter */
2867                                     /* pointer, depending on how we're built */
2868 #endif
2869 };
2870
2871
2872 struct pipe_details
2873 {
2874     pInfo           next;
2875     PerlIO *fp;  /* file pointer to pipe mailbox */
2876     int useFILE; /* using stdio, not perlio */
2877     int pid;   /* PID of subprocess */
2878     int mode;  /* == 'r' if pipe open for reading */
2879     int done;  /* subprocess has completed */
2880     int waiting; /* waiting for completion/closure */
2881     int             closing;        /* my_pclose is closing this pipe */
2882     unsigned long   completion;     /* termination status of subprocess */
2883     pPipe           in;             /* pipe in to sub */
2884     pPipe           out;            /* pipe out of sub */
2885     pPipe           err;            /* pipe of sub's sys$error */
2886     int             in_done;        /* true when in pipe finished */
2887     int             out_done;
2888     int             err_done;
2889     unsigned short  xchan;          /* channel to debug xterm */
2890     unsigned short  xchan_valid;    /* channel is assigned */
2891 };
2892
2893 struct exit_control_block
2894 {
2895     struct exit_control_block *flink;
2896     unsigned long int (*exit_routine)(void);
2897     unsigned long int arg_count;
2898     unsigned long int *status_address;
2899     unsigned long int exit_status;
2900 };
2901
2902 typedef struct _closed_pipes    Xpipe;
2903 typedef struct _closed_pipes*  pXpipe;
2904
2905 struct _closed_pipes {
2906     int             pid;            /* PID of subprocess */
2907     unsigned long   completion;     /* termination status of subprocess */
2908 };
2909 #define NKEEPCLOSED 50
2910 static Xpipe closed_list[NKEEPCLOSED];
2911 static int   closed_index = 0;
2912 static int   closed_num = 0;
2913
2914 #define RETRY_DELAY     "0 ::0.20"
2915 #define MAX_RETRY              50
2916
2917 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2918 static unsigned long mypid;
2919 static unsigned long delaytime[2];
2920
2921 static pInfo open_pipes = NULL;
2922 static $DESCRIPTOR(nl_desc, "NL:");
2923
2924 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2925
2926
2927
2928 static unsigned long int
2929 pipe_exit_routine(void)
2930 {
2931     pInfo info;
2932     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2933     int sts, did_stuff, j;
2934
2935    /*
2936     * Flush any pending i/o, but since we are in process run-down, be
2937     * careful about referencing PerlIO structures that may already have
2938     * been deallocated.  We may not even have an interpreter anymore.
2939     */
2940     info = open_pipes;
2941     while (info) {
2942         if (info->fp) {
2943 #if defined(PERL_IMPLICIT_CONTEXT)
2944            /* We need to use the Perl context of the thread that created */
2945            /* the pipe. */
2946            pTHX;
2947            if (info->err)
2948                aTHX = info->err->thx;
2949            else if (info->out)
2950                aTHX = info->out->thx;
2951            else if (info->in)
2952                aTHX = info->in->thx;
2953 #endif
2954            if (!info->useFILE
2955 #if defined(USE_ITHREADS)
2956              && my_perl
2957 #endif
2958 #ifdef USE_PERLIO
2959              && PL_perlio_fd_refcnt
2960 #endif
2961               )
2962                PerlIO_flush(info->fp);
2963            else
2964                fflush((FILE *)info->fp);
2965         }
2966         info = info->next;
2967     }
2968
2969     /*
2970      next we try sending an EOF...ignore if doesn't work, make sure we
2971      don't hang
2972     */
2973     did_stuff = 0;
2974     info = open_pipes;
2975
2976     while (info) {
2977       _ckvmssts_noperl(sys$setast(0));
2978       if (info->in && !info->in->shut_on_empty) {
2979         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2980                                  0, 0, 0, 0, 0, 0));
2981         info->waiting = 1;
2982         did_stuff = 1;
2983       }
2984       _ckvmssts_noperl(sys$setast(1));
2985       info = info->next;
2986     }
2987
2988     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2989
2990     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2991         int nwait = 0;
2992
2993         info = open_pipes;
2994         while (info) {
2995           _ckvmssts_noperl(sys$setast(0));
2996           if (info->waiting && info->done)
2997                 info->waiting = 0;
2998           nwait += info->waiting;
2999           _ckvmssts_noperl(sys$setast(1));
3000           info = info->next;
3001         }
3002         if (!nwait) break;
3003         sleep(1);
3004     }
3005
3006     did_stuff = 0;
3007     info = open_pipes;
3008     while (info) {
3009       _ckvmssts_noperl(sys$setast(0));
3010       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3011         sts = sys$forcex(&info->pid,0,&abort);
3012         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3013         did_stuff = 1;
3014       }
3015       _ckvmssts_noperl(sys$setast(1));
3016       info = info->next;
3017     }
3018
3019     /* again, wait for effect */
3020
3021     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3022         int nwait = 0;
3023
3024         info = open_pipes;
3025         while (info) {
3026           _ckvmssts_noperl(sys$setast(0));
3027           if (info->waiting && info->done)
3028                 info->waiting = 0;
3029           nwait += info->waiting;
3030           _ckvmssts_noperl(sys$setast(1));
3031           info = info->next;
3032         }
3033         if (!nwait) break;
3034         sleep(1);
3035     }
3036
3037     info = open_pipes;
3038     while (info) {
3039       _ckvmssts_noperl(sys$setast(0));
3040       if (!info->done) {  /* We tried to be nice . . . */
3041         sts = sys$delprc(&info->pid,0);
3042         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3043         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3044       }
3045       _ckvmssts_noperl(sys$setast(1));
3046       info = info->next;
3047     }
3048
3049     while(open_pipes) {
3050
3051 #if defined(PERL_IMPLICIT_CONTEXT)
3052       /* We need to use the Perl context of the thread that created */
3053       /* the pipe. */
3054       pTHX;
3055       if (open_pipes->err)
3056           aTHX = open_pipes->err->thx;
3057       else if (open_pipes->out)
3058           aTHX = open_pipes->out->thx;
3059       else if (open_pipes->in)
3060           aTHX = open_pipes->in->thx;
3061 #endif
3062       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3063       else if (!(sts & 1)) retsts = sts;
3064     }
3065     return retsts;
3066 }
3067
3068 static struct exit_control_block pipe_exitblock =
3069        {(struct exit_control_block *) 0,
3070         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3071
3072 static void pipe_mbxtofd_ast(pPipe p);
3073 static void pipe_tochild1_ast(pPipe p);
3074 static void pipe_tochild2_ast(pPipe p);
3075
3076 static void
3077 popen_completion_ast(pInfo info)
3078 {
3079   pInfo i = open_pipes;
3080   int iss;
3081
3082   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3083   closed_list[closed_index].pid = info->pid;
3084   closed_list[closed_index].completion = info->completion;
3085   closed_index++;
3086   if (closed_index == NKEEPCLOSED)
3087     closed_index = 0;
3088   closed_num++;
3089
3090   while (i) {
3091     if (i == info) break;
3092     i = i->next;
3093   }
3094   if (!i) return;       /* unlinked, probably freed too */
3095
3096   info->done = TRUE;
3097
3098 /*
3099     Writing to subprocess ...
3100             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3101
3102             chan_out may be waiting for "done" flag, or hung waiting
3103             for i/o completion to child...cancel the i/o.  This will
3104             put it into "snarf mode" (done but no EOF yet) that discards
3105             input.
3106
3107     Output from subprocess (stdout, stderr) needs to be flushed and
3108     shut down.   We try sending an EOF, but if the mbx is full the pipe
3109     routine should still catch the "shut_on_empty" flag, telling it to
3110     use immediate-style reads so that "mbx empty" -> EOF.
3111
3112
3113 */
3114   if (info->in && !info->in_done) {               /* only for mode=w */
3115         if (info->in->shut_on_empty && info->in->need_wake) {
3116             info->in->need_wake = FALSE;
3117             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3118         } else {
3119             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3120         }
3121   }
3122
3123   if (info->out && !info->out_done) {             /* were we also piping output? */
3124       info->out->shut_on_empty = TRUE;
3125       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3126       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3127       _ckvmssts_noperl(iss);
3128   }
3129
3130   if (info->err && !info->err_done) {        /* we were piping stderr */
3131         info->err->shut_on_empty = TRUE;
3132         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3133         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3134         _ckvmssts_noperl(iss);
3135   }
3136   _ckvmssts_noperl(sys$setef(pipe_ef));
3137
3138 }
3139
3140 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3141 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3142 static void pipe_infromchild_ast(pPipe p);
3143
3144 /*
3145     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3146     inside an AST routine without worrying about reentrancy and which Perl
3147     memory allocator is being used.
3148
3149     We read data and queue up the buffers, then spit them out one at a
3150     time to the output mailbox when the output mailbox is ready for one.
3151
3152 */
3153 #define INITIAL_TOCHILDQUEUE  2
3154
3155 static pPipe
3156 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3157 {
3158     pPipe p;
3159     pCBuf b;
3160     char mbx1[64], mbx2[64];
3161     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3162                                       DSC$K_CLASS_S, mbx1},
3163                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3164                                       DSC$K_CLASS_S, mbx2};
3165     unsigned int dviitm = DVI$_DEVBUFSIZ;
3166     int j, n;
3167
3168     n = sizeof(Pipe);
3169     _ckvmssts_noperl(lib$get_vm(&n, &p));
3170
3171     create_mbx(&p->chan_in , &d_mbx1);
3172     create_mbx(&p->chan_out, &d_mbx2);
3173     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3174
3175     p->buf           = 0;
3176     p->shut_on_empty = FALSE;
3177     p->need_wake     = FALSE;
3178     p->type          = 0;
3179     p->retry         = 0;
3180     p->iosb.status   = SS$_NORMAL;
3181     p->iosb2.status  = SS$_NORMAL;
3182     p->free          = RQE_ZERO;
3183     p->wait          = RQE_ZERO;
3184     p->curr          = 0;
3185     p->curr2         = 0;
3186     p->info          = 0;
3187 #ifdef PERL_IMPLICIT_CONTEXT
3188     p->thx           = aTHX;
3189 #endif
3190
3191     n = sizeof(CBuf) + p->bufsize;
3192
3193     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3194         _ckvmssts_noperl(lib$get_vm(&n, &b));
3195         b->buf = (char *) b + sizeof(CBuf);
3196         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3197     }
3198
3199     pipe_tochild2_ast(p);
3200     pipe_tochild1_ast(p);
3201     strcpy(wmbx, mbx1);
3202     strcpy(rmbx, mbx2);
3203     return p;
3204 }
3205
3206 /*  reads the MBX Perl is writing, and queues */
3207
3208 static void
3209 pipe_tochild1_ast(pPipe p)
3210 {
3211     pCBuf b = p->curr;
3212     int iss = p->iosb.status;
3213     int eof = (iss == SS$_ENDOFFILE);
3214     int sts;
3215 #ifdef PERL_IMPLICIT_CONTEXT
3216     pTHX = p->thx;
3217 #endif
3218
3219     if (p->retry) {
3220         if (eof) {
3221             p->shut_on_empty = TRUE;
3222             b->eof     = TRUE;
3223             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3224         } else  {
3225             _ckvmssts_noperl(iss);
3226         }
3227
3228         b->eof  = eof;
3229         b->size = p->iosb.count;
3230         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3231         if (p->need_wake) {
3232             p->need_wake = FALSE;
3233             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3234         }
3235     } else {
3236         p->retry = 1;   /* initial call */
3237     }
3238
3239     if (eof) {                  /* flush the free queue, return when done */
3240         int n = sizeof(CBuf) + p->bufsize;
3241         while (1) {
3242             iss = lib$remqti(&p->free, &b);
3243             if (iss == LIB$_QUEWASEMP) return;
3244             _ckvmssts_noperl(iss);
3245             _ckvmssts_noperl(lib$free_vm(&n, &b));
3246         }
3247     }
3248
3249     iss = lib$remqti(&p->free, &b);
3250     if (iss == LIB$_QUEWASEMP) {
3251         int n = sizeof(CBuf) + p->bufsize;
3252         _ckvmssts_noperl(lib$get_vm(&n, &b));
3253         b->buf = (char *) b + sizeof(CBuf);
3254     } else {
3255        _ckvmssts_noperl(iss);
3256     }
3257
3258     p->curr = b;
3259     iss = sys$qio(0,p->chan_in,
3260              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3261              &p->iosb,
3262              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3263     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3264     _ckvmssts_noperl(iss);
3265 }
3266
3267
3268 /* writes queued buffers to output, waits for each to complete before
3269    doing the next */
3270
3271 static void
3272 pipe_tochild2_ast(pPipe p)
3273 {
3274     pCBuf b = p->curr2;
3275     int iss = p->iosb2.status;
3276     int n = sizeof(CBuf) + p->bufsize;
3277     int done = (p->info && p->info->done) ||
3278               iss == SS$_CANCEL || iss == SS$_ABORT;
3279 #if defined(PERL_IMPLICIT_CONTEXT)
3280     pTHX = p->thx;
3281 #endif
3282
3283     do {
3284         if (p->type) {         /* type=1 has old buffer, dispose */
3285             if (p->shut_on_empty) {
3286                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3287             } else {
3288                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3289             }
3290             p->type = 0;
3291         }
3292
3293         iss = lib$remqti(&p->wait, &b);
3294         if (iss == LIB$_QUEWASEMP) {
3295             if (p->shut_on_empty) {
3296                 if (done) {
3297                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3298                     *p->pipe_done = TRUE;
3299                     _ckvmssts_noperl(sys$setef(pipe_ef));
3300                 } else {
3301                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3302                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3303                 }
3304                 return;
3305             }
3306             p->need_wake = TRUE;
3307             return;
3308         }
3309         _ckvmssts_noperl(iss);
3310         p->type = 1;
3311     } while (done);
3312
3313
3314     p->curr2 = b;
3315     if (b->eof) {
3316         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3317             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3318     } else {
3319         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3320             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3321     }
3322
3323     return;
3324
3325 }
3326
3327
3328 static pPipe
3329 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3330 {
3331     pPipe p;
3332     char mbx1[64], mbx2[64];
3333     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3334                                       DSC$K_CLASS_S, mbx1},
3335                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3336                                       DSC$K_CLASS_S, mbx2};
3337     unsigned int dviitm = DVI$_DEVBUFSIZ;
3338
3339     int n = sizeof(Pipe);
3340     _ckvmssts_noperl(lib$get_vm(&n, &p));
3341     create_mbx(&p->chan_in , &d_mbx1);
3342     create_mbx(&p->chan_out, &d_mbx2);
3343
3344     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3345     n = p->bufsize * sizeof(char);
3346     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3347     p->shut_on_empty = FALSE;
3348     p->info   = 0;
3349     p->type   = 0;
3350     p->iosb.status = SS$_NORMAL;
3351 #if defined(PERL_IMPLICIT_CONTEXT)
3352     p->thx = aTHX;
3353 #endif
3354     pipe_infromchild_ast(p);
3355
3356     strcpy(wmbx, mbx1);
3357     strcpy(rmbx, mbx2);
3358     return p;
3359 }
3360
3361 static void
3362 pipe_infromchild_ast(pPipe p)
3363 {
3364     int iss = p->iosb.status;
3365     int eof = (iss == SS$_ENDOFFILE);
3366     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3367     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3368 #if defined(PERL_IMPLICIT_CONTEXT)
3369     pTHX = p->thx;
3370 #endif
3371
3372     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3373         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3374         p->chan_out = 0;
3375     }
3376
3377     /* read completed:
3378             input shutdown if EOF from self (done or shut_on_empty)
3379             output shutdown if closing flag set (my_pclose)
3380             send data/eof from child or eof from self
3381             otherwise, re-read (snarf of data from child)
3382     */
3383
3384     if (p->type == 1) {
3385         p->type = 0;
3386         if (myeof && p->chan_in) {                  /* input shutdown */
3387             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3388             p->chan_in = 0;
3389         }
3390
3391         if (p->chan_out) {
3392             if (myeof || kideof) {      /* pass EOF to parent */
3393                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3394                                          pipe_infromchild_ast, p,
3395                                          0, 0, 0, 0, 0, 0));
3396                 return;
3397             } else if (eof) {       /* eat EOF --- fall through to read*/
3398
3399             } else {                /* transmit data */
3400                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3401                                          pipe_infromchild_ast,p,
3402                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3403                 return;
3404             }
3405         }
3406     }
3407
3408     /*  everything shut? flag as done */
3409
3410     if (!p->chan_in && !p->chan_out) {
3411         *p->pipe_done = TRUE;
3412         _ckvmssts_noperl(sys$setef(pipe_ef));
3413         return;
3414     }
3415
3416     /* write completed (or read, if snarfing from child)
3417             if still have input active,
3418                queue read...immediate mode if shut_on_empty so we get EOF if empty
3419             otherwise,
3420                check if Perl reading, generate EOFs as needed
3421     */
3422
3423     if (p->type == 0) {
3424         p->type = 1;
3425         if (p->chan_in) {
3426             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3427                           pipe_infromchild_ast,p,
3428                           p->buf, p->bufsize, 0, 0, 0, 0);
3429             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3430             _ckvmssts_noperl(iss);
3431         } else {           /* send EOFs for extra reads */
3432             p->iosb.status = SS$_ENDOFFILE;
3433             p->iosb.dvispec = 0;
3434             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3435                                      0, 0, 0,
3436                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3437         }
3438     }
3439 }
3440
3441 static pPipe
3442 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3443 {
3444     pPipe p;
3445     char mbx[64];
3446     unsigned long dviitm = DVI$_DEVBUFSIZ;
3447     struct stat s;
3448     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3449                                       DSC$K_CLASS_S, mbx};
3450     int n = sizeof(Pipe);
3451
3452     /* things like terminals and mbx's don't need this filter */
3453     if (fd && fstat(fd,&s) == 0) {
3454         unsigned long devchar;
3455         char device[65];
3456         unsigned short dev_len;
3457         struct dsc$descriptor_s d_dev;
3458         char * cptr;
3459         struct item_list_3 items[3];
3460         int status;
3461         unsigned short dvi_iosb[4];
3462
3463         cptr = getname(fd, out, 1);
3464         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3465         d_dev.dsc$a_pointer = out;
3466         d_dev.dsc$w_length = strlen(out);
3467         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3468         d_dev.dsc$b_class = DSC$K_CLASS_S;
3469
3470         items[0].len = 4;
3471         items[0].code = DVI$_DEVCHAR;
3472         items[0].bufadr = &devchar;
3473         items[0].retadr = NULL;
3474         items[1].len = 64;
3475         items[1].code = DVI$_FULLDEVNAM;
3476         items[1].bufadr = device;
3477         items[1].retadr = &dev_len;
3478         items[2].len = 0;
3479         items[2].code = 0;
3480
3481         status = sys$getdviw
3482                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3483         _ckvmssts_noperl(status);
3484         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3485             device[dev_len] = 0;
3486
3487             if (!(devchar & DEV$M_DIR)) {
3488                 strcpy(out, device);
3489                 return 0;
3490             }
3491         }
3492     }
3493
3494     _ckvmssts_noperl(lib$get_vm(&n, &p));
3495     p->fd_out = dup(fd);
3496     create_mbx(&p->chan_in, &d_mbx);
3497     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3498     n = (p->bufsize+1) * sizeof(char);
3499     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3500     p->shut_on_empty = FALSE;
3501     p->retry = 0;
3502     p->info  = 0;
3503     strcpy(out, mbx);
3504
3505     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3506                              pipe_mbxtofd_ast, p,
3507                              p->buf, p->bufsize, 0, 0, 0, 0));
3508
3509     return p;
3510 }
3511
3512 static void
3513 pipe_mbxtofd_ast(pPipe p)
3514 {
3515     int iss = p->iosb.status;
3516     int done = p->info->done;
3517     int iss2;
3518     int eof = (iss == SS$_ENDOFFILE);
3519     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3520     int err = !(iss&1) && !eof;
3521 #if defined(PERL_IMPLICIT_CONTEXT)
3522     pTHX = p->thx;
3523 #endif
3524
3525     if (done && myeof) {               /* end piping */
3526         close(p->fd_out);
3527         sys$dassgn(p->chan_in);
3528         *p->pipe_done = TRUE;
3529         _ckvmssts_noperl(sys$setef(pipe_ef));
3530         return;
3531     }
3532
3533     if (!err && !eof) {             /* good data to send to file */
3534         p->buf[p->iosb.count] = '\n';
3535         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3536         if (iss2 < 0) {
3537             p->retry++;
3538             if (p->retry < MAX_RETRY) {
3539                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3540                 return;
3541             }
3542         }
3543         p->retry = 0;
3544     } else if (err) {
3545         _ckvmssts_noperl(iss);
3546     }
3547
3548
3549     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3550           pipe_mbxtofd_ast, p,
3551           p->buf, p->bufsize, 0, 0, 0, 0);
3552     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3553     _ckvmssts_noperl(iss);
3554 }
3555
3556
3557 typedef struct _pipeloc     PLOC;
3558 typedef struct _pipeloc*   pPLOC;
3559
3560 struct _pipeloc {
3561     pPLOC   next;
3562     char    dir[NAM$C_MAXRSS+1];
3563 };
3564 static pPLOC  head_PLOC = 0;
3565
3566 void
3567 free_pipelocs(pTHX_ void *head)
3568 {
3569     pPLOC p, pnext;
3570     pPLOC *pHead = (pPLOC *)head;
3571
3572     p = *pHead;
3573     while (p) {
3574         pnext = p->next;
3575         PerlMem_free(p);
3576         p = pnext;
3577     }
3578     *pHead = 0;
3579 }
3580
3581 static void
3582 store_pipelocs(pTHX)
3583 {
3584     int    i;
3585     pPLOC  p;
3586     AV    *av = 0;
3587     SV    *dirsv;
3588     char  *dir, *x;
3589     char  *unixdir;
3590     char  temp[NAM$C_MAXRSS+1];
3591     STRLEN n_a;
3592
3593     if (head_PLOC)
3594         free_pipelocs(aTHX_ &head_PLOC);
3595
3596 /*  the . directory from @INC comes last */
3597
3598     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3599     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3600     p->next = head_PLOC;
3601     head_PLOC = p;
3602     strcpy(p->dir,"./");
3603
3604 /*  get the directory from $^X */
3605
3606     unixdir = PerlMem_malloc(VMS_MAXRSS);
3607     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3608
3609 #ifdef PERL_IMPLICIT_CONTEXT
3610     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3611 #else
3612     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3613 #endif
3614         my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3615         x = strrchr(temp,']');
3616         if (x == NULL) {
3617         x = strrchr(temp,'>');
3618           if (x == NULL) {
3619             /* It could be a UNIX path */
3620             x = strrchr(temp,'/');
3621           }
3622         }
3623         if (x)
3624           x[1] = '\0';
3625         else {
3626           /* Got a bare name, so use default directory */
3627           temp[0] = '.';
3628           temp[1] = '\0';
3629         }
3630
3631         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3632             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3633             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3634             p->next = head_PLOC;
3635             head_PLOC = p;
3636             my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3637         }
3638     }
3639
3640 /*  reverse order of @INC entries, skip "." since entered above */
3641
3642 #ifdef PERL_IMPLICIT_CONTEXT
3643     if (aTHX)
3644 #endif
3645     if (PL_incgv) av = GvAVn(PL_incgv);
3646
3647     for (i = 0; av && i <= AvFILL(av); i++) {
3648         dirsv = *av_fetch(av,i,TRUE);
3649
3650         if (SvROK(dirsv)) continue;
3651         dir = SvPVx(dirsv,n_a);
3652         if (strcmp(dir,".") == 0) continue;
3653         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3654             continue;
3655
3656         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3657         p->next = head_PLOC;
3658         head_PLOC = p;
3659         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3660     }
3661
3662 /* most likely spot (ARCHLIB) put first in the list */
3663
3664 #ifdef ARCHLIB_EXP
3665     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3666         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3667         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3668         p->next = head_PLOC;
3669         head_PLOC = p;
3670         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3671     }
3672 #endif
3673     PerlMem_free(unixdir);
3674 }
3675
3676 static I32
3677 Perl_cando_by_name_int
3678    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3679 #if !defined(PERL_IMPLICIT_CONTEXT)
3680 #define cando_by_name_int               Perl_cando_by_name_int
3681 #else
3682 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3683 #endif
3684
3685 static char *
3686 find_vmspipe(pTHX)
3687 {
3688     static int   vmspipe_file_status = 0;
3689     static char  vmspipe_file[NAM$C_MAXRSS+1];
3690
3691     /* already found? Check and use ... need read+execute permission */
3692
3693     if (vmspipe_file_status == 1) {
3694         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3695          && cando_by_name_int
3696            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3697             return vmspipe_file;
3698         }
3699         vmspipe_file_status = 0;
3700     }
3701
3702     /* scan through stored @INC, $^X */
3703
3704     if (vmspipe_file_status == 0) {
3705         char file[NAM$C_MAXRSS+1];
3706         pPLOC  p = head_PLOC;
3707
3708         while (p) {
3709             char * exp_res;
3710             int dirlen;
3711             dirlen = my_strlcpy(file, p->dir, sizeof(file));
3712             my_strlcat(file, "vmspipe.com", sizeof(file));
3713             p = p->next;
3714
3715             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3716             if (!exp_res) continue;
3717
3718             if (cando_by_name_int
3719                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3720              && cando_by_name_int
3721                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3722                 vmspipe_file_status = 1;
3723                 return vmspipe_file;
3724             }
3725         }
3726         vmspipe_file_status = -1;   /* failed, use tempfiles */
3727     }
3728
3729     return 0;
3730 }
3731
3732 static FILE *
3733 vmspipe_tempfile(pTHX)
3734 {
3735     char file[NAM$C_MAXRSS+1];
3736     FILE *fp;
3737     static int index = 0;
3738     Stat_t s0, s1;
3739     int cmp_result;
3740
3741     /* create a tempfile */
3742
3743     /* we can't go from   W, shr=get to  R, shr=get without
3744        an intermediate vulnerable state, so don't bother trying...
3745
3746        and lib$spawn doesn't shr=put, so have to close the write
3747
3748        So... match up the creation date/time and the FID to
3749        make sure we're dealing with the same file
3750
3751     */
3752
3753     index++;
3754     if (!decc_filename_unix_only) {
3755       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3756       fp = fopen(file,"w");
3757       if (!fp) {
3758         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3759         fp = fopen(file,"w");
3760         if (!fp) {
3761             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3762             fp = fopen(file,"w");
3763         }
3764       }
3765      }
3766      else {
3767       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3768       fp = fopen(file,"w");
3769       if (!fp) {
3770         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3771         fp = fopen(file,"w");
3772         if (!fp) {
3773           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3774           fp = fopen(file,"w");
3775         }
3776       }
3777     }
3778     if (!fp) return 0;  /* we're hosed */
3779
3780     fprintf(fp,"$! 'f$verify(0)'\n");
3781     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3782     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3783     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3784     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3785     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3786     fprintf(fp,"$ perl_del    = \"delete\"\n");
3787     fprintf(fp,"$ pif         = \"if\"\n");
3788     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3789     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3790     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3791     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3792     fprintf(fp,"$!  --- build command line to get max possible length\n");
3793     fprintf(fp,"$c=perl_popen_cmd0\n");
3794     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3795     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3796     fprintf(fp,"$x=perl_popen_cmd3\n");
3797     fprintf(fp,"$c=c+x\n");
3798     fprintf(fp,"$ perl_on\n");
3799     fprintf(fp,"$ 'c'\n");
3800     fprintf(fp,"$ perl_status = $STATUS\n");
3801     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3802     fprintf(fp,"$ perl_exit 'perl_status'\n");
3803     fsync(fileno(fp));
3804
3805     fgetname(fp, file, 1);
3806     fstat(fileno(fp), &s0.crtl_stat);
3807     fclose(fp);
3808
3809     if (decc_filename_unix_only)
3810         int_tounixspec(file, file, NULL);
3811     fp = fopen(file,"r","shr=get");
3812     if (!fp) return 0;
3813     fstat(fileno(fp), &s1.crtl_stat);
3814
3815     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3816     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3817         fclose(fp);
3818         return 0;
3819     }
3820
3821     return fp;
3822 }
3823
3824
3825 static int vms_is_syscommand_xterm(void)
3826 {
3827     const static struct dsc$descriptor_s syscommand_dsc =
3828       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3829
3830     const static struct dsc$descriptor_s decwdisplay_dsc =
3831       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3832
3833     struct item_list_3 items[2];
3834     unsigned short dvi_iosb[4];
3835     unsigned long devchar;
3836     unsigned long devclass;
3837     int status;
3838
3839     /* Very simple check to guess if sys$command is a decterm? */
3840     /* First see if the DECW$DISPLAY: device exists */
3841     items[0].len = 4;
3842     items[0].code = DVI$_DEVCHAR;
3843     items[0].bufadr = &devchar;
3844     items[0].retadr = NULL;
3845     items[1].len = 0;
3846     items[1].code = 0;
3847
3848     status = sys$getdviw
3849         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3850
3851     if ($VMS_STATUS_SUCCESS(status)) {
3852         status = dvi_iosb[0];
3853     }
3854
3855     if (!$VMS_STATUS_SUCCESS(status)) {
3856         SETERRNO(EVMSERR, status);
3857         return -1;
3858     }
3859
3860     /* If it does, then for now assume that we are on a workstation */
3861     /* Now verify that SYS$COMMAND is a terminal */
3862     /* for creating the debugger DECTerm */
3863
3864     items[0].len = 4;
3865     items[0].code = DVI$_DEVCLASS;
3866     items[0].bufadr = &devclass;
3867     items[0].retadr = NULL;
3868     items[1].len = 0;
3869     items[1].code = 0;
3870
3871     status = sys$getdviw
3872         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3873
3874     if ($VMS_STATUS_SUCCESS(status)) {
3875         status = dvi_iosb[0];
3876     }
3877
3878     if (!$VMS_STATUS_SUCCESS(status)) {
3879         SETERRNO(EVMSERR, status);
3880         return -1;
3881     }
3882     else {
3883         if (devclass == DC$_TERM) {
3884             return 0;
3885         }
3886     }
3887     return -1;
3888 }
3889
3890 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3891 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3892 {
3893     int status;
3894     int ret_stat;
3895     char * ret_char;
3896     char device_name[65];
3897     unsigned short device_name_len;
3898     struct dsc$descriptor_s customization_dsc;
3899     struct dsc$descriptor_s device_name_dsc;
3900     const char * cptr;
3901     char customization[200];
3902     char title[40];
3903     pInfo info = NULL;
3904     char mbx1[64];
3905     unsigned short p_chan;
3906     int n;
3907     unsigned short iosb[4];
3908     const char * cust_str =
3909         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3910     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3911                                           DSC$K_CLASS_S, mbx1};
3912
3913      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3914     /*---------------------------------------*/
3915     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3916
3917
3918     /* Make sure that this is from the Perl debugger */
3919     ret_char = strstr(cmd," xterm ");
3920     if (ret_char == NULL)
3921         return NULL;
3922     cptr = ret_char + 7;
3923     ret_char = strstr(cmd,"tty");
3924     if (ret_char == NULL)
3925         return NULL;
3926     ret_char = strstr(cmd,"sleep");
3927     if (ret_char == NULL)
3928         return NULL;
3929
3930     if (decw_term_port == 0) {
3931         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3932         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3933         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3934
3935        status = lib$find_image_symbol
3936                                (&filename1_dsc,
3937                                 &decw_term_port_dsc,
3938                                 (void *)&decw_term_port,
3939                                 NULL,
3940                                 0);
3941
3942         /* Try again with the other image name */
3943         if (!$VMS_STATUS_SUCCESS(status)) {
3944
3945            status = lib$find_image_symbol
3946                                (&filename2_dsc,
3947                                 &decw_term_port_dsc,
3948                                 (void *)&decw_term_port,
3949                                 NULL,
3950                                 0);
3951
3952         }
3953
3954     }
3955
3956
3957     /* No decw$term_port, give it up */
3958     if (!$VMS_STATUS_SUCCESS(status))
3959         return NULL;
3960
3961     /* Are we on a workstation? */
3962     /* to do: capture the rows / columns and pass their properties */
3963     ret_stat = vms_is_syscommand_xterm();
3964     if (ret_stat < 0)
3965         return NULL;
3966
3967     /* Make the title: */
3968     ret_char = strstr(cptr,"-title");
3969     if (ret_char != NULL) {
3970         while ((*cptr != 0) && (*cptr != '\"')) {
3971             cptr++;
3972         }
3973         if (*cptr == '\"')
3974             cptr++;
3975         n = 0;
3976         while ((*cptr != 0) && (*cptr != '\"')) {
3977             title[n] = *cptr;
3978             n++;
3979             if (n == 39) {
3980                 title[39] = 0;
3981                 break;
3982             }
3983             cptr++;
3984         }
3985         title[n] = 0;
3986     }
3987     else {
3988             /* Default title */
3989             strcpy(title,"Perl Debug DECTerm");
3990     }
3991     sprintf(customization, cust_str, title);
3992
3993     customization_dsc.dsc$a_pointer = customization;
3994     customization_dsc.dsc$w_length = strlen(customization);
3995     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3996     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3997
3998     device_name_dsc.dsc$a_pointer = device_name;
3999     device_name_dsc.dsc$w_length = sizeof device_name -1;
4000     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4001     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4002
4003     device_name_len = 0;
4004
4005     /* Try to create the window */
4006      status = (*decw_term_port)
4007        (NULL,
4008         NULL,
4009         &customization_dsc,
4010         &device_name_dsc,
4011         &device_name_len,
4012         NULL,
4013         NULL,
4014         NULL);
4015     if (!$VMS_STATUS_SUCCESS(status)) {
4016         SETERRNO(EVMSERR, status);
4017         return NULL;
4018     }
4019
4020     device_name[device_name_len] = '\0';
4021
4022     /* Need to set this up to look like a pipe for cleanup */
4023     n = sizeof(Info);
4024     status = lib$get_vm(&n, &info);
4025     if (!$VMS_STATUS_SUCCESS(status)) {
4026         SETERRNO(ENOMEM, status);
4027         return NULL;
4028     }
4029
4030     info->mode = *mode;
4031     info->done = FALSE;
4032     info->completion = 0;
4033     info->closing    = FALSE;
4034     info->in         = 0;
4035     info->out        = 0;
4036     info->err        = 0;
4037     info->fp         = NULL;
4038     info->useFILE    = 0;
4039     info->waiting    = 0;
4040     info->in_done    = TRUE;
4041     info->out_done   = TRUE;
4042     info->err_done   = TRUE;
4043
4044     /* Assign a channel on this so that it will persist, and not login */
4045     /* We stash this channel in the info structure for reference. */
4046     /* The created xterm self destructs when the last channel is removed */
4047     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4048     /* So leave this assigned. */
4049     device_name_dsc.dsc$w_length = device_name_len;
4050     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4051     if (!$VMS_STATUS_SUCCESS(status)) {
4052         SETERRNO(EVMSERR, status);
4053         return NULL;
4054     }
4055     info->xchan_valid = 1;
4056
4057     /* Now create a mailbox to be read by the application */
4058
4059     create_mbx(&p_chan, &d_mbx1);
4060
4061     /* write the name of the created terminal to the mailbox */
4062     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4063             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4064
4065     if (!$VMS_STATUS_SUCCESS(status)) {
4066         SETERRNO(EVMSERR, status);
4067         return NULL;
4068     }
4069
4070     info->fp  = PerlIO_open(mbx1, mode);
4071
4072     /* Done with this channel */
4073     sys$dassgn(p_chan);
4074
4075     /* If any errors, then clean up */
4076     if (!info->fp) {
4077         n = sizeof(Info);
4078         _ckvmssts_noperl(lib$free_vm(&n, &info));
4079         return NULL;
4080         }
4081
4082     /* All done */
4083     return info->fp;
4084 }
4085
4086 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4087
4088 static PerlIO *
4089 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4090 {
4091     static int handler_set_up = FALSE;
4092     PerlIO * ret_fp;
4093     unsigned long int sts, flags = CLI$M_NOWAIT;
4094     /* The use of a GLOBAL table (as was done previously) rendered
4095      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4096      * environment.  Hence we've switched to LOCAL symbol table.
4097      */
4098     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4099     int j, wait = 0, n;
4100     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4101     char *in, *out, *err, mbx[512];
4102     FILE *tpipe = 0;
4103     char tfilebuf[NAM$C_MAXRSS+1];
4104     pInfo info = NULL;
4105     char cmd_sym_name[20];
4106     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4107                                       DSC$K_CLASS_S, symbol};
4108     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4109                                       DSC$K_CLASS_S, 0};
4110     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4111                                       DSC$K_CLASS_S, cmd_sym_name};
4112     struct dsc$descriptor_s *vmscmd;
4113     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4114     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4115     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4116
4117     /* Check here for Xterm create request.  This means looking for
4118      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4119      *  is possible to create an xterm.
4120      */
4121     if (*in_mode == 'r') {
4122         PerlIO * xterm_fd;
4123
4124 #if defined(PERL_IMPLICIT_CONTEXT)
4125         /* Can not fork an xterm with a NULL context */
4126         /* This probably could never happen */
4127         xterm_fd = NULL;
4128         if (aTHX != NULL)
4129 #endif
4130         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4131         if (xterm_fd != NULL)
4132             return xterm_fd;
4133     }
4134
4135     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4136
4137     /* once-per-program initialization...
4138        note that the SETAST calls and the dual test of pipe_ef
4139        makes sure that only the FIRST thread through here does
4140        the initialization...all other threads wait until it's
4141        done.
4142
4143        Yeah, uglier than a pthread call, it's got all the stuff inline
4144        rather than in a separate routine.
4145     */
4146
4147     if (!pipe_ef) {
4148         _ckvmssts_noperl(sys$setast(0));
4149         if (!pipe_ef) {
4150             unsigned long int pidcode = JPI$_PID;
4151             $DESCRIPTOR(d_delay, RETRY_DELAY);
4152             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4153             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4154             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4155         }
4156         if (!handler_set_up) {
4157           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4158           handler_set_up = TRUE;
4159         }
4160         _ckvmssts_noperl(sys$setast(1));
4161     }
4162
4163     /* see if we can find a VMSPIPE.COM */
4164
4165     tfilebuf[0] = '@';
4166     vmspipe = find_vmspipe(aTHX);
4167     if (vmspipe) {
4168         vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4169     } else {        /* uh, oh...we're in tempfile hell */
4170         tpipe = vmspipe_tempfile(aTHX);
4171         if (!tpipe) {       /* a fish popular in Boston */
4172             if (ckWARN(WARN_PIPE)) {
4173                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4174             }
4175         return NULL;
4176         }
4177         fgetname(tpipe,tfilebuf+1,1);
4178         vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4179     }
4180     vmspipedsc.dsc$a_pointer = tfilebuf;
4181
4182     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4183     if (!(sts & 1)) {
4184       switch (sts) {
4185         case RMS$_FNF:  case RMS$_DNF:
4186           set_errno(ENOENT); break;
4187         case RMS$_DIR:
4188           set_errno(ENOTDIR); break;
4189         case RMS$_DEV:
4190           set_errno(ENODEV); break;
4191         case RMS$_PRV:
4192           set_errno(EACCES); break;
4193         case RMS$_SYN:
4194           set_errno(EINVAL); break;
4195         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4196           set_errno(E2BIG); break;
4197         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4198           _ckvmssts_noperl(sts); /* fall through */
4199         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4200           set_errno(EVMSERR);
4201       }
4202       set_vaxc_errno(sts);
4203       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4204         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4205       }
4206       *psts = sts;
4207       return NULL;
4208     }
4209     n = sizeof(Info);
4210     _ckvmssts_noperl(lib$get_vm(&n, &info));
4211
4212     my_strlcpy(mode, in_mode, sizeof(mode));
4213     info->mode = *mode;
4214     info->done = FALSE;
4215     info->completion = 0;
4216     info->closing    = FALSE;
4217     info->in         = 0;
4218     info->out        = 0;
4219     info->err        = 0;
4220     info->fp         = NULL;
4221     info->useFILE    = 0;
4222     info->waiting    = 0;
4223     info->in_done    = TRUE;
4224     info->out_done   = TRUE;
4225     info->err_done   = TRUE;
4226     info->xchan      = 0;
4227     info->xchan_valid = 0;
4228
4229     in = PerlMem_malloc(VMS_MAXRSS);
4230     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4231     out = PerlMem_malloc(VMS_MAXRSS);
4232     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4233     err = PerlMem_malloc(VMS_MAXRSS);
4234     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4235
4236     in[0] = out[0] = err[0] = '\0';
4237
4238     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4239         info->useFILE = 1;
4240         strcpy(p,p+1);
4241     }
4242     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4243         wait = 1;
4244         strcpy(p,p+1);
4245     }
4246
4247     if (*mode == 'r') {             /* piping from subroutine */
4248
4249         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4250         if (info->out) {
4251             info->out->pipe_done = &info->out_done;
4252             info->out_done = FALSE;
4253             info->out->info = info;
4254         }
4255         if (!info->useFILE) {
4256             info->fp  = PerlIO_open(mbx, mode);
4257         } else {
4258             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4259             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4260         }
4261
4262         if (!info->fp && info->out) {
4263             sys$cancel(info->out->chan_out);
4264
4265             while (!info->out_done) {
4266                 int done;
4267                 _ckvmssts_noperl(sys$setast(0));
4268                 done = info->out_done;
4269                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4270                 _ckvmssts_noperl(sys$setast(1));
4271                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4272             }
4273
4274             if (info->out->buf) {
4275                 n = info->out->bufsize * sizeof(char);
4276                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4277             }
4278             n = sizeof(Pipe);
4279             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4280             n = sizeof(Info);
4281             _ckvmssts_noperl(lib$free_vm(&n, &info));
4282             *psts = RMS$_FNF;
4283             return NULL;
4284         }
4285
4286         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4287         if (info->err) {
4288             info->err->pipe_done = &info->err_done;
4289             info->err_done = FALSE;
4290             info->err->info = info;
4291         }
4292
4293     } else if (*mode == 'w') {      /* piping to subroutine */
4294
4295         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4296         if (info->out) {
4297             info->out->pipe_done = &info->out_done;
4298             info->out_done = FALSE;
4299             info->out->info = info;
4300         }
4301
4302         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4303         if (info->err) {
4304             info->err->pipe_done = &info->err_done;
4305             info->err_done = FALSE;
4306             info->err->info = info;
4307         }
4308
4309         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4310         if (!info->useFILE) {
4311             info->fp  = PerlIO_open(mbx, mode);
4312         } else {
4313             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4314             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4315         }
4316
4317         if (info->in) {
4318             info->in->pipe_done = &info->in_done;
4319             info->in_done = FALSE;
4320             info->in->info = info;
4321         }
4322
4323         /* error cleanup */
4324         if (!info->fp && info->in) {
4325             info->done = TRUE;
4326             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4327                                       0, 0, 0, 0, 0, 0, 0, 0));
4328
4329             while (!info->in_done) {
4330                 int done;
4331                 _ckvmssts_noperl(sys$setast(0));
4332                 done = info->in_done;
4333                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4334                 _ckvmssts_noperl(sys$setast(1));
4335                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4336             }
4337
4338             if (info->in->buf) {
4339                 n = info->in->bufsize * sizeof(char);
4340                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4341             }
4342             n = sizeof(Pipe);
4343             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4344             n = sizeof(Info);
4345             _ckvmssts_noperl(lib$free_vm(&n, &info));
4346             *psts = RMS$_FNF;
4347             return NULL;
4348         }
4349
4350
4351     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4352         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4353         if (info->out) {
4354             info->out->pipe_done = &info->out_done;
4355             info->out_done = FALSE;
4356             info->out->info = info;
4357         }
4358
4359         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4360         if (info->err) {
4361             info->err->pipe_done = &info->err_done;
4362             info->err_done = FALSE;
4363             info->err->info = info;
4364         }
4365     }
4366
4367     d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4368     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4369
4370     d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4371     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4372
4373     d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4374     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4375
4376     /* Done with the names for the pipes */
4377     PerlMem_free(err);
4378     PerlMem_free(out);
4379     PerlMem_free(in);
4380
4381     p = vmscmd->dsc$a_pointer;
4382     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4383     if (*p == '$') p++;                         /* remove leading $ */
4384     while (*p == ' ' || *p == '\t') p++;
4385
4386     for (j = 0; j < 4; j++) {
4387         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4388         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4389
4390     d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4391     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4392
4393         if (strlen(p) > MAX_DCL_SYMBOL) {
4394             p += MAX_DCL_SYMBOL;
4395         } else {
4396             p += strlen(p);
4397         }
4398     }
4399     _ckvmssts_noperl(sys$setast(0));
4400     info->next=open_pipes;  /* prepend to list */
4401     open_pipes=info;
4402     _ckvmssts_noperl(sys$setast(1));
4403     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4404      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4405      * have SYS$COMMAND if we need it.
4406      */
4407     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4408                       0, &info->pid, &info->completion,
4409                       0, popen_completion_ast,info,0,0,0));
4410
4411     /* if we were using a tempfile, close it now */
4412
4413     if (tpipe) fclose(tpipe);
4414
4415     /* once the subprocess is spawned, it has copied the symbols and
4416        we can get rid of ours */
4417
4418     for (j = 0; j < 4; j++) {
4419         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4420         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4421     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4422     }
4423     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4424     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4425     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4426     vms_execfree(vmscmd);
4427
4428 #ifdef PERL_IMPLICIT_CONTEXT
4429     if (aTHX)
4430 #endif
4431     PL_forkprocess = info->pid;
4432
4433     ret_fp = info->fp;
4434     if (wait) {
4435          dSAVEDERRNO;
4436          int done = 0;
4437          while (!done) {
4438              _ckvmssts_noperl(sys$setast(0));
4439              done = info->done;
4440              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4441              _ckvmssts_noperl(sys$setast(1));
4442              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4443          }
4444         *psts = info->completion;
4445 /* Caller thinks it is open and tries to close it. */
4446 /* This causes some problems, as it changes the error status */
4447 /*        my_pclose(info->fp); */
4448
4449          /* If we did not have a file pointer open, then we have to */
4450          /* clean up here or eventually we will run out of something */
4451          SAVE_ERRNO;
4452          if (info->fp == NULL) {
4453              my_pclose_pinfo(aTHX_ info);
4454          }
4455          RESTORE_ERRNO;
4456
4457     } else {
4458         *psts = info->pid;
4459     }
4460     return ret_fp;
4461 }  /* end of safe_popen */
4462
4463
4464 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4465 PerlIO *
4466 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4467 {
4468     int sts;
4469     TAINT_ENV();
4470     TAINT_PROPER("popen");
4471     PERL_FLUSHALL_FOR_CHILD;
4472     return safe_popen(aTHX_ cmd,mode,&sts);
4473 }
4474
4475 /*}}}*/
4476
4477
4478 /* Routine to close and cleanup a pipe info structure */
4479
4480 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4481
4482     unsigned long int retsts;
4483     int done, n;
4484     pInfo next, last;
4485
4486     /* If we were writing to a subprocess, insure that someone reading from
4487      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4488      * produce an EOF record in the mailbox.
4489      *
4490      *  well, at least sometimes it *does*, so we have to watch out for
4491      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4492      */
4493      if (info->fp) {
4494         if (!info->useFILE
4495 #if defined(USE_ITHREADS)
4496           && my_perl
4497 #endif
4498 #ifdef USE_PERLIO
4499           && PL_perlio_fd_refcnt
4500 #endif
4501            )
4502             PerlIO_flush(info->fp);
4503         else
4504             fflush((FILE *)info->fp);
4505     }
4506
4507     _ckvmssts(sys$setast(0));
4508      info->closing = TRUE;
4509      done = info->done && info->in_done && info->out_done && info->err_done;
4510      /* hanging on write to Perl's input? cancel it */
4511      if (info->mode == 'r' && info->out && !info->out_done) {
4512         if (info->out->chan_out) {
4513             _ckvmssts(sys$cancel(info->out->chan_out));
4514             if (!info->out->chan_in) {   /* EOF generation, need AST */
4515                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4516             }
4517         }
4518      }
4519      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4520          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4521                            0, 0, 0, 0, 0, 0));
4522     _ckvmssts(sys$setast(1));
4523     if (info->fp) {
4524      if (!info->useFILE
4525 #if defined(USE_ITHREADS)
4526          && my_perl
4527 #endif
4528 #ifdef USE_PERLIO
4529          && PL_perlio_fd_refcnt
4530 #endif
4531         )
4532         PerlIO_close(info->fp);
4533      else
4534         fclose((FILE *)info->fp);
4535     }
4536      /*
4537         we have to wait until subprocess completes, but ALSO wait until all
4538         the i/o completes...otherwise we'll be freeing the "info" structure
4539         that the i/o ASTs could still be using...
4540      */
4541
4542      while (!done) {
4543          _ckvmssts(sys$setast(0));
4544          done = info->done && info->in_done && info->out_done && info->err_done;
4545          if (!done) _ckvmssts(sys$clref(pipe_ef));
4546          _ckvmssts(sys$setast(1));
4547          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4548      }
4549      retsts = info->completion;
4550
4551     /* remove from list of open pipes */
4552     _ckvmssts(sys$setast(0));
4553     last = NULL;
4554     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4555         if (next == info)
4556             break;
4557     }
4558
4559     if (last)
4560         last->next = info->next;
4561     else
4562         open_pipes = info->next;
4563     _ckvmssts(sys$setast(1));
4564
4565     /* free buffers and structures */
4566
4567     if (info->in) {
4568         if (info->in->buf) {
4569             n = info->in->bufsize * sizeof(char);
4570             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4571         }
4572         n = sizeof(Pipe);
4573         _ckvmssts(lib$free_vm(&n, &info->in));
4574     }
4575     if (info->out) {
4576         if (info->out->buf) {
4577             n = info->out->bufsize * sizeof(char);
4578             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4579         }
4580         n = sizeof(Pipe);
4581         _ckvmssts(lib$free_vm(&n, &info->out));
4582     }
4583     if (info->err) {
4584         if (info->err->buf) {
4585             n = info->err->bufsize * sizeof(char);
4586             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4587         }
4588         n = sizeof(Pipe);
4589         _ckvmssts(lib$free_vm(&n, &info->err));
4590     }
4591     n = sizeof(Info);
4592     _ckvmssts(lib$free_vm(&n, &info));
4593
4594     return retsts;
4595 }
4596
4597
4598 /*{{{  I32 my_pclose(PerlIO *fp)*/
4599 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4600 {
4601     pInfo info, last = NULL;
4602     I32 ret_status;
4603
4604     /* Fixme - need ast and mutex protection here */
4605     for (info = open_pipes; info != NULL; last = info, info = info->next)
4606         if (info->fp == fp) break;
4607
4608     if (info == NULL) {  /* no such pipe open */
4609       set_errno(ECHILD); /* quoth POSIX */
4610       set_vaxc_errno(SS$_NONEXPR);
4611       return -1;
4612     }
4613
4614     ret_status = my_pclose_pinfo(aTHX_ info);
4615
4616     return ret_status;
4617
4618 }  /* end of my_pclose() */
4619
4620 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4621   /* Roll our own prototype because we want this regardless of whether
4622    * _VMS_WAIT is defined.
4623    */
4624   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4625 #endif
4626 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4627    created with popen(); otherwise partially emulate waitpid() unless
4628    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4629    Also check processes not considered by the CRTL waitpid().
4630  */
4631 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4632 Pid_t
4633 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4634 {
4635     pInfo info;
4636     int done;
4637     int sts;
4638     int j;
4639
4640     if (statusp) *statusp = 0;
4641
4642     for (info = open_pipes; info != NULL; info = info->next)
4643         if (info->pid == pid) break;
4644
4645     if (info != NULL) {  /* we know about this child */
4646       while (!info->done) {
4647           _ckvmssts(sys$setast(0));
4648           done = info->done;
4649           if (!done) _ckvmssts(sys$clref(pipe_ef));
4650           _ckvmssts(sys$setast(1));
4651           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4652       }
4653
4654       if (statusp) *statusp = info->completion;
4655       return pid;
4656     }
4657
4658     /* child that already terminated? */
4659
4660     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4661         if (closed_list[j].pid == pid) {
4662             if (statusp) *statusp = closed_list[j].completion;
4663             return pid;
4664         }
4665     }
4666
4667     /* fall through if this child is not one of our own pipe children */
4668
4669 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4670
4671       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4672        * in 7.2 did we get a version that fills in the VMS completion
4673        * status as Perl has always tried to do.
4674        */
4675
4676       sts = __vms_waitpid( pid, statusp, flags );
4677
4678       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4679          return sts;
4680
4681       /* If the real waitpid tells us the child does not exist, we
4682        * fall through here to implement waiting for a child that
4683        * was created by some means other than exec() (say, spawned
4684        * from DCL) or to wait for a process that is not a subprocess
4685        * of the current process.
4686        */
4687
4688 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4689
4690     {
4691       $DESCRIPTOR(intdsc,"0 00:00:01");
4692       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4693       unsigned long int pidcode = JPI$_PID, mypid;
4694       unsigned long int interval[2];
4695       unsigned int jpi_iosb[2];
4696       struct itmlst_3 jpilist[2] = {
4697           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4698           {                      0,         0,                 0, 0}
4699       };
4700
4701       if (pid <= 0) {
4702         /* Sorry folks, we don't presently implement rooting around for
4703            the first child we can find, and we definitely don't want to
4704            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4705          */
4706         set_errno(ENOTSUP);
4707         return -1;
4708       }
4709
4710       /* Get the owner of the child so I can warn if it's not mine. If the
4711        * process doesn't exist or I don't have the privs to look at it,
4712        * I can go home early.
4713        */
4714       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4715       if (sts & 1) sts = jpi_iosb[0];
4716       if (!(sts & 1)) {
4717         switch (sts) {
4718             case SS$_NONEXPR:
4719                 set_errno(ECHILD);
4720                 break;
4721             case SS$_NOPRIV:
4722                 set_errno(EACCES);
4723                 break;
4724             default:
4725                 _ckvmssts(sts);
4726         }
4727         set_vaxc_errno(sts);
4728         return -1;
4729       }
4730
4731       if (ckWARN(WARN_EXEC)) {
4732         /* remind folks they are asking for non-standard waitpid behavior */
4733         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4734         if (ownerpid != mypid)
4735           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4736                       "waitpid: process %x is not a child of process %x",
4737                       pid,mypid);
4738       }
4739
4740       /* simply check on it once a second until it's not there anymore. */
4741
4742       _ckvmssts(sys$bintim(&intdsc,interval));
4743       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4744             _ckvmssts(sys$schdwk(0,0,interval,0));
4745             _ckvmssts(sys$hiber());
4746       }
4747       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4748
4749       _ckvmssts(sts);
4750       return pid;
4751     }
4752 }  /* end of waitpid() */
4753 /*}}}*/
4754 /*}}}*/
4755 /*}}}*/
4756
4757 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4758 char *
4759 my_gconvert(double val, int ndig, int trail, char *buf)
4760 {
4761   static char __gcvtbuf[DBL_DIG+1];
4762   char *loc;
4763
4764   loc = buf ? buf : __gcvtbuf;
4765
4766 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4767   if (val < 1) {
4768     sprintf(loc,"%.*g",ndig,val);
4769     return loc;
4770   }
4771 #endif
4772
4773   if (val) {
4774     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4775     return gcvt(val,ndig,loc);
4776   }
4777   else {
4778     loc[0] = '0'; loc[1] = '\0';
4779     return loc;
4780   }
4781
4782 }
4783 /*}}}*/
4784
4785 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4786 static int rms_free_search_context(struct FAB * fab)
4787 {
4788 struct NAM * nam;
4789
4790     nam = fab->fab$l_nam;
4791     nam->nam$b_nop |= NAM$M_SYNCHK;
4792     nam->nam$l_rlf = NULL;
4793     fab->fab$b_dns = 0;
4794     return sys$parse(fab, NULL, NULL);
4795 }
4796
4797 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4798 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4799 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4800 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4801 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4802 #define rms_nam_esll(nam) nam.nam$b_esl
4803 #define rms_nam_esl(nam) nam.nam$b_esl
4804 #define rms_nam_name(nam) nam.nam$l_name
4805 #define rms_nam_namel(nam) nam.nam$l_name
4806 #define rms_nam_type(nam) nam.nam$l_type
4807 #define rms_nam_typel(nam) nam.nam$l_type
4808 #define rms_nam_ver(nam) nam.nam$l_ver
4809 #define rms_nam_verl(nam) nam.nam$l_ver
4810 #define rms_nam_rsll(nam) nam.nam$b_rsl
4811 #define rms_nam_rsl(nam) nam.nam$b_rsl
4812 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4813 #define rms_set_fna(fab, nam, name, size) \
4814         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4815 #define rms_get_fna(fab, nam) fab.fab$l_fna
4816 #define rms_set_dna(fab, nam, name, size) \
4817         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4818 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4819 #define rms_set_esa(nam, name, size) \
4820         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4821 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4822         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4823 #define rms_set_rsa(nam, name, size) \
4824         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4825 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4826         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4827 #define rms_nam_name_type_l_size(nam) \
4828         (nam.nam$b_name + nam.nam$b_type)
4829 #else
4830 static int rms_free_search_context(struct FAB * fab)
4831 {
4832 struct NAML * nam;
4833
4834     nam = fab->fab$l_naml;
4835     nam->naml$b_nop |= NAM$M_SYNCHK;
4836     nam->naml$l_rlf = NULL;
4837     nam->naml$l_long_defname_size = 0;
4838
4839     fab->fab$b_dns = 0;
4840     return sys$parse(fab, NULL, NULL);
4841 }
4842
4843 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4844 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4845 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4846 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4847 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4848 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4849 #define rms_nam_esl(nam) nam.naml$b_esl
4850 #define rms_nam_name(nam) nam.naml$l_name
4851 #define rms_nam_namel(nam) nam.naml$l_long_name
4852 #define rms_nam_type(nam) nam.naml$l_type
4853 #define rms_nam_typel(nam) nam.naml$l_long_type
4854 #define rms_nam_ver(nam) nam.naml$l_ver
4855 #define rms_nam_verl(nam) nam.naml$l_long_ver
4856 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4857 #define rms_nam_rsl(nam) nam.naml$b_rsl
4858 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4859 #define rms_set_fna(fab, nam, name, size) \
4860         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4861         nam.naml$l_long_filename_size = size; \
4862         nam.naml$l_long_filename = name;}
4863 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4864 #define rms_set_dna(fab, nam, name, size) \
4865         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4866         nam.naml$l_long_defname_size = size; \
4867         nam.naml$l_long_defname = name; }
4868 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4869 #define rms_set_esa(nam, name, size) \
4870         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4871         nam.naml$l_long_expand_alloc = size; \
4872         nam.naml$l_long_expand = name; }
4873 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4874         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4875         nam.naml$l_long_expand = l_name; \
4876         nam.naml$l_long_expand_alloc = l_size; }
4877 #define rms_set_rsa(nam, name, size) \
4878         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4879         nam.naml$l_long_result = name; \
4880         nam.naml$l_long_result_alloc = size; }
4881 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4882         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4883         nam.naml$l_long_result = l_name; \
4884         nam.naml$l_long_result_alloc = l_size; }
4885 #define rms_nam_name_type_l_size(nam) \
4886         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4887 #endif
4888
4889
4890 /* rms_erase
4891  * The CRTL for 8.3 and later can create symbolic links in any mode,
4892  * however in 8.3 the unlink/remove/delete routines will only properly handle
4893  * them if one of the PCP modes is active.
4894  */
4895 static int rms_erase(const char * vmsname)
4896 {
4897   int status;
4898   struct FAB myfab = cc$rms_fab;
4899   rms_setup_nam(mynam);
4900
4901   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4902   rms_bind_fab_nam(myfab, mynam);
4903
4904 #ifdef NAML$M_OPEN_SPECIAL
4905   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4906 #endif
4907
4908   status = sys$erase(&myfab, 0, 0);
4909
4910   return status;
4911 }
4912
4913
4914 static int
4915 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4916                     const struct dsc$descriptor_s * vms_dst_dsc,
4917                     unsigned long flags)
4918 {
4919     /*  VMS and UNIX handle file permissions differently and the
4920      * the same ACL trick may be needed for renaming files,
4921      * especially if they are directories.
4922      */
4923
4924    /* todo: get kill_file and rename to share common code */
4925    /* I can not find online documentation for $change_acl
4926     * it appears to be replaced by $set_security some time ago */
4927
4928 const unsigned int access_mode = 0;
4929 $DESCRIPTOR(obj_file_dsc,"FILE");
4930 char *vmsname;
4931 char *rslt;
4932 unsigned long int jpicode = JPI$_UIC;
4933 int aclsts, fndsts, rnsts = -1;
4934 unsigned int ctx = 0;
4935 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4936 struct dsc$descriptor_s * clean_dsc;
4937
4938 struct myacedef {
4939     unsigned char myace$b_length;
4940     unsigned char myace$b_type;
4941     unsigned short int myace$w_flags;
4942     unsigned long int myace$l_access;
4943     unsigned long int myace$l_ident;
4944 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4945              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4946              0},
4947              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4948
4949 struct item_list_3
4950         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4951                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4952                       {0,0,0,0}},
4953         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4954         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4955                      {0,0,0,0}};
4956
4957
4958     /* Expand the input spec using RMS, since we do not want to put
4959      * ACLs on the target of a symbolic link */
4960     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4961     if (vmsname == NULL)
4962         return SS$_INSFMEM;
4963
4964     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4965                         vmsname,
4966                         PERL_RMSEXPAND_M_SYMLINK);
4967     if (rslt == NULL) {
4968         PerlMem_free(vmsname);
4969         return SS$_INSFMEM;
4970     }
4971
4972     /* So we get our own UIC to use as a rights identifier,
4973      * and the insert an ACE at the head of the ACL which allows us
4974      * to delete the file.
4975      */
4976     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4977
4978     fildsc.dsc$w_length = strlen(vmsname);
4979     fildsc.dsc$a_pointer = vmsname;
4980     ctx = 0;
4981     newace.myace$l_ident = oldace.myace$l_ident;
4982     rnsts = SS$_ABORT;
4983
4984     /* Grab any existing ACEs with this identifier in case we fail */
4985     clean_dsc = &fildsc;
4986     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4987                                &fildsc,
4988                                NULL,
4989                                OSS$M_WLOCK,
4990                                findlst,
4991                                &ctx,
4992                                &access_mode);
4993
4994     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4995         /* Add the new ACE . . . */
4996
4997         /* if the sys$get_security succeeded, then ctx is valid, and the
4998          * object/file descriptors will be ignored.  But otherwise they
4999          * are needed
5000          */
5001         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5002                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5003         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5004             set_errno(EVMSERR);
5005             set_vaxc_errno(aclsts);
5006             PerlMem_free(vmsname);
5007             return aclsts;
5008         }
5009
5010         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5011                                 NULL, NULL,
5012                                 &flags,
5013                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5014
5015         if ($VMS_STATUS_SUCCESS(rnsts)) {
5016             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5017         }
5018
5019         /* Put things back the way they were. */
5020         ctx = 0;
5021         aclsts = sys$get_security(&obj_file_dsc,
5022                                   clean_dsc,
5023                                   NULL,
5024                                   OSS$M_WLOCK,
5025                                   findlst,
5026                                   &ctx,
5027                                   &access_mode);
5028
5029         if ($VMS_STATUS_SUCCESS(aclsts)) {
5030         int sec_flags;
5031
5032             sec_flags = 0;
5033             if (!$VMS_STATUS_SUCCESS(fndsts))
5034                 sec_flags = OSS$M_RELCTX;
5035
5036             /* Get rid of the new ACE */
5037             aclsts = sys$set_security(NULL, NULL, NULL,
5038                                   sec_flags, dellst, &ctx, &access_mode);
5039
5040             /* If there was an old ACE, put it back */
5041             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5042                 addlst[0].bufadr = &oldace;
5043                 aclsts = sys$set_security(NULL, NULL, NULL,
5044                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5045                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5046                     set_errno(EVMSERR);
5047                     set_vaxc_errno(aclsts);
5048                     rnsts = aclsts;
5049                 }
5050             } else {
5051             int aclsts2;
5052
5053                 /* Try to clear the lock on the ACL list */
5054                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5055                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5056
5057                 /* Rename errors are most important */
5058                 if (!$VMS_STATUS_SUCCESS(rnsts))
5059                     aclsts = rnsts;
5060                 set_errno(EVMSERR);
5061                 set_vaxc_errno(aclsts);
5062                 rnsts = aclsts;
5063             }
5064         }
5065         else {
5066             if (aclsts != SS$_ACLEMPTY)
5067                 rnsts = aclsts;
5068         }
5069     }
5070     else
5071         rnsts = fndsts;
5072
5073     PerlMem_free(vmsname);
5074     return rnsts;
5075 }
5076
5077
5078 /*{{{int rename(const char *, const char * */
5079 /* Not exactly what X/Open says to do, but doing it absolutely right
5080  * and efficiently would require a lot more work.  This should be close
5081  * enough to pass all but the most strict X/Open compliance test.
5082  */
5083 int
5084 Perl_rename(pTHX_ const char *src, const char * dst)
5085 {
5086 int retval;
5087 int pre_delete = 0;
5088 int src_sts;
5089 int dst_sts;
5090 Stat_t src_st;
5091 Stat_t dst_st;
5092
5093     /* Validate the source file */
5094     src_sts = flex_lstat(src, &src_st);
5095     if (src_sts != 0) {
5096
5097         /* No source file or other problem */
5098         return src_sts;
5099     }
5100     if (src_st.st_devnam[0] == 0)  {
5101         /* This may be possible so fail if it is seen. */
5102         errno = EIO;
5103         return -1;
5104     }
5105
5106     dst_sts = flex_lstat(dst, &dst_st);
5107     if (dst_sts == 0) {
5108
5109         if (dst_st.st_dev != src_st.st_dev) {
5110             /* Must be on the same device */
5111             errno = EXDEV;
5112             return -1;
5113         }
5114
5115         /* VMS_INO_T_COMPARE is true if the inodes are different
5116          * to match the output of memcmp
5117          */
5118
5119         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5120             /* That was easy, the files are the same! */
5121             return 0;
5122         }
5123
5124         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5125             /* If source is a directory, so must be dest */
5126                 errno = EISDIR;
5127                 return -1;
5128         }
5129
5130     }
5131
5132
5133     if ((dst_sts == 0) &&
5134         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5135
5136         /* We have issues here if vms_unlink_all_versions is set
5137          * If the destination exists, and is not a directory, then
5138          * we must delete in advance.
5139          *
5140          * If the src is a directory, then we must always pre-delete
5141          * the destination.
5142          *
5143          * If we successfully delete the dst in advance, and the rename fails
5144          * X/Open requires that errno be EIO.
5145          *
5146          */
5147
5148         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5149             int d_sts;
5150             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5151                                      S_ISDIR(dst_st.st_mode));
5152
5153            /* Need to delete all versions ? */
5154            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5155                 int i = 0;
5156
5157                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5158                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5159                     if (d_sts != 0)
5160                         break;
5161                     i++;
5162
5163                     /* Make sure that we do not loop forever */
5164                     if (i > 32767) {
5165                         errno = EIO;
5166                         d_sts = -1;
5167                         break;
5168                     }
5169                 }
5170            }
5171
5172             if (d_sts != 0)
5173                 return d_sts;
5174
5175             /* We killed the destination, so only errno now is EIO */
5176             pre_delete = 1;
5177         }
5178     }
5179
5180     /* Originally the idea was to call the CRTL rename() and only
5181      * try the lib$rename_file if it failed.
5182      * It turns out that there are too many variants in what the
5183      * the CRTL rename might do, so only use lib$rename_file
5184      */
5185     retval = -1;
5186
5187     {
5188         /* Is the source and dest both in VMS format */
5189         /* if the source is a directory, then need to fileify */
5190         /*  and dest must be a directory or non-existent. */
5191
5192         char * vms_dst;
5193         int sts;
5194         char * ret_str;
5195         unsigned long flags;
5196         struct dsc$descriptor_s old_file_dsc;
5197         struct dsc$descriptor_s new_file_dsc;
5198
5199         /* We need to modify the src and dst depending
5200          * on if one or more of them are directories.
5201          */
5202
5203         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5204         if (vms_dst == NULL)
5205             _ckvmssts_noperl(SS$_INSFMEM);
5206
5207         if (S_ISDIR(src_st.st_mode)) {
5208         char * ret_str;
5209         char * vms_dir_file;
5210
5211             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5212             if (vms_dir_file == NULL)
5213                 _ckvmssts_noperl(SS$_INSFMEM);
5214
5215             /* If the dest is a directory, we must remove it */
5216             if (dst_sts == 0) {
5217                 int d_sts;
5218                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5219                 if (d_sts != 0) {
5220                     PerlMem_free(vms_dst);
5221                     errno = EIO;
5222                     return d_sts;
5223                 }
5224
5225                 pre_delete = 1;
5226             }
5227
5228            /* The dest must be a VMS file specification */
5229            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5230            if (ret_str == NULL) {
5231                 PerlMem_free(vms_dst);
5232                 errno = EIO;
5233                 return -1;
5234            }
5235
5236             /* The source must be a file specification */
5237             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5238             if (ret_str == NULL) {
5239                 PerlMem_free(vms_dst);
5240                 PerlMem_free(vms_dir_file);
5241                 errno = EIO;
5242                 return -1;
5243             }
5244             PerlMem_free(vms_dst);
5245             vms_dst = vms_dir_file;
5246
5247         } else {
5248             /* File to file or file to new dir */
5249
5250             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5251                 /* VMS pathify a dir target */
5252                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5253                 if (ret_str == NULL) {
5254                     PerlMem_free(vms_dst);
5255                     errno = EIO;
5256                     return -1;
5257                 }
5258             } else {
5259                 char * v_spec, * r_spec, * d_spec, * n_spec;
5260                 char * e_spec, * vs_spec;
5261                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5262
5263                 /* fileify a target VMS file specification */
5264                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5265                 if (ret_str == NULL) {
5266                     PerlMem_free(vms_dst);
5267                     errno = EIO;
5268                     return -1;
5269                 }
5270
5271                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5272                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5273                              &e_len, &vs_spec, &vs_len);
5274                 if (sts == 0) {
5275                      if (e_len == 0) {
5276                          /* Get rid of the version */
5277                          if (vs_len != 0) {
5278                              *vs_spec = '\0';
5279                          }
5280                          /* Need to specify a '.' so that the extension */
5281                          /* is not inherited */
5282                          strcat(vms_dst,".");
5283                      }
5284                 }
5285             }
5286         }
5287
5288         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5289         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5290         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5291         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5292
5293         new_file_dsc.dsc$a_pointer = vms_dst;
5294         new_file_dsc.dsc$w_length = strlen(vms_dst);
5295         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5296         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5297
5298         flags = 0;
5299 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5300         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5301 #endif
5302
5303         sts = lib$rename_file(&old_file_dsc,
5304                               &new_file_dsc,
5305                               NULL, NULL,
5306                               &flags,
5307                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5308         if (!$VMS_STATUS_SUCCESS(sts)) {
5309
5310            /* We could have failed because VMS style permissions do not
5311             * permit renames that UNIX will allow.  Just like the hack
5312             * in for kill_file.
5313             */
5314            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5315         }
5316
5317         PerlMem_free(vms_dst);
5318         if (!$VMS_STATUS_SUCCESS(sts)) {
5319             errno = EIO;
5320             return -1;
5321         }
5322         retval = 0;
5323     }
5324
5325     if (vms_unlink_all_versions) {
5326         /* Now get rid of any previous versions of the source file that
5327          * might still exist
5328          */
5329         int i = 0;
5330         dSAVEDERRNO;
5331         SAVE_ERRNO;
5332         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5333                                    S_ISDIR(src_st.st_mode));
5334         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5335              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5336                                        S_ISDIR(src_st.st_mode));
5337              if (src_sts != 0)
5338                  break;
5339              i++;
5340
5341              /* Make sure that we do not loop forever */
5342              if (i > 32767) {
5343                  src_sts = -1;
5344                  break;
5345              }
5346         }
5347         RESTORE_ERRNO;
5348     }
5349
5350     /* We deleted the destination, so must force the error to be EIO */
5351     if ((retval != 0) && (pre_delete != 0))
5352         errno = EIO;
5353
5354     return retval;
5355 }
5356 /*}}}*/
5357
5358
5359 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5360 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5361  * to expand file specification.  Allows for a single default file
5362  * specification and a simple mask of options.  If outbuf is non-NULL,
5363  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5364  * the resultant file specification is placed.  If outbuf is NULL, the
5365  * resultant file specification is placed into a static buffer.
5366  * The third argument, if non-NULL, is taken to be a default file
5367  * specification string.  The fourth argument is unused at present.
5368  * rmesexpand() returns the address of the resultant string if
5369  * successful, and NULL on error.
5370  *
5371  * New functionality for previously unused opts value:
5372  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5373  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5374  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5375  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5376  */
5377 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5378
5379 static char *
5380 int_rmsexpand
5381    (const char *filespec,
5382     char *outbuf,
5383     const char *defspec,
5384     unsigned opts,
5385     int * fs_utf8,
5386     int * dfs_utf8)
5387 {
5388   char * ret_spec;
5389   const char * in_spec;
5390   char * spec_buf;
5391   const char * def_spec;
5392   char * vmsfspec, *vmsdefspec;
5393   char * esa;
5394   char * esal = NULL;
5395   char * outbufl;
5396   struct FAB myfab = cc$rms_fab;
5397   rms_setup_nam(mynam);
5398   STRLEN speclen;
5399   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5400   int sts;
5401
5402   /* temp hack until UTF8 is actually implemented */
5403   if (fs_utf8 != NULL)
5404     *fs_utf8 = 0;
5405
5406   if (!filespec || !*filespec) {
5407     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5408     return NULL;
5409   }
5410
5411   vmsfspec = NULL;
5412   vmsdefspec = NULL;
5413   outbufl = NULL;
5414
5415   in_spec = filespec;
5416   isunix = 0;
5417   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5418       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5419       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5420
5421       /* If this is a UNIX file spec, convert it to VMS */
5422       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5423                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5424                            &e_len, &vs_spec, &vs_len);
5425       if (sts != 0) {
5426           isunix = 1;
5427           char * ret_spec;
5428
5429           vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5430           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5431           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5432           if (ret_spec == NULL) {
5433               PerlMem_free(vmsfspec);
5434               return NULL;
5435           }
5436           in_spec = (const char *)vmsfspec;
5437
5438           /* Unless we are forcing to VMS format, a UNIX input means
5439            * UNIX output, and that requires long names to be used
5440            */
5441           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5442 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5443               opts |= PERL_RMSEXPAND_M_LONG;
5444 #else
5445               NOOP;
5446 #endif
5447           else
5448               isunix = 0;
5449       }
5450
5451   }
5452
5453   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5454   rms_bind_fab_nam(myfab, mynam);
5455
5456   /* Process the default file specification if present */
5457   def_spec = defspec;
5458   if (defspec && *defspec) {
5459     int t_isunix;
5460     t_isunix = is_unix_filespec(defspec);
5461     if (t_isunix) {
5462       vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5463       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5464       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5465
5466       if (ret_spec == NULL) {
5467           /* Clean up and bail */
5468           PerlMem_free(vmsdefspec);
5469           if (vmsfspec != NULL)
5470               PerlMem_free(vmsfspec);
5471               return NULL;
5472           }
5473           def_spec = (const char *)vmsdefspec;
5474       }
5475       rms_set_dna(myfab, mynam,
5476                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5477   }
5478
5479   /* Now we need the expansion buffers */
5480   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5481   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5482 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5483   esal = PerlMem_malloc(VMS_MAXRSS);
5484   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5485 #endif
5486   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5487
5488   /* If a NAML block is used RMS always writes to the long and short
5489    * addresses unless you suppress the short name.
5490    */
5491 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5492   outbufl = PerlMem_malloc(VMS_MAXRSS);
5493   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5494 #endif
5495    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5496
5497 #ifdef NAM$M_NO_SHORT_UPCASE
5498   if (decc_efs_case_preserve)
5499     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5500 #endif
5501
5502    /* We may not want to follow symbolic links */
5503 #ifdef NAML$M_OPEN_SPECIAL
5504   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5505     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5506 #endif
5507
5508   /* First attempt to parse as an existing file */
5509   retsts = sys$parse(&myfab,0,0);
5510   if (!(retsts & STS$K_SUCCESS)) {
5511
5512     /* Could not find the file, try as syntax only if error is not fatal */
5513     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5514     if (retsts == RMS$_DNF ||
5515         retsts == RMS$_DIR ||
5516         retsts == RMS$_DEV ||
5517         retsts == RMS$_PRV) {
5518       retsts = sys$parse(&myfab,0,0);
5519       if (retsts & STS$K_SUCCESS) goto int_expanded;
5520     }
5521
5522      /* Still could not parse the file specification */
5523     /*----------------------------------------------*/
5524     sts = rms_free_search_context(&myfab); /* Free search context */
5525     if (vmsdefspec != NULL)
5526         PerlMem_free(vmsdefspec);
5527     if (vmsfspec != NULL)
5528         PerlMem_free(vmsfspec);
5529     if (outbufl != NULL)
5530         PerlMem_free(outbufl);
5531     PerlMem_free(esa);
5532     if (esal != NULL)
5533         PerlMem_free(esal);
5534     set_vaxc_errno(retsts);
5535     if      (retsts == RMS$_PRV) set_errno(EACCES);
5536     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5537     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5538     else                         set_errno(EVMSERR);
5539     return NULL;
5540   }
5541   retsts = sys$search(&myfab,0,0);
5542   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5543     sts = rms_free_search_context(&myfab); /* Free search context */
5544     if (vmsdefspec != NULL)
5545         PerlMem_free(vmsdefspec);
5546     if (vmsfspec != NULL)
5547         PerlMem_free(vmsfspec);
5548     if (outbufl != NULL)
5549         PerlMem_free(outbufl);
5550     PerlMem_free(esa);
5551     if (esal != NULL)
5552         PerlMem_free(esal);
5553     set_vaxc_errno(retsts);
5554     if      (retsts == RMS$_PRV) set_errno(EACCES);
5555     else                         set_errno(EVMSERR);
5556     return NULL;
5557   }
5558
5559   /* If the input filespec contained any lowercase characters,
5560    * downcase the result for compatibility with Unix-minded code. */
5561 int_expanded:
5562   if (!decc_efs_case_preserve) {
5563     char * tbuf;
5564     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5565       if (islower(*tbuf)) { haslower = 1; break; }
5566   }
5567
5568    /* Is a long or a short name expected */
5569   /*------------------------------------*/
5570   spec_buf = NULL;
5571 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5572   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5573     if (rms_nam_rsll(mynam)) {
5574         spec_buf = outbufl;
5575         speclen = rms_nam_rsll(mynam);
5576     }
5577     else {
5578         spec_buf = esal; /* Not esa */
5579         speclen = rms_nam_esll(mynam);
5580     }
5581   }
5582   else {
5583 #endif
5584     if (rms_nam_rsl(mynam)) {
5585         spec_buf = outbuf;
5586         speclen = rms_nam_rsl(mynam);
5587     }
5588     else {
5589         spec_buf = esa; /* Not esal */
5590         speclen = rms_nam_esl(mynam);
5591     }
5592 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5593   }
5594 #endif
5595   spec_buf[speclen] = '\0';
5596
5597   /* Trim off null fields added by $PARSE
5598    * If type > 1 char, must have been specified in original or default spec
5599    * (not true for version; $SEARCH may have added version of existing file).
5600    */
5601   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5602   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5603     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5604              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5605   }
5606   else {
5607     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5608              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5609   }
5610   if (trimver || trimtype) {
5611     if (defspec && *defspec) {
5612       char *defesal = NULL;
5613       char *defesa = NULL;
5614       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5615       if (defesa != NULL) {
5616         struct FAB deffab = cc$rms_fab;
5617 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5618         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5619         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5620 #endif
5621         rms_setup_nam(defnam);
5622
5623         rms_bind_fab_nam(deffab, defnam);
5624
5625         /* Cast ok */
5626         rms_set_fna
5627             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5628
5629         /* RMS needs the esa/esal as a work area if wildcards are involved */
5630         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5631
5632         rms_clear_nam_nop(defnam);
5633         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5634 #ifdef NAM$M_NO_SHORT_UPCASE
5635         if (decc_efs_case_preserve)
5636           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5637 #endif
5638 #ifdef NAML$M_OPEN_SPECIAL
5639         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5640           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5641 #endif
5642         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5643           if (trimver) {
5644              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5645           }
5646           if (trimtype) {
5647             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5648           }
5649         }
5650         if (defesal != NULL)
5651             PerlMem_free(defesal);
5652         PerlMem_free(defesa);
5653       } else {
5654           _ckvmssts_noperl(SS$_INSFMEM);
5655       }
5656     }
5657     if (trimver) {
5658       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5659         if (*(rms_nam_verl(mynam)) != '\"')
5660           speclen = rms_nam_verl(mynam) - spec_buf;
5661       }
5662       else {
5663         if (*(rms_nam_ver(mynam)) != '\"')
5664           speclen = rms_nam_ver(mynam) - spec_buf;
5665       }
5666     }
5667     if (trimtype) {
5668       /* If we didn't already trim version, copy down */
5669       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5670         if (speclen > rms_nam_verl(mynam) - spec_buf)
5671           memmove
5672            (rms_nam_typel(mynam),
5673             rms_nam_verl(mynam),
5674             speclen - (rms_nam_verl(mynam) - spec_buf));
5675           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5676       }
5677       else {
5678         if (speclen > rms_nam_ver(mynam) - spec_buf)
5679           memmove
5680            (rms_nam_type(mynam),
5681             rms_nam_ver(mynam),
5682             speclen - (rms_nam_ver(mynam) - spec_buf));
5683           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5684       }
5685     }
5686   }
5687
5688    /* Done with these copies of the input files */
5689   /*-------------------------------------------*/
5690   if (vmsfspec != NULL)
5691         PerlMem_free(vmsfspec);
5692   if (vmsdefspec != NULL)
5693         PerlMem_free(vmsdefspec);
5694
5695   /* If we just had a directory spec on input, $PARSE "helpfully"
5696    * adds an empty name and type for us */
5697 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5698   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5699     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5700         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5701         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5702       speclen = rms_nam_namel(mynam) - spec_buf;
5703   }
5704   else
5705 #endif
5706   {
5707     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5708         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5709         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5710       speclen = rms_nam_name(mynam) - spec_buf;
5711   }
5712
5713   /* Posix format specifications must have matching quotes */
5714   if (speclen < (VMS_MAXRSS - 1)) {
5715     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5716       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5717         spec_buf[speclen] = '\"';
5718         speclen++;
5719       }
5720     }
5721   }
5722   spec_buf[speclen] = '\0';
5723   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5724
5725   /* Have we been working with an expanded, but not resultant, spec? */
5726   /* Also, convert back to Unix syntax if necessary. */
5727   {
5728   int rsl;
5729
5730 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5731     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5732       rsl = rms_nam_rsll(mynam);
5733     } else
5734 #endif
5735     {
5736       rsl = rms_nam_rsl(mynam);
5737     }
5738     if (!rsl) {
5739       /* rsl is not present, it means that spec_buf is either */
5740       /* esa or esal, and needs to be copied to outbuf */
5741       /* convert to Unix if desired */
5742       if (isunix) {
5743         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5744       } else {
5745         /* VMS file specs are not in UTF-8 */
5746         if (fs_utf8 != NULL)
5747             *fs_utf8 = 0;
5748         my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5749         ret_spec = outbuf;
5750       }
5751     }
5752     else {
5753       /* Now spec_buf is either outbuf or outbufl */
5754       /* We need the result into outbuf */
5755       if (isunix) {
5756            /* If we need this in UNIX, then we need another buffer */
5757            /* to keep things in order */
5758            char * src;
5759            char * new_src = NULL;
5760            if (spec_buf == outbuf) {
5761                new_src = PerlMem_malloc(VMS_MAXRSS);
5762                my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5763            } else {
5764                src = spec_buf;
5765            }
5766            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5767            if (new_src) {
5768                PerlMem_free(new_src);
5769            }
5770       } else {
5771            /* VMS file specs are not in UTF-8 */
5772            if (fs_utf8 != NULL)
5773                *fs_utf8 = 0;
5774
5775            /* Copy the buffer if needed */
5776            if (outbuf != spec_buf)
5777                my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5778            ret_spec = outbuf;
5779       }
5780     }
5781   }
5782
5783   /* Need to clean up the search context */
5784   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5785   sts = rms_free_search_context(&myfab); /* Free search context */
5786
5787   /* Clean up the extra buffers */
5788   if (esal != NULL)
5789       PerlMem_free(esal);
5790   PerlMem_free(esa);
5791   if (outbufl != NULL)
5792      PerlMem_free(outbufl);
5793
5794   /* Return the result */
5795   return ret_spec;
5796 }
5797
5798 /* Common simple case - Expand an already VMS spec */
5799 static char *
5800 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5801     opts |= PERL_RMSEXPAND_M_VMS_IN;
5802     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5803 }
5804
5805 /* Common simple case - Expand to a VMS spec */
5806 static char *
5807 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5808     opts |= PERL_RMSEXPAND_M_VMS;
5809     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5810 }
5811
5812
5813 /* Entry point used by perl routines */
5814 static char *
5815 mp_do_rmsexpand
5816    (pTHX_ const char *filespec,
5817     char *outbuf,
5818     int ts,
5819     const char *defspec,
5820     unsigned opts,
5821     int * fs_utf8,
5822     int * dfs_utf8)
5823 {
5824     static char __rmsexpand_retbuf[VMS_MAXRSS];
5825     char * expanded, *ret_spec, *ret_buf;
5826
5827     expanded = NULL;
5828     ret_buf = outbuf;
5829     if (ret_buf == NULL) {
5830         if (ts) {
5831             Newx(expanded, VMS_MAXRSS, char);
5832             if (expanded == NULL)
5833                 _ckvmssts(SS$_INSFMEM);
5834             ret_buf = expanded;
5835         } else {
5836             ret_buf = __rmsexpand_retbuf;
5837         }
5838     }
5839
5840
5841     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5842                              opts, fs_utf8,  dfs_utf8);
5843
5844     if (ret_spec == NULL) {
5845        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5846        if (expanded)
5847            Safefree(expanded);
5848     }
5849
5850     return ret_spec;
5851 }
5852 /*}}}*/
5853 /* External entry points */
5854 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5855 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5856 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5857 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5858 char *Perl_rmsexpand_utf8
5859   (pTHX_ const char *spec, char *buf, const char *def,
5860    unsigned opt, int * fs_utf8, int * dfs_utf8)
5861 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5862 char *Perl_rmsexpand_utf8_ts
5863   (pTHX_ const char *spec, char *buf, const char *def,
5864    unsigned opt, int * fs_utf8, int * dfs_utf8)
5865 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5866
5867
5868 /*
5869 ** The following routines are provided to make life easier when
5870 ** converting among VMS-style and Unix-style directory specifications.
5871 ** All will take input specifications in either VMS or Unix syntax. On
5872 ** failure, all return NULL.  If successful, the routines listed below
5873 ** return a pointer to a buffer containing the appropriately
5874 ** reformatted spec (and, therefore, subsequent calls to that routine
5875 ** will clobber the result), while the routines of the same names with
5876 ** a _ts suffix appended will return a pointer to a mallocd string
5877 ** containing the appropriately reformatted spec.
5878 ** In all cases, only explicit syntax is altered; no check is made that
5879 ** the resulting string is valid or that the directory in question
5880 ** actually exists.
5881 **
5882 **   fileify_dirspec() - convert a directory spec into the name of the
5883 **     directory file (i.e. what you can stat() to see if it's a dir).
5884 **     The style (VMS or Unix) of the result is the same as the style
5885 **     of the parameter passed in.
5886 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5887 **     what you prepend to a filename to indicate what directory it's in).
5888 **     The style (VMS or Unix) of the result is the same as the style
5889 **     of the parameter passed in.
5890 **   tounixpath() - convert a directory spec into a Unix-style path.
5891 **   tovmspath() - convert a directory spec into a VMS-style path.
5892 **   tounixspec() - convert any file spec into a Unix-style file spec.
5893 **   tovmsspec() - convert any file spec into a VMS-style spec.
5894 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5895 **
5896 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5897 ** Permission is given to distribute this code as part of the Perl
5898 ** standard distribution under the terms of the GNU General Public
5899 ** License or the Perl Artistic License.  Copies of each may be
5900 ** found in the Perl standard distribution.
5901  */
5902
5903 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5904 static char *
5905 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5906 {
5907     unsigned long int dirlen, retlen, hasfilename = 0;
5908     char *cp1, *cp2, *lastdir;
5909     char *trndir, *vmsdir;
5910     unsigned short int trnlnm_iter_count;
5911     int sts;
5912     if (utf8_fl != NULL)
5913         *utf8_fl = 0;
5914
5915     if (!dir || !*dir) {
5916       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5917     }
5918     dirlen = strlen(dir);
5919     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5920     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5921       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5922         dir = "/sys$disk";
5923         dirlen = 9;
5924       }
5925       else
5926         dirlen = 1;
5927     }
5928     if (dirlen > (VMS_MAXRSS - 1)) {
5929       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5930       return NULL;
5931     }
5932     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5933     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5934     if (!strpbrk(dir+1,"/]>:")  &&
5935         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5936       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5937       trnlnm_iter_count = 0;
5938       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
5939         trnlnm_iter_count++;
5940         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5941       }
5942       dirlen = strlen(trndir);
5943     }
5944     else {
5945       memcpy(trndir, dir, dirlen);
5946       trndir[dirlen] = '\0';
5947     }
5948
5949     /* At this point we are done with *dir and use *trndir which is a
5950      * copy that can be modified.  *dir must not be modified.
5951      */
5952
5953     /* If we were handed a rooted logical name or spec, treat it like a
5954      * simple directory, so that
5955      *    $ Define myroot dev:[dir.]
5956      *    ... do_fileify_dirspec("myroot",buf,1) ...
5957      * does something useful.
5958      */
5959     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5960       trndir[--dirlen] = '\0';
5961       trndir[dirlen-1] = ']';
5962     }
5963     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5964       trndir[--dirlen] = '\0';
5965       trndir[dirlen-1] = '>';
5966     }
5967
5968     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5969       /* If we've got an explicit filename, we can just shuffle the string. */
5970       if (*(cp1+1)) hasfilename = 1;
5971       /* Similarly, we can just back up a level if we've got multiple levels
5972          of explicit directories in a VMS spec which ends with directories. */
5973       else {
5974         for (cp2 = cp1; cp2 > trndir; cp2--) {
5975           if (*cp2 == '.') {
5976             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5977 /* fix-me, can not scan EFS file specs backward like this */
5978               *cp2 = *cp1; *cp1 = '\0';
5979               hasfilename = 1;
5980               break;
5981             }
5982           }
5983           if (*cp2 == '[' || *cp2 == '<') break;
5984         }
5985       }
5986     }
5987
5988     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5989     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5990     cp1 = strpbrk(trndir,"]:>");
5991     if (hasfilename || !cp1) { /* filename present or not VMS */
5992
5993       if (trndir[0] == '.') {
5994         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5995           PerlMem_free(trndir);
5996           PerlMem_free(vmsdir);
5997           return int_fileify_dirspec("[]", buf, NULL);
5998         }
5999         else if (trndir[1] == '.' &&
6000                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6001           PerlMem_free(trndir);
6002           PerlMem_free(vmsdir);
6003           return int_fileify_dirspec("[-]", buf, NULL);
6004         }
6005       }
6006       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6007         dirlen -= 1;                 /* to last element */
6008         lastdir = strrchr(trndir,'/');
6009       }
6010       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6011         /* If we have "/." or "/..", VMSify it and let the VMS code
6012          * below expand it, rather than repeating the code to handle
6013          * relative components of a filespec here */
6014         do {
6015           if (*(cp1+2) == '.') cp1++;
6016           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6017             char * ret_chr;
6018             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6019                 PerlMem_free(trndir);
6020                 PerlMem_free(vmsdir);
6021                 return NULL;
6022             }
6023             if (strchr(vmsdir,'/') != NULL) {
6024               /* If int_tovmsspec() returned it, it must have VMS syntax
6025                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6026                * the time to check this here only so we avoid a recursion
6027                * loop; otherwise, gigo.
6028                */
6029               PerlMem_free(trndir);
6030               PerlMem_free(vmsdir);
6031               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6032               return NULL;
6033             }
6034             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6035                 PerlMem_free(trndir);
6036                 PerlMem_free(vmsdir);
6037                 return NULL;
6038             }
6039             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6040             PerlMem_free(trndir);
6041             PerlMem_free(vmsdir);
6042             return ret_chr;
6043           }
6044           cp1++;
6045         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6046         lastdir = strrchr(trndir,'/');
6047       }
6048       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6049         char * ret_chr;
6050         /* Ditto for specs that end in an MFD -- let the VMS code
6051          * figure out whether it's a real device or a rooted logical. */
6052
6053         /* This should not happen any more.  Allowing the fake /000000
6054          * in a UNIX pathname causes all sorts of problems when trying
6055          * to run in UNIX emulation.  So the VMS to UNIX conversions
6056          * now remove the fake /000000 directories.
6057          */
6058
6059         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6060         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6061             PerlMem_free(trndir);
6062             PerlMem_free(vmsdir);
6063             return NULL;
6064         }
6065         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6066             PerlMem_free(trndir);
6067             PerlMem_free(vmsdir);
6068             return NULL;
6069         }
6070         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6071         PerlMem_free(trndir);
6072         PerlMem_free(vmsdir);
6073         return ret_chr;
6074       }
6075       else {
6076
6077         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6078              !(lastdir = cp1 = strrchr(trndir,']')) &&
6079              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6080
6081         cp2 = strrchr(cp1,'.');
6082         if (cp2) {
6083             int e_len, vs_len = 0;
6084             int is_dir = 0;
6085             char * cp3;
6086             cp3 = strchr(cp2,';');
6087             e_len = strlen(cp2);
6088             if (cp3) {
6089                 vs_len = strlen(cp3);
6090                 e_len = e_len - vs_len;
6091             }
6092             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6093             if (!is_dir) {
6094                 if (!decc_efs_charset) {
6095                     /* If this is not EFS, then not a directory */
6096                     PerlMem_free(trndir);
6097                     PerlMem_free(vmsdir);
6098                     set_errno(ENOTDIR);
6099                     set_vaxc_errno(RMS$_DIR);
6100                     return NULL;
6101                 }
6102             } else {
6103                 /* Ok, here we have an issue, technically if a .dir shows */
6104                 /* from inside a directory, then we should treat it as */
6105                 /* xxx^.dir.dir.  But we do not have that context at this */
6106                 /* point unless this is totally restructured, so we remove */
6107                 /* The .dir for now, and fix this better later */
6108                 dirlen = cp2 - trndir;
6109             }
6110             if (decc_efs_charset && !strchr(trndir,'/')) {
6111                 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6112                 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6113
6114                 for (; cp4 > cp1; cp4--) {
6115                     if (*cp4 == '.') {
6116                         if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6117                             memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6118                             *cp4 = '^';
6119                             dirlen++;
6120                         }
6121                     }
6122                 }
6123             }
6124         }
6125
6126       }
6127
6128       retlen = dirlen + 6;
6129       memcpy(buf, trndir, dirlen);
6130       buf[dirlen] = '\0';
6131
6132       /* We've picked up everything up to the directory file name.
6133          Now just add the type and version, and we're set. */
6134       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6135           strcat(buf,".dir;1");
6136       else
6137           strcat(buf,".DIR;1");
6138       PerlMem_free(trndir);
6139       PerlMem_free(vmsdir);
6140       return buf;
6141     }
6142     else {  /* VMS-style directory spec */
6143
6144       char *esa, *esal, term, *cp;
6145       char *my_esa;
6146       int my_esa_len;
6147       unsigned long int cmplen, haslower = 0;
6148       struct FAB dirfab = cc$rms_fab;
6149       rms_setup_nam(savnam);
6150       rms_setup_nam(dirnam);
6151
6152       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6153       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6154       esal = NULL;
6155 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6156       esal = PerlMem_malloc(VMS_MAXRSS);
6157       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6158 #endif
6159       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6160       rms_bind_fab_nam(dirfab, dirnam);
6161       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6162       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6163 #ifdef NAM$M_NO_SHORT_UPCASE
6164       if (decc_efs_case_preserve)
6165         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6166 #endif
6167
6168       for (cp = trndir; *cp; cp++)
6169         if (islower(*cp)) { haslower = 1; break; }
6170       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6171         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6172             (dirfab.fab$l_sts == RMS$_DNF) ||
6173             (dirfab.fab$l_sts == RMS$_PRV)) {
6174             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6175             sts = sys$parse(&dirfab);
6176         }
6177         if (!sts) {
6178           PerlMem_free(esa);
6179           if (esal != NULL)
6180               PerlMem_free(esal);
6181           PerlMem_free(trndir);
6182           PerlMem_free(vmsdir);
6183           set_errno(EVMSERR);
6184           set_vaxc_errno(dirfab.fab$l_sts);
6185           return NULL;
6186         }
6187       }
6188       else {
6189         savnam = dirnam;
6190         /* Does the file really exist? */
6191         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6192           /* Yes; fake the fnb bits so we'll check type below */
6193           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6194         }
6195         else { /* No; just work with potential name */
6196           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6197           else {
6198             int fab_sts;
6199             fab_sts = dirfab.fab$l_sts;
6200             sts = rms_free_search_context(&dirfab);
6201             PerlMem_free(esa);
6202             if (esal != NULL)
6203                 PerlMem_free(esal);
6204             PerlMem_free(trndir);
6205             PerlMem_free(vmsdir);
6206             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6207             return NULL;
6208           }
6209         }
6210       }
6211
6212       /* Make sure we are using the right buffer */
6213 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6214       if (esal != NULL) {
6215         my_esa = esal;
6216         my_esa_len = rms_nam_esll(dirnam);
6217       } else {
6218 #endif
6219         my_esa = esa;
6220         my_esa_len = rms_nam_esl(dirnam);
6221 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6222       }
6223 #endif
6224       my_esa[my_esa_len] = '\0';
6225       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6226         cp1 = strchr(my_esa,']');
6227         if (!cp1) cp1 = strchr(my_esa,'>');
6228         if (cp1) {  /* Should always be true */
6229           my_esa_len -= cp1 - my_esa - 1;
6230           memmove(my_esa, cp1 + 1, my_esa_len);
6231         }
6232       }
6233       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6234         /* Yep; check version while we're at it, if it's there. */
6235         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6236         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6237           /* Something other than .DIR[;1].  Bzzt. */
6238           sts = rms_free_search_context(&dirfab);
6239           PerlMem_free(esa);
6240           if (esal != NULL)
6241              PerlMem_free(esal);
6242           PerlMem_free(trndir);
6243           PerlMem_free(vmsdir);
6244           set_errno(ENOTDIR);
6245           set_vaxc_errno(RMS$_DIR);
6246           return NULL;
6247         }
6248       }
6249
6250       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6251         /* They provided at least the name; we added the type, if necessary, */
6252         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6253         sts = rms_free_search_context(&dirfab);
6254         PerlMem_free(trndir);
6255         PerlMem_free(esa);
6256         if (esal != NULL)
6257             PerlMem_free(esal);
6258         PerlMem_free(vmsdir);
6259         return buf;
6260       }
6261       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6262         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6263         *cp1 = '\0';
6264         my_esa_len -= 9;
6265       }
6266       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6267       if (cp1 == NULL) { /* should never happen */
6268         sts = rms_free_search_context(&dirfab);
6269         PerlMem_free(trndir);
6270         PerlMem_free(esa);
6271         if (esal != NULL)
6272             PerlMem_free(esal);
6273         PerlMem_free(vmsdir);
6274         return NULL;
6275       }
6276       term = *cp1;
6277       *cp1 = '\0';
6278       retlen = strlen(my_esa);
6279       cp1 = strrchr(my_esa,'.');
6280       /* ODS-5 directory specifications can have extra "." in them. */
6281       /* Fix-me, can not scan EFS file specifications backwards */
6282       while (cp1 != NULL) {
6283         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6284           break;
6285         else {
6286            cp1--;
6287            while ((cp1 > my_esa) && (*cp1 != '.'))
6288              cp1--;
6289         }
6290         if (cp1 == my_esa)
6291           cp1 = NULL;
6292       }
6293
6294       if ((cp1) != NULL) {
6295         /* There's more than one directory in the path.  Just roll back. */
6296         *cp1 = term;
6297         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6298       }
6299       else {
6300         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6301           /* Go back and expand rooted logical name */
6302           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6303 #ifdef NAM$M_NO_SHORT_UPCASE
6304           if (decc_efs_case_preserve)
6305             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6306 #endif
6307           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6308             sts = rms_free_search_context(&dirfab);
6309             PerlMem_free(esa);
6310             if (esal != NULL)
6311                 PerlMem_free(esal);
6312             PerlMem_free(trndir);
6313             PerlMem_free(vmsdir);
6314             set_errno(EVMSERR);
6315             set_vaxc_errno(dirfab.fab$l_sts);
6316             return NULL;
6317           }
6318
6319           /* This changes the length of the string of course */
6320           if (esal != NULL) {
6321               my_esa_len = rms_nam_esll(dirnam);
6322           } else {
6323               my_esa_len = rms_nam_esl(dirnam);
6324           }
6325
6326           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6327           cp1 = strstr(my_esa,"][");
6328           if (!cp1) cp1 = strstr(my_esa,"]<");
6329           dirlen = cp1 - my_esa;
6330           memcpy(buf, my_esa, dirlen);
6331           if (!strncmp(cp1+2,"000000]",7)) {
6332             buf[dirlen-1] = '\0';
6333             /* fix-me Not full ODS-5, just extra dots in directories for now */
6334             cp1 = buf + dirlen - 1;
6335             while (cp1 > buf)
6336             {
6337               if (*cp1 == '[')
6338                 break;
6339               if (*cp1 == '.') {
6340                 if (*(cp1-1) != '^')
6341                   break;
6342               }
6343               cp1--;
6344             }
6345             if (*cp1 == '.') *cp1 = ']';
6346             else {
6347               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6348               memmove(cp1+1,"000000]",7);
6349             }
6350           }
6351           else {
6352             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6353             buf[retlen] = '\0';
6354             /* Convert last '.' to ']' */
6355             cp1 = buf+retlen-1;
6356             while (*cp != '[') {
6357               cp1--;
6358               if (*cp1 == '.') {
6359                 /* Do not trip on extra dots in ODS-5 directories */
6360                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6361                 break;
6362               }
6363             }
6364             if (*cp1 == '.') *cp1 = ']';
6365             else {
6366               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6367               memmove(cp1+1,"000000]",7);
6368             }
6369           }
6370         }
6371         else {  /* This is a top-level dir.  Add the MFD to the path. */
6372           cp1 = my_esa;
6373           cp2 = buf;
6374           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6375           strcpy(cp2,":[000000]");
6376           cp1 += 2;
6377           strcpy(cp2+9,cp1);
6378         }
6379       }
6380       sts = rms_free_search_context(&dirfab);
6381       /* We've set up the string up through the filename.  Add the
6382          type and version, and we're done. */
6383       strcat(buf,".DIR;1");
6384
6385       /* $PARSE may have upcased filespec, so convert output to lower
6386        * case if input contained any lowercase characters. */
6387       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6388       PerlMem_free(trndir);
6389       PerlMem_free(esa);
6390       if (esal != NULL)
6391         PerlMem_free(esal);
6392       PerlMem_free(vmsdir);
6393       return buf;
6394     }
6395 }  /* end of int_fileify_dirspec() */
6396
6397
6398 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6399 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6400 {
6401     static char __fileify_retbuf[VMS_MAXRSS];
6402     char * fileified, *ret_spec, *ret_buf;
6403
6404     fileified = NULL;
6405     ret_buf = buf;
6406     if (ret_buf == NULL) {
6407         if (ts) {
6408             Newx(fileified, VMS_MAXRSS, char);
6409             if (fileified == NULL)
6410                 _ckvmssts(SS$_INSFMEM);
6411             ret_buf = fileified;
6412         } else {
6413             ret_buf = __fileify_retbuf;
6414         }
6415     }
6416
6417     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6418
6419     if (ret_spec == NULL) {
6420        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6421        if (fileified)
6422            Safefree(fileified);
6423     }
6424
6425     return ret_spec;
6426 }  /* end of do_fileify_dirspec() */
6427 /*}}}*/
6428
6429 /* External entry points */
6430 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6431 { return do_fileify_dirspec(dir,buf,0,NULL); }
6432 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6433 { return do_fileify_dirspec(dir,buf,1,NULL); }
6434 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6435 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6436 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6437 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6438
6439 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6440     char * v_spec, int v_len, char * r_spec, int r_len,
6441     char * d_spec, int d_len, char * n_spec, int n_len,
6442     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6443
6444     /* VMS specification - Try to do this the simple way */
6445     if ((v_len + r_len > 0) || (d_len > 0)) {
6446         int is_dir;
6447
6448         /* No name or extension component, already a directory */
6449         if ((n_len + e_len + vs_len) == 0) {
6450             strcpy(buf, dir);
6451             return buf;
6452         }
6453
6454         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6455         /* This results from catfile() being used instead of catdir() */
6456         /* So even though it should not work, we need to allow it */
6457
6458         /* If this is .DIR;1 then do a simple conversion */
6459         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6460         if (is_dir || (e_len == 0) && (d_len > 0)) {
6461              int len;
6462              len = v_len + r_len + d_len - 1;
6463              char dclose = d_spec[d_len - 1];
6464              memcpy(buf, dir, len);
6465              buf[len] = '.';
6466              len++;
6467              memcpy(&buf[len], n_spec, n_len);
6468              len += n_len;
6469              buf[len] = dclose;
6470              buf[len + 1] = '\0';
6471              return buf;
6472         }
6473
6474 #ifdef HAS_SYMLINK
6475         else if (d_len > 0) {
6476             /* In the olden days, a directory needed to have a .DIR */
6477             /* extension to be a valid directory, but now it could  */
6478             /* be a symbolic link */
6479             int len;
6480             len = v_len + r_len + d_len - 1;
6481             char dclose = d_spec[d_len - 1];
6482             memcpy(buf, dir, len);
6483             buf[len] = '.';
6484             len++;
6485             memcpy(&buf[len], n_spec, n_len);
6486             len += n_len;
6487             if (e_len > 0) {
6488                 if (decc_efs_charset) {
6489                     buf[len] = '^';
6490                     len++;
6491                     memcpy(&buf[len], e_spec, e_len);
6492                     len += e_len;
6493                 } else {
6494                     set_vaxc_errno(RMS$_DIR);
6495                     set_errno(ENOTDIR);
6496                     return NULL;
6497                 }
6498             }
6499             buf[len] = dclose;
6500             buf[len + 1] = '\0';
6501             return buf;
6502         }
6503 #else
6504         else {
6505             set_vaxc_errno(RMS$_DIR);
6506             set_errno(ENOTDIR);
6507             return NULL;
6508         }
6509 #endif
6510     }
6511     set_vaxc_errno(RMS$_DIR);
6512     set_errno(ENOTDIR);
6513     return NULL;
6514 }
6515
6516
6517 /* Internal routine to make sure or convert a directory to be in a */
6518 /* path specification.  No utf8 flag because it is not changed or used */
6519 static char *int_pathify_dirspec(const char *dir, char *buf)
6520 {
6521     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6522     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6523     char * exp_spec, *ret_spec;
6524     char * trndir;
6525     unsigned short int trnlnm_iter_count;
6526     STRLEN trnlen;
6527     int need_to_lower;
6528
6529     if (vms_debug_fileify) {
6530         if (dir == NULL)
6531             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6532         else
6533             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6534     }
6535
6536     /* We may need to lower case the result if we translated  */
6537     /* a logical name or got the current working directory */
6538     need_to_lower = 0;
6539
6540     if (!dir || !*dir) {
6541       set_errno(EINVAL);
6542       set_vaxc_errno(SS$_BADPARAM);
6543       return NULL;
6544     }
6545
6546     trndir = PerlMem_malloc(VMS_MAXRSS);
6547     if (trndir == NULL)
6548         _ckvmssts_noperl(SS$_INSFMEM);
6549
6550     /* If no directory specified use the current default */
6551     if (*dir)
6552         my_strlcpy(trndir, dir, VMS_MAXRSS);
6553     else {
6554         getcwd(trndir, VMS_MAXRSS - 1);
6555         need_to_lower = 1;
6556     }
6557
6558     /* now deal with bare names that could be logical names */
6559     trnlnm_iter_count = 0;
6560     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6561            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6562         trnlnm_iter_count++;
6563         need_to_lower = 1;
6564         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6565             break;
6566         trnlen = strlen(trndir);
6567
6568         /* Trap simple rooted lnms, and return lnm:[000000] */
6569         if (!strcmp(trndir+trnlen-2,".]")) {
6570             my_strlcpy(buf, dir, VMS_MAXRSS);
6571             strcat(buf, ":[000000]");
6572             PerlMem_free(trndir);
6573
6574             if (vms_debug_fileify) {
6575                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6576             }
6577             return buf;
6578         }
6579     }
6580
6581     /* At this point we do not work with *dir, but the copy in  *trndir */
6582
6583     if (need_to_lower && !decc_efs_case_preserve) {
6584         /* Legacy mode, lower case the returned value */
6585         __mystrtolower(trndir);
6586     }
6587
6588
6589     /* Some special cases, '..', '.' */
6590     sts = 0;
6591     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6592        /* Force UNIX filespec */
6593        sts = 1;
6594
6595     } else {
6596         /* Is this Unix or VMS format? */
6597         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6598                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6599                              &e_len, &vs_spec, &vs_len);
6600         if (sts == 0) {
6601
6602             /* Just a filename? */
6603             if ((v_len + r_len + d_len) == 0) {
6604
6605                 /* Now we have a problem, this could be Unix or VMS */
6606                 /* We have to guess.  .DIR usually means VMS */
6607
6608                 /* In UNIX report mode, the .DIR extension is removed */
6609                 /* if one shows up, it is for a non-directory or a directory */
6610                 /* in EFS charset mode */
6611
6612                 /* So if we are in Unix report mode, assume that this */
6613                 /* is a relative Unix directory specification */
6614
6615                 sts = 1;
6616                 if (!decc_filename_unix_report && decc_efs_charset) {
6617                     int is_dir;
6618                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6619
6620                     if (is_dir) {
6621                         /* Traditional mode, assume .DIR is directory */
6622                         buf[0] = '[';
6623                         buf[1] = '.';
6624                         memcpy(&buf[2], n_spec, n_len);
6625                         buf[n_len + 2] = ']';
6626                         buf[n_len + 3] = '\0';
6627                         PerlMem_free(trndir);
6628                         if (vms_debug_fileify) {
6629                             fprintf(stderr,
6630                                     "int_pathify_dirspec: buf = %s\n",
6631                                     buf);
6632                         }
6633                         return buf;
6634                     }
6635                 }
6636             }
6637         }
6638     }
6639     if (sts == 0) {
6640         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6641             v_spec, v_len, r_spec, r_len,
6642             d_spec, d_len, n_spec, n_len,
6643             e_spec, e_len, vs_spec, vs_len);
6644
6645         if (ret_spec != NULL) {
6646             PerlMem_free(trndir);
6647             if (vms_debug_fileify) {
6648                 fprintf(stderr,
6649                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6650             }
6651             return ret_spec;
6652         }
6653
6654         /* Simple way did not work, which means that a logical name */
6655         /* was present for the directory specification.             */
6656         /* Need to use an rmsexpand variant to decode it completely */
6657         exp_spec = PerlMem_malloc(VMS_MAXRSS);
6658         if (exp_spec == NULL)
6659             _ckvmssts_noperl(SS$_INSFMEM);
6660
6661         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6662         if (ret_spec != NULL) {
6663             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6664                                  &r_spec, &r_len, &d_spec, &d_len,
6665                                  &n_spec, &n_len, &e_spec,
6666                                  &e_len, &vs_spec, &vs_len);
6667             if (sts == 0) {
6668                 ret_spec = int_pathify_dirspec_simple(
6669                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6670                     d_spec, d_len, n_spec, n_len,
6671                     e_spec, e_len, vs_spec, vs_len);
6672
6673                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6674                     /* Legacy mode, lower case the returned value */
6675                     __mystrtolower(ret_spec);
6676                 }
6677             } else {
6678                 set_vaxc_errno(RMS$_DIR);
6679                 set_errno(ENOTDIR);
6680                 ret_spec = NULL;
6681             }
6682         }
6683         PerlMem_free(exp_spec);
6684         PerlMem_free(trndir);
6685         if (vms_debug_fileify) {
6686             if (ret_spec == NULL)
6687                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6688             else
6689                 fprintf(stderr,
6690                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6691         }
6692         return ret_spec;
6693
6694     } else {
6695         /* Unix specification, Could be trivial conversion, */
6696         /* but have to deal with trailing '.dir' or extra '.' */
6697
6698         char * lastdot;
6699         char * lastslash;
6700         int is_dir;
6701         STRLEN dir_len = strlen(trndir);
6702
6703         lastslash = strrchr(trndir, '/');
6704         if (lastslash == NULL)
6705             lastslash = trndir;
6706         else
6707             lastslash++;
6708
6709         lastdot = NULL;
6710
6711         /* '..' or '.' are valid directory components */
6712         is_dir = 0;
6713         if (lastslash[0] == '.') {
6714             if (lastslash[1] == '\0') {
6715                is_dir = 1;
6716             } else if (lastslash[1] == '.') {
6717                 if (lastslash[2] == '\0') {
6718                     is_dir = 1;
6719                 } else {
6720                     /* And finally allow '...' */
6721                     if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6722                         is_dir = 1;
6723                     }
6724                 }
6725             }
6726         }
6727
6728         if (!is_dir) {
6729            lastdot = strrchr(lastslash, '.');
6730         }
6731         if (lastdot != NULL) {
6732             STRLEN e_len;
6733              /* '.dir' is discarded, and any other '.' is invalid */
6734             e_len = strlen(lastdot);
6735
6736             is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6737
6738             if (is_dir) {
6739                 dir_len = dir_len - 4;
6740             }
6741         }
6742
6743         my_strlcpy(buf, trndir, VMS_MAXRSS);
6744         if (buf[dir_len - 1] != '/') {
6745             buf[dir_len] = '/';
6746             buf[dir_len + 1] = '\0';
6747         }
6748
6749         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6750         if (!decc_efs_charset) {
6751              int dir_start = 0;
6752              char * str = buf;
6753              if (str[0] == '.') {
6754                  char * dots = str;
6755                  int cnt = 1;
6756                  while ((dots[cnt] == '.') && (cnt < 3))
6757                      cnt++;
6758                  if (cnt <= 3) {
6759                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6760                          dir_start = 1;
6761                          str += cnt;
6762                      }
6763                  }
6764              }
6765              for (; *str; ++str) {
6766                  while (*str == '/') {
6767                      dir_start = 1;
6768                      *str++;
6769                  }
6770                  if (dir_start) {
6771
6772                      /* Have to skip up to three dots which could be */
6773                      /* directories, 3 dots being a VMS extension for Perl */
6774                      char * dots = str;
6775                      int cnt = 0;
6776                      while ((dots[cnt] == '.') && (cnt < 3)) {
6777                          cnt++;
6778                      }
6779                      if (dots[cnt] == '\0')
6780                          break;
6781                      if ((cnt > 1) && (dots[cnt] != '/')) {
6782                          dir_start = 0;
6783                      } else {
6784                          str += cnt;
6785                      }
6786
6787                      /* too many dots? */
6788                      if ((cnt == 0) || (cnt > 3)) {
6789                          dir_start = 0;
6790                      }
6791                  }
6792                  if (!dir_start && (*str == '.')) {
6793                      *str = '_';
6794                  }
6795              }
6796         }
6797         PerlMem_free(trndir);
6798         ret_spec = buf;
6799         if (vms_debug_fileify) {
6800             if (ret_spec == NULL)
6801                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6802             else
6803                 fprintf(stderr,
6804                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6805         }
6806         return ret_spec;
6807     }
6808 }
6809
6810 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6811 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6812 {
6813     static char __pathify_retbuf[VMS_MAXRSS];
6814     char * pathified, *ret_spec, *ret_buf;
6815
6816     pathified = NULL;
6817     ret_buf = buf;
6818     if (ret_buf == NULL) {
6819         if (ts) {
6820             Newx(pathified, VMS_MAXRSS, char);
6821             if (pathified == NULL)
6822                 _ckvmssts(SS$_INSFMEM);
6823             ret_buf = pathified;
6824         } else {
6825             ret_buf = __pathify_retbuf;
6826         }
6827     }
6828
6829     ret_spec = int_pathify_dirspec(dir, ret_buf);
6830
6831     if (ret_spec == NULL) {
6832        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6833        if (pathified)
6834            Safefree(pathified);
6835     }
6836
6837     return ret_spec;
6838
6839 }  /* end of do_pathify_dirspec() */
6840
6841
6842 /* External entry points */
6843 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6844 { return do_pathify_dirspec(dir,buf,0,NULL); }
6845 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6846 { return do_pathify_dirspec(dir,buf,1,NULL); }
6847 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6848 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6849 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6850 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6851
6852 /* Internal tounixspec routine that does not use a thread context */
6853 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6854 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6855 {
6856   char *dirend, *cp1, *cp3, *tmp;
6857   const char *cp2;
6858   int dirlen;
6859   unsigned short int trnlnm_iter_count;
6860   int cmp_rslt;
6861   if (utf8_fl != NULL)
6862     *utf8_fl = 0;
6863
6864   if (vms_debug_fileify) {
6865       if (spec == NULL)
6866           fprintf(stderr, "int_tounixspec: spec = NULL\n");
6867       else
6868           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6869   }
6870
6871
6872   if (spec == NULL) {
6873       set_errno(EINVAL);
6874       set_vaxc_errno(SS$_BADPARAM);
6875       return NULL;
6876   }
6877   if (strlen(spec) > (VMS_MAXRSS-1)) {
6878       set_errno(E2BIG);
6879       set_vaxc_errno(SS$_BUFFEROVF);
6880       return NULL;
6881   }
6882
6883   /* New VMS specific format needs translation
6884    * glob passes filenames with trailing '\n' and expects this preserved.
6885    */
6886   if (decc_posix_compliant_pathnames) {
6887     if (strncmp(spec, "\"^UP^", 5) == 0) {
6888       char * uspec;
6889       char *tunix;
6890       int tunix_len;
6891       int nl_flag;
6892
6893       tunix = PerlMem_malloc(VMS_MAXRSS);
6894       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6895       tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
6896       nl_flag = 0;
6897       if (tunix[tunix_len - 1] == '\n') {
6898         tunix[tunix_len - 1] = '\"';
6899         tunix[tunix_len] = '\0';
6900         tunix_len--;
6901         nl_flag = 1;
6902       }
6903       uspec = decc$translate_vms(tunix);
6904       PerlMem_free(tunix);
6905       if ((int)uspec > 0) {
6906         my_strlcpy(rslt, uspec, VMS_MAXRSS);
6907         if (nl_flag) {
6908           strcat(rslt,"\n");
6909         }
6910         else {
6911           /* If we can not translate it, makemaker wants as-is */
6912           my_strlcpy(rslt, spec, VMS_MAXRSS);
6913         }
6914         return rslt;
6915       }
6916     }
6917   }
6918
6919   cmp_rslt = 0; /* Presume VMS */
6920   cp1 = strchr(spec, '/');
6921   if (cp1 == NULL)
6922     cmp_rslt = 0;
6923
6924     /* Look for EFS ^/ */
6925     if (decc_efs_charset) {
6926       while (cp1 != NULL) {
6927         cp2 = cp1 - 1;
6928         if (*cp2 != '^') {
6929           /* Found illegal VMS, assume UNIX */
6930           cmp_rslt = 1;
6931           break;
6932         }
6933       cp1++;
6934       cp1 = strchr(cp1, '/');
6935     }
6936   }
6937
6938   /* Look for "." and ".." */
6939   if (decc_filename_unix_report) {
6940     if (spec[0] == '.') {
6941       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6942         cmp_rslt = 1;
6943       }
6944       else {
6945         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6946           cmp_rslt = 1;
6947         }
6948       }
6949     }
6950   }
6951   /* This is already UNIX or at least nothing VMS understands */
6952   if (cmp_rslt) {
6953     my_strlcpy(rslt, spec, VMS_MAXRSS);
6954     if (vms_debug_fileify) {
6955         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6956     }
6957     return rslt;
6958   }
6959
6960   cp1 = rslt;
6961   cp2 = spec;
6962   dirend = strrchr(spec,']');
6963   if (dirend == NULL) dirend = strrchr(spec,'>');
6964   if (dirend == NULL) dirend = strchr(spec,':');
6965   if (dirend == NULL) {
6966     strcpy(rslt,spec);
6967     if (vms_debug_fileify) {
6968         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6969     }
6970     return rslt;
6971   }
6972
6973   /* Special case 1 - sys$posix_root = / */
6974   if (!decc_disable_posix_root) {
6975     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6976       *cp1 = '/';
6977       cp1++;
6978       cp2 = cp2 + 15;
6979       }
6980   }
6981
6982   /* Special case 2 - Convert NLA0: to /dev/null */
6983   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6984   if (cmp_rslt == 0) {
6985     strcpy(rslt, "/dev/null");
6986     cp1 = cp1 + 9;
6987     cp2 = cp2 + 5;
6988     if (spec[6] != '\0') {
6989       cp1[9] = '/';
6990       cp1++;
6991       cp2++;
6992     }
6993   }
6994
6995    /* Also handle special case "SYS$SCRATCH:" */
6996   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6997   tmp = PerlMem_malloc(VMS_MAXRSS);
6998   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6999   if (cmp_rslt == 0) {
7000   int islnm;
7001
7002     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7003     if (!islnm) {
7004       strcpy(rslt, "/tmp");
7005       cp1 = cp1 + 4;
7006       cp2 = cp2 + 12;
7007       if (spec[12] != '\0') {
7008         cp1[4] = '/';
7009         cp1++;
7010         cp2++;
7011       }
7012     }
7013   }
7014
7015   if (*cp2 != '[' && *cp2 != '<') {
7016     *(cp1++) = '/';
7017   }
7018   else {  /* the VMS spec begins with directories */
7019     cp2++;
7020     if (*cp2 == ']' || *cp2 == '>') {
7021       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7022       PerlMem_free(tmp);
7023       return rslt;
7024     }
7025     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7026       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7027         PerlMem_free(tmp);
7028         if (vms_debug_fileify) {
7029             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7030         }
7031         return NULL;
7032       }
7033       trnlnm_iter_count = 0;
7034       do {
7035         cp3 = tmp;
7036         while (*cp3 != ':' && *cp3) cp3++;
7037         *(cp3++) = '\0';
7038         if (strchr(cp3,']') != NULL) break;
7039         trnlnm_iter_count++;
7040         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7041       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7042       cp1 = rslt;
7043       cp3 = tmp;
7044       *(cp1++) = '/';
7045       while (*cp3) {
7046         *(cp1++) = *(cp3++);
7047         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7048             PerlMem_free(tmp);
7049             set_errno(ENAMETOOLONG);
7050             set_vaxc_errno(SS$_BUFFEROVF);
7051             if (vms_debug_fileify) {
7052                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7053             }
7054             return NULL; /* No room */
7055         }
7056       }
7057       *(cp1++) = '/';
7058     }
7059     if ((*cp2 == '^')) {
7060         /* EFS file escape, pass the next character as is */
7061         /* Fix me: HEX encoding for Unicode not implemented */
7062         cp2++;
7063     }
7064     else if ( *cp2 == '.') {
7065       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7066         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7067         cp2 += 3;
7068       }
7069       else cp2++;
7070     }
7071   }
7072   PerlMem_free(tmp);
7073   for (; cp2 <= dirend; cp2++) {
7074     if ((*cp2 == '^')) {
7075         /* EFS file escape, pass the next character as is */
7076         /* Fix me: HEX encoding for Unicode not implemented */
7077         *(cp1++) = *(++cp2);
7078         /* An escaped dot stays as is -- don't convert to slash */
7079         if (*cp2 == '.') cp2++;
7080     }
7081     if (*cp2 == ':') {
7082       *(cp1++) = '/';
7083       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7084     }
7085     else if (*cp2 == ']' || *cp2 == '>') {
7086       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7087     }
7088     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7089       *(cp1++) = '/';
7090       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7091         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7092                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7093         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7094             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7095       }
7096       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7097         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7098         cp2 += 2;
7099       }
7100     }
7101     else if (*cp2 == '-') {
7102       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7103         while (*cp2 == '-') {
7104           cp2++;
7105           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7106         }
7107         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7108                                                          /* filespecs like */
7109           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7110           if (vms_debug_fileify) {
7111               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7112           }
7113           return NULL;
7114         }
7115       }
7116       else *(cp1++) = *cp2;
7117     }
7118     else *(cp1++) = *cp2;
7119   }
7120   /* Translate the rest of the filename. */
7121   while (*cp2) {
7122       int dot_seen;
7123       dot_seen = 0;
7124       switch(*cp2) {
7125       /* Fixme - for compatibility with the CRTL we should be removing */
7126       /* spaces from the file specifications, but this may show that */
7127       /* some tests that were appearing to pass are not really passing */
7128       case '%':
7129           cp2++;
7130           *(cp1++) = '?';
7131           break;
7132       case '^':
7133           /* Fix me hex expansions not implemented */
7134           cp2++;  /* '^.' --> '.' and other. */
7135           if (*cp2) {
7136               if (*cp2 == '_') {
7137                   cp2++;
7138                   *(cp1++) = ' ';
7139               } else {
7140                   *(cp1++) = *(cp2++);
7141               }
7142           }
7143           break;
7144       case ';':
7145           if (decc_filename_unix_no_version) {
7146               /* Easy, drop the version */
7147               while (*cp2)
7148                   cp2++;
7149               break;
7150           } else {
7151               /* Punt - passing the version as a dot will probably */
7152               /* break perl in weird ways, but so did passing */
7153               /* through the ; as a version.  Follow the CRTL and */
7154               /* hope for the best. */
7155               cp2++;
7156               *(cp1++) = '.';
7157           }
7158           break;
7159       case '.':
7160           if (dot_seen) {
7161               /* We will need to fix this properly later */
7162               /* As Perl may be installed on an ODS-5 volume, but not */
7163               /* have the EFS_CHARSET enabled, it still may encounter */
7164               /* filenames with extra dots in them, and a precedent got */
7165               /* set which allowed them to work, that we will uphold here */
7166               /* If extra dots are present in a name and no ^ is on them */
7167               /* VMS assumes that the first one is the extension delimiter */
7168               /* the rest have an implied ^. */
7169
7170               /* this is also a conflict as the . is also a version */
7171               /* delimiter in VMS, */
7172
7173               *(cp1++) = *(cp2++);
7174               break;
7175           }
7176           dot_seen = 1;
7177           /* This is an extension */
7178           if (decc_readdir_dropdotnotype) {
7179               cp2++;
7180               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7181                   /* Drop the dot for the extension */
7182                   break;
7183               } else {
7184                   *(cp1++) = '.';
7185               }
7186               break;
7187           }
7188       default:
7189           *(cp1++) = *(cp2++);
7190       }
7191   }
7192   *cp1 = '\0';
7193
7194   /* This still leaves /000000/ when working with a
7195    * VMS device root or concealed root.
7196    */
7197   {
7198   int ulen;
7199   char * zeros;
7200
7201       ulen = strlen(rslt);
7202
7203       /* Get rid of "000000/ in rooted filespecs */
7204       if (ulen > 7) {
7205         zeros = strstr(rslt, "/000000/");
7206         if (zeros != NULL) {
7207           int mlen;
7208           mlen = ulen - (zeros - rslt) - 7;
7209           memmove(zeros, &zeros[7], mlen);
7210           ulen = ulen - 7;
7211           rslt[ulen] = '\0';
7212         }
7213       }
7214   }
7215
7216   if (vms_debug_fileify) {
7217       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7218   }
7219   return rslt;
7220
7221 }  /* end of int_tounixspec() */
7222
7223
7224 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7225 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7226 {
7227     static char __tounixspec_retbuf[VMS_MAXRSS];
7228     char * unixspec, *ret_spec, *ret_buf;
7229
7230     unixspec = NULL;
7231     ret_buf = buf;
7232     if (ret_buf == NULL) {
7233         if (ts) {
7234             Newx(unixspec, VMS_MAXRSS, char);
7235             if (unixspec == NULL)
7236                 _ckvmssts(SS$_INSFMEM);
7237             ret_buf = unixspec;
7238         } else {
7239             ret_buf = __tounixspec_retbuf;
7240         }
7241     }
7242
7243     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7244
7245     if (ret_spec == NULL) {
7246        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7247        if (unixspec)
7248            Safefree(unixspec);
7249     }
7250
7251     return ret_spec;
7252
7253 }  /* end of do_tounixspec() */
7254 /*}}}*/
7255 /* External entry points */
7256 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7257   { return do_tounixspec(spec,buf,0, NULL); }
7258 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7259   { return do_tounixspec(spec,buf,1, NULL); }
7260 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7261   { return do_tounixspec(spec,buf,0, utf8_fl); }
7262 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7263   { return do_tounixspec(spec,buf,1, utf8_fl); }
7264
7265 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7266
7267 /*
7268  This procedure is used to identify if a path is based in either
7269  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7270  it returns the OpenVMS format directory for it.
7271
7272  It is expecting specifications of only '/' or '/xxxx/'
7273
7274  If a posix root does not exist, or 'xxxx' is not a directory
7275  in the posix root, it returns a failure.
7276
7277  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7278
7279  It is used only internally by posix_to_vmsspec_hardway().
7280  */
7281
7282 static int posix_root_to_vms
7283   (char *vmspath, int vmspath_len,
7284    const char *unixpath,
7285    const int * utf8_fl)
7286 {
7287 int sts;
7288 struct FAB myfab = cc$rms_fab;
7289 rms_setup_nam(mynam);
7290 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7291 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7292 char * esa, * esal, * rsa, * rsal;
7293 int dir_flag;
7294 int unixlen;
7295
7296     dir_flag = 0;
7297     vmspath[0] = '\0';
7298     unixlen = strlen(unixpath);
7299     if (unixlen == 0) {
7300       return RMS$_FNF;
7301     }
7302
7303 #if __CRTL_VER >= 80200000
7304   /* If not a posix spec already, convert it */
7305   if (decc_posix_compliant_pathnames) {
7306     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7307       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7308     }
7309     else {
7310       /* This is already a VMS specification, no conversion */
7311       unixlen--;
7312       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7313     }
7314   }
7315   else
7316 #endif
7317   {
7318   int path_len;
7319   int i,j;
7320
7321      /* Check to see if this is under the POSIX root */
7322      if (decc_disable_posix_root) {
7323         return RMS$_FNF;
7324      }
7325
7326      /* Skip leading / */
7327      if (unixpath[0] == '/') {
7328         unixpath++;
7329         unixlen--;
7330      }
7331
7332
7333      strcpy(vmspath,"SYS$POSIX_ROOT:");
7334
7335      /* If this is only the / , or blank, then... */
7336      if (unixpath[0] == '\0') {
7337         /* by definition, this is the answer */
7338         return SS$_NORMAL;
7339      }
7340
7341      /* Need to look up a directory */
7342      vmspath[15] = '[';
7343      vmspath[16] = '\0';
7344
7345      /* Copy and add '^' escape characters as needed */
7346      j = 16;
7347      i = 0;
7348      while (unixpath[i] != 0) {
7349      int k;
7350
7351         j += copy_expand_unix_filename_escape
7352             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7353         i += k;
7354      }
7355
7356      path_len = strlen(vmspath);
7357      if (vmspath[path_len - 1] == '/')
7358         path_len--;
7359      vmspath[path_len] = ']';
7360      path_len++;
7361      vmspath[path_len] = '\0';
7362
7363   }
7364   vmspath[vmspath_len] = 0;
7365   if (unixpath[unixlen - 1] == '/')
7366   dir_flag = 1;
7367   esal = PerlMem_malloc(VMS_MAXRSS);
7368   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7369   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7370   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7371   rsal = PerlMem_malloc(VMS_MAXRSS);
7372   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7373   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7374   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7375   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7376   rms_bind_fab_nam(myfab, mynam);
7377   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7378   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7379   if (decc_efs_case_preserve)
7380     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7381 #ifdef NAML$M_OPEN_SPECIAL
7382   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7383 #endif
7384
7385   /* Set up the remaining naml fields */
7386   sts = sys$parse(&myfab);
7387
7388   /* It failed! Try again as a UNIX filespec */
7389   if (!(sts & 1)) {
7390     PerlMem_free(esal);
7391     PerlMem_free(esa);
7392     PerlMem_free(rsal);
7393     PerlMem_free(rsa);
7394     return sts;
7395   }
7396
7397    /* get the Device ID and the FID */
7398    sts = sys$search(&myfab);
7399
7400    /* These are no longer needed */
7401    PerlMem_free(esa);
7402    PerlMem_free(rsal);
7403    PerlMem_free(rsa);
7404
7405    /* on any failure, returned the POSIX ^UP^ filespec */
7406    if (!(sts & 1)) {
7407       PerlMem_free(esal);
7408       return sts;
7409    }
7410    specdsc.dsc$a_pointer = vmspath;
7411    specdsc.dsc$w_length = vmspath_len;
7412
7413    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7414    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7415    sts = lib$fid_to_name
7416       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7417
7418   /* on any failure, returned the POSIX ^UP^ filespec */
7419   if (!(sts & 1)) {
7420      /* This can happen if user does not have permission to read directories */
7421      if (strncmp(unixpath,"\"^UP^",5) != 0)
7422        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7423      else
7424        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7425   }
7426   else {
7427     vmspath[specdsc.dsc$w_length] = 0;
7428
7429     /* Are we expecting a directory? */
7430     if (dir_flag != 0) {
7431     int i;
7432     char *eptr;
7433
7434       eptr = NULL;
7435
7436       i = specdsc.dsc$w_length - 1;
7437       while (i > 0) {
7438       int zercnt;
7439         zercnt = 0;
7440         /* Version must be '1' */
7441         if (vmspath[i--] != '1')
7442           break;
7443         /* Version delimiter is one of ".;" */
7444         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7445           break;
7446         i--;
7447         if (vmspath[i--] != 'R')
7448           break;
7449         if (vmspath[i--] != 'I')
7450           break;
7451         if (vmspath[i--] != 'D')
7452           break;
7453         if (vmspath[i--] != '.')
7454           break;
7455         eptr = &vmspath[i+1];
7456         while (i > 0) {
7457           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7458             if (vmspath[i-1] != '^') {
7459               if (zercnt != 6) {
7460                 *eptr = vmspath[i];
7461                 eptr[1] = '\0';
7462                 vmspath[i] = '.';
7463                 break;
7464               }
7465               else {
7466                 /* Get rid of 6 imaginary zero directory filename */
7467                 vmspath[i+1] = '\0';
7468               }
7469             }
7470           }
7471           if (vmspath[i] == '0')
7472             zercnt++;
7473           else
7474             zercnt = 10;
7475           i--;
7476         }
7477         break;
7478       }
7479     }
7480   }
7481   PerlMem_free(esal);
7482   return sts;
7483 }
7484
7485 /* /dev/mumble needs to be handled special.
7486    /dev/null becomes NLA0:, And there is the potential for other stuff
7487    like /dev/tty which may need to be mapped to something.
7488 */
7489
7490 static int
7491 slash_dev_special_to_vms
7492    (const char * unixptr,
7493     char * vmspath,
7494     int vmspath_len)
7495 {
7496 char * nextslash;
7497 int len;
7498 int cmp;
7499
7500     unixptr += 4;
7501     nextslash = strchr(unixptr, '/');
7502     len = strlen(unixptr);
7503     if (nextslash != NULL)
7504         len = nextslash - unixptr;
7505     cmp = strncmp("null", unixptr, 5);
7506     if (cmp == 0) {
7507         if (vmspath_len >= 6) {
7508             strcpy(vmspath, "_NLA0:");
7509             return SS$_NORMAL;
7510         }
7511     }
7512     return 0;
7513 }
7514
7515
7516 /* The built in routines do not understand perl's special needs, so
7517     doing a manual conversion from UNIX to VMS
7518
7519     If the utf8_fl is not null and points to a non-zero value, then
7520     treat 8 bit characters as UTF-8.
7521
7522     The sequence starting with '$(' and ending with ')' will be passed
7523     through with out interpretation instead of being escaped.
7524
7525   */
7526 static int posix_to_vmsspec_hardway
7527   (char *vmspath, int vmspath_len,
7528    const char *unixpath,
7529    int dir_flag,
7530    int * utf8_fl) {
7531
7532 char *esa;
7533 const char *unixptr;
7534 const char *unixend;
7535 char *vmsptr;
7536 const char *lastslash;
7537 const char *lastdot;
7538 int unixlen;
7539 int vmslen;
7540 int dir_start;
7541 int dir_dot;
7542 int quoted;
7543 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7544 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7545
7546   if (utf8_fl != NULL)
7547     *utf8_fl = 0;
7548
7549   unixptr = unixpath;
7550   dir_dot = 0;
7551
7552   /* Ignore leading "/" characters */
7553   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7554     unixptr++;
7555   }
7556   unixlen = strlen(unixptr);
7557
7558   /* Do nothing with blank paths */
7559   if (unixlen == 0) {
7560     vmspath[0] = '\0';
7561     return SS$_NORMAL;
7562   }
7563
7564   quoted = 0;
7565   /* This could have a "^UP^ on the front */
7566   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7567     quoted = 1;
7568     unixptr+= 5;
7569     unixlen-= 5;
7570   }
7571
7572   lastslash = strrchr(unixptr,'/');
7573   lastdot = strrchr(unixptr,'.');
7574   unixend = strrchr(unixptr,'\"');
7575   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7576     unixend = unixptr + unixlen;
7577   }
7578
7579   /* last dot is last dot or past end of string */
7580   if (lastdot == NULL)
7581     lastdot = unixptr + unixlen;
7582
7583   /* if no directories, set last slash to beginning of string */
7584   if (lastslash == NULL) {
7585     lastslash = unixptr;
7586   }
7587   else {
7588     /* Watch out for trailing "." after last slash, still a directory */
7589     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7590       lastslash = unixptr + unixlen;
7591     }
7592
7593     /* Watch out for trailing ".." after last slash, still a directory */
7594     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7595       lastslash = unixptr + unixlen;
7596     }
7597
7598     /* dots in directories are aways escaped */
7599     if (lastdot < lastslash)
7600       lastdot = unixptr + unixlen;
7601   }
7602
7603   /* if (unixptr < lastslash) then we are in a directory */
7604
7605   dir_start = 0;
7606
7607   vmsptr = vmspath;
7608   vmslen = 0;
7609
7610   /* Start with the UNIX path */
7611   if (*unixptr != '/') {
7612     /* relative paths */
7613
7614     /* If allowing logical names on relative pathnames, then handle here */
7615     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7616         !decc_posix_compliant_pathnames) {
7617     char * nextslash;
7618     int seg_len;
7619     char * trn;
7620     int islnm;
7621
7622         /* Find the next slash */
7623         nextslash = strchr(unixptr,'/');
7624
7625         esa = PerlMem_malloc(vmspath_len);
7626         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7627
7628         trn = PerlMem_malloc(VMS_MAXRSS);
7629         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7630
7631         if (nextslash != NULL) {
7632
7633             seg_len = nextslash - unixptr;
7634             memcpy(esa, unixptr, seg_len);
7635             esa[seg_len] = 0;
7636         }
7637         else {
7638             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7639         }
7640         /* trnlnm(section) */
7641         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7642
7643         if (islnm) {
7644             /* Now fix up the directory */
7645
7646             /* Split up the path to find the components */
7647             sts = vms_split_path
7648                   (trn,
7649                    &v_spec,
7650                    &v_len,
7651                    &r_spec,
7652                    &r_len,
7653                    &d_spec,
7654                    &d_len,
7655                    &n_spec,
7656                    &n_len,
7657                    &e_spec,
7658                    &e_len,
7659                    &vs_spec,
7660                    &vs_len);
7661
7662             while (sts == 0) {
7663             int cmp;
7664
7665                 /* A logical name must be a directory  or the full
7666                    specification.  It is only a full specification if
7667                    it is the only component */
7668                 if ((unixptr[seg_len] == '\0') ||
7669                     (unixptr[seg_len+1] == '\0')) {
7670
7671                     /* Is a directory being required? */
7672                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7673                         /* Not a logical name */
7674                         break;
7675                     }
7676
7677
7678                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7679                         /* This must be a directory */
7680                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7681                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7682                             vmsptr[vmslen] = ':';
7683                             vmslen++;
7684                             vmsptr[vmslen] = '\0';
7685                             return SS$_NORMAL;
7686                         }
7687                     }
7688
7689                 }
7690
7691
7692                 /* must be dev/directory - ignore version */
7693                 if ((n_len + e_len) != 0)
7694                     break;
7695
7696                 /* transfer the volume */
7697                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7698                     memcpy(vmsptr, v_spec, v_len);
7699                     vmsptr += v_len;
7700                     vmsptr[0] = '\0';
7701                     vmslen += v_len;
7702                 }
7703
7704                 /* unroot the rooted directory */
7705                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7706                     r_spec[0] = '[';
7707                     r_spec[r_len - 1] = ']';
7708
7709                     /* This should not be there, but nothing is perfect */
7710                     if (r_len > 9) {
7711                         cmp = strcmp(&r_spec[1], "000000.");
7712                         if (cmp == 0) {
7713                             r_spec += 7;
7714                             r_spec[7] = '[';
7715                             r_len -= 7;
7716                             if (r_len == 2)
7717                                 r_len = 0;
7718                         }
7719                     }
7720                     if (r_len > 0) {
7721                         memcpy(vmsptr, r_spec, r_len);
7722                         vmsptr += r_len;
7723                         vmslen += r_len;
7724                         vmsptr[0] = '\0';
7725                     }
7726                 }
7727                 /* Bring over the directory. */
7728                 if ((d_len > 0) &&
7729                     ((d_len + vmslen) < vmspath_len)) {
7730                     d_spec[0] = '[';
7731                     d_spec[d_len - 1] = ']';
7732                     if (d_len > 9) {
7733                         cmp = strcmp(&d_spec[1], "000000.");
7734                         if (cmp == 0) {
7735                             d_spec += 7;
7736                             d_spec[7] = '[';
7737                             d_len -= 7;
7738                             if (d_len == 2)
7739                                 d_len = 0;
7740                         }
7741                     }
7742
7743                     if (r_len > 0) {
7744                         /* Remove the redundant root */
7745                         if (r_len > 0) {
7746                             /* remove the ][ */
7747                             vmsptr--;
7748                             vmslen--;
7749                             d_spec++;
7750                             d_len--;
7751                         }
7752                         memcpy(vmsptr, d_spec, d_len);
7753                             vmsptr += d_len;
7754                             vmslen += d_len;
7755                             vmsptr[0] = '\0';
7756                     }
7757                 }
7758                 break;
7759             }
7760         }
7761
7762         PerlMem_free(esa);
7763         PerlMem_free(trn);
7764     }
7765
7766     if (lastslash > unixptr) {
7767     int dotdir_seen;
7768
7769       /* skip leading ./ */
7770       dotdir_seen = 0;
7771       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7772         dotdir_seen = 1;
7773         unixptr++;
7774         unixptr++;
7775       }
7776
7777       /* Are we still in a directory? */
7778       if (unixptr <= lastslash) {
7779         *vmsptr++ = '[';
7780         vmslen = 1;
7781         dir_start = 1;
7782
7783         /* if not backing up, then it is relative forward. */
7784         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7785               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7786           *vmsptr++ = '.';
7787           vmslen++;
7788           dir_dot = 1;
7789           }
7790        }
7791        else {
7792          if (dotdir_seen) {
7793            /* Perl wants an empty directory here to tell the difference
7794             * between a DCL command and a filename
7795             */
7796           *vmsptr++ = '[';
7797           *vmsptr++ = ']';
7798           vmslen = 2;
7799         }
7800       }
7801     }
7802     else {
7803       /* Handle two special files . and .. */
7804       if (unixptr[0] == '.') {
7805         if (&unixptr[1] == unixend) {
7806           *vmsptr++ = '[';
7807           *vmsptr++ = ']';
7808           vmslen += 2;
7809           *vmsptr++ = '\0';
7810           return SS$_NORMAL;
7811         }
7812         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7813           *vmsptr++ = '[';
7814           *vmsptr++ = '-';
7815           *vmsptr++ = ']';
7816           vmslen += 3;
7817           *vmsptr++ = '\0';
7818           return SS$_NORMAL;
7819         }
7820       }
7821     }
7822   }
7823   else {        /* Absolute PATH handling */
7824   int sts;
7825   char * nextslash;
7826   int seg_len;
7827     /* Need to find out where root is */
7828
7829     /* In theory, this procedure should never get an absolute POSIX pathname
7830      * that can not be found on the POSIX root.
7831      * In practice, that can not be relied on, and things will show up
7832      * here that are a VMS device name or concealed logical name instead.
7833      * So to make things work, this procedure must be tolerant.
7834      */
7835     esa = PerlMem_malloc(vmspath_len);
7836     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7837
7838     sts = SS$_NORMAL;
7839     nextslash = strchr(&unixptr[1],'/');
7840     seg_len = 0;
7841     if (nextslash != NULL) {
7842       int cmp;
7843       seg_len = nextslash - &unixptr[1];
7844       my_strlcpy(vmspath, unixptr, seg_len + 2);
7845       cmp = 1;
7846       if (seg_len == 3) {
7847         cmp = strncmp(vmspath, "dev", 4);
7848         if (cmp == 0) {
7849             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7850             if (sts == SS$_NORMAL)
7851                 return SS$_NORMAL;
7852         }
7853       }
7854       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7855     }
7856
7857     if ($VMS_STATUS_SUCCESS(sts)) {
7858       /* This is verified to be a real path */
7859
7860       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7861       if ($VMS_STATUS_SUCCESS(sts)) {
7862         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
7863         vmsptr = vmspath + vmslen;
7864         unixptr++;
7865         if (unixptr < lastslash) {
7866         char * rptr;
7867           vmsptr--;
7868           *vmsptr++ = '.';
7869           dir_start = 1;
7870           dir_dot = 1;
7871           if (vmslen > 7) {
7872           int cmp;
7873             rptr = vmsptr - 7;
7874             cmp = strcmp(rptr,"000000.");
7875             if (cmp == 0) {
7876               vmslen -= 7;
7877               vmsptr -= 7;
7878               vmsptr[1] = '\0';
7879             } /* removing 6 zeros */
7880           } /* vmslen < 7, no 6 zeros possible */
7881         } /* Not in a directory */
7882       } /* Posix root found */
7883       else {
7884         /* No posix root, fall back to default directory */
7885         strcpy(vmspath, "SYS$DISK:[");
7886         vmsptr = &vmspath[10];
7887         vmslen = 10;
7888         if (unixptr > lastslash) {
7889            *vmsptr = ']';
7890            vmsptr++;
7891            vmslen++;
7892         }
7893         else {
7894            dir_start = 1;
7895         }
7896       }
7897     } /* end of verified real path handling */
7898     else {
7899     int add_6zero;
7900     int islnm;
7901
7902       /* Ok, we have a device or a concealed root that is not in POSIX
7903        * or we have garbage.  Make the best of it.
7904        */
7905
7906       /* Posix to VMS destroyed this, so copy it again */
7907       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
7908       vmslen = strlen(vmspath); /* We know we're truncating. */
7909       vmsptr = &vmsptr[vmslen];
7910       islnm = 0;
7911
7912       /* Now do we need to add the fake 6 zero directory to it? */
7913       add_6zero = 1;
7914       if ((*lastslash == '/') && (nextslash < lastslash)) {
7915         /* No there is another directory */
7916         add_6zero = 0;
7917       }
7918       else {
7919       int trnend;
7920       int cmp;
7921
7922         /* now we have foo:bar or foo:[000000]bar to decide from */
7923         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7924
7925         if (!islnm && !decc_posix_compliant_pathnames) {
7926
7927             cmp = strncmp("bin", vmspath, 4);
7928             if (cmp == 0) {
7929                 /* bin => SYS$SYSTEM: */
7930                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7931             }
7932             else {
7933                 /* tmp => SYS$SCRATCH: */
7934                 cmp = strncmp("tmp", vmspath, 4);
7935                 if (cmp == 0) {
7936                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7937                 }
7938             }
7939         }
7940
7941         trnend = islnm ? islnm - 1 : 0;
7942
7943         /* if this was a logical name, ']' or '>' must be present */
7944         /* if not a logical name, then assume a device and hope. */
7945         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7946
7947         /* if log name and trailing '.' then rooted - treat as device */
7948         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7949
7950         /* Fix me, if not a logical name, a device lookup should be
7951          * done to see if the device is file structured.  If the device
7952          * is not file structured, the 6 zeros should not be put on.
7953          *
7954          * As it is, perl is occasionally looking for dev:[000000]tty.
7955          * which looks a little strange.
7956          *
7957          * Not that easy to detect as "/dev" may be file structured with
7958          * special device files.
7959          */
7960
7961         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
7962             (&nextslash[1] == unixend)) {
7963           /* No real directory present */
7964           add_6zero = 1;
7965         }
7966       }
7967
7968       /* Put the device delimiter on */
7969       *vmsptr++ = ':';
7970       vmslen++;
7971       unixptr = nextslash;
7972       unixptr++;
7973
7974       /* Start directory if needed */
7975       if (!islnm || add_6zero) {
7976         *vmsptr++ = '[';
7977         vmslen++;
7978         dir_start = 1;
7979       }
7980
7981       /* add fake 000000] if needed */
7982       if (add_6zero) {
7983         *vmsptr++ = '0';
7984         *vmsptr++ = '0';
7985         *vmsptr++ = '0';
7986         *vmsptr++ = '0';
7987         *vmsptr++ = '0';
7988         *vmsptr++ = '0';
7989         *vmsptr++ = ']';
7990         vmslen += 7;
7991         dir_start = 0;
7992       }
7993
7994     } /* non-POSIX translation */
7995     PerlMem_free(esa);
7996   } /* End of relative/absolute path handling */
7997
7998   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7999   int dash_flag;
8000   int in_cnt;
8001   int out_cnt;
8002
8003     dash_flag = 0;
8004
8005     if (dir_start != 0) {
8006
8007       /* First characters in a directory are handled special */
8008       while ((*unixptr == '/') ||
8009              ((*unixptr == '.') &&
8010               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8011                 (&unixptr[1]==unixend)))) {
8012       int loop_flag;
8013
8014         loop_flag = 0;
8015
8016         /* Skip redundant / in specification */
8017         while ((*unixptr == '/') && (dir_start != 0)) {
8018           loop_flag = 1;
8019           unixptr++;
8020           if (unixptr == lastslash)
8021             break;
8022         }
8023         if (unixptr == lastslash)
8024           break;
8025
8026         /* Skip redundant ./ characters */
8027         while ((*unixptr == '.') &&
8028                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8029           loop_flag = 1;
8030           unixptr++;
8031           if (unixptr == lastslash)
8032             break;
8033           if (*unixptr == '/')
8034             unixptr++;
8035         }
8036         if (unixptr == lastslash)
8037           break;
8038
8039         /* Skip redundant ../ characters */
8040         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8041              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8042           /* Set the backing up flag */
8043           loop_flag = 1;
8044           dir_dot = 0;
8045           dash_flag = 1;
8046           *vmsptr++ = '-';
8047           vmslen++;
8048           unixptr++; /* first . */
8049           unixptr++; /* second . */
8050           if (unixptr == lastslash)
8051             break;
8052           if (*unixptr == '/') /* The slash */
8053             unixptr++;
8054         }
8055         if (unixptr == lastslash)
8056           break;
8057
8058         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8059         /* Not needed when VMS is pretending to be UNIX. */
8060
8061         /* Is this loop stuck because of too many dots? */
8062         if (loop_flag == 0) {
8063           /* Exit the loop and pass the rest through */
8064           break;
8065         }
8066       }
8067
8068       /* Are we done with directories yet? */
8069       if (unixptr >= lastslash) {
8070
8071         /* Watch out for trailing dots */
8072         if (dir_dot != 0) {
8073             vmslen --;
8074             vmsptr--;
8075         }
8076         *vmsptr++ = ']';
8077         vmslen++;
8078         dash_flag = 0;
8079         dir_start = 0;
8080         if (*unixptr == '/')
8081           unixptr++;
8082       }
8083       else {
8084         /* Have we stopped backing up? */
8085         if (dash_flag) {
8086           *vmsptr++ = '.';
8087           vmslen++;
8088           dash_flag = 0;
8089           /* dir_start continues to be = 1 */
8090         }
8091         if (*unixptr == '-') {
8092           *vmsptr++ = '^';
8093           *vmsptr++ = *unixptr++;
8094           vmslen += 2;
8095           dir_start = 0;
8096
8097           /* Now are we done with directories yet? */
8098           if (unixptr >= lastslash) {
8099
8100             /* Watch out for trailing dots */
8101             if (dir_dot != 0) {
8102               vmslen --;
8103               vmsptr--;
8104             }
8105
8106             *vmsptr++ = ']';
8107             vmslen++;
8108             dash_flag = 0;
8109             dir_start = 0;
8110           }
8111         }
8112       }
8113     }
8114
8115     /* All done? */
8116     if (unixptr >= unixend)
8117       break;
8118
8119     /* Normal characters - More EFS work probably needed */
8120     dir_start = 0;
8121     dir_dot = 0;
8122
8123     switch(*unixptr) {
8124     case '/':
8125         /* remove multiple / */
8126         while (unixptr[1] == '/') {
8127            unixptr++;
8128         }
8129         if (unixptr == lastslash) {
8130           /* Watch out for trailing dots */
8131           if (dir_dot != 0) {
8132             vmslen --;
8133             vmsptr--;
8134           }
8135           *vmsptr++ = ']';
8136         }
8137         else {
8138           dir_start = 1;
8139           *vmsptr++ = '.';
8140           dir_dot = 1;
8141
8142           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8143           /* Not needed when VMS is pretending to be UNIX. */
8144
8145         }
8146         dash_flag = 0;
8147         if (unixptr != unixend)
8148           unixptr++;
8149         vmslen++;
8150         break;
8151     case '.':
8152         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8153             (&unixptr[1] == unixend)) {
8154           *vmsptr++ = '^';
8155           *vmsptr++ = '.';
8156           vmslen += 2;
8157           unixptr++;
8158
8159           /* trailing dot ==> '^..' on VMS */
8160           if (unixptr == unixend) {
8161             *vmsptr++ = '.';
8162             vmslen++;
8163             unixptr++;
8164           }
8165           break;
8166         }
8167
8168         *vmsptr++ = *unixptr++;
8169         vmslen ++;
8170         break;
8171     case '"':
8172         if (quoted && (&unixptr[1] == unixend)) {
8173             unixptr++;
8174             break;
8175         }
8176         in_cnt = copy_expand_unix_filename_escape
8177                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8178         vmsptr += out_cnt;
8179         unixptr += in_cnt;
8180         break;
8181     case '~':
8182     case ';':
8183     case '\\':
8184     case '?':
8185     case ' ':
8186     default:
8187         in_cnt = copy_expand_unix_filename_escape
8188                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8189         vmsptr += out_cnt;
8190         unixptr += in_cnt;
8191         break;
8192     }
8193   }
8194
8195   /* Make sure directory is closed */
8196   if (unixptr == lastslash) {
8197     char *vmsptr2;
8198     vmsptr2 = vmsptr - 1;
8199
8200     if (*vmsptr2 != ']') {
8201       *vmsptr2--;
8202
8203       /* directories do not end in a dot bracket */
8204       if (*vmsptr2 == '.') {
8205         vmsptr2--;
8206
8207         /* ^. is allowed */
8208         if (*vmsptr2 != '^') {
8209           vmsptr--; /* back up over the dot */
8210         }
8211       }
8212       *vmsptr++ = ']';
8213     }
8214   }
8215   else {
8216     char *vmsptr2;
8217     /* Add a trailing dot if a file with no extension */
8218     vmsptr2 = vmsptr - 1;
8219     if ((vmslen > 1) &&
8220         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8221         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8222         *vmsptr++ = '.';
8223         vmslen++;
8224     }
8225   }
8226
8227   *vmsptr = '\0';
8228   return SS$_NORMAL;
8229 }
8230 #endif
8231
8232  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8233 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8234 {
8235 char * result;
8236 int utf8_flag;
8237
8238    /* If a UTF8 flag is being passed, honor it */
8239    utf8_flag = 0;
8240    if (utf8_fl != NULL) {
8241      utf8_flag = *utf8_fl;
8242     *utf8_fl = 0;
8243    }
8244
8245    if (utf8_flag) {
8246      /* If there is a possibility of UTF8, then if any UTF8 characters
8247         are present, then they must be converted to VTF-7
8248       */
8249      result = strcpy(rslt, path); /* FIX-ME */
8250    }
8251    else
8252      result = strcpy(rslt, path);
8253
8254    return result;
8255 }
8256
8257
8258
8259 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8260 static char *int_tovmsspec
8261    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8262   char *dirend;
8263   char *lastdot;
8264   register char *cp1;
8265   const char *cp2;
8266   unsigned long int infront = 0, hasdir = 1;
8267   int rslt_len;
8268   int no_type_seen;
8269   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8270   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8271
8272   if (vms_debug_fileify) {
8273       if (path == NULL)
8274           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8275       else
8276           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8277   }
8278
8279   if (path == NULL) {
8280       /* If we fail, we should be setting errno */
8281       set_errno(EINVAL);
8282       set_vaxc_errno(SS$_BADPARAM);
8283       return NULL;
8284   }
8285   rslt_len = VMS_MAXRSS-1;
8286
8287   /* '.' and '..' are "[]" and "[-]" for a quick check */
8288   if (path[0] == '.') {
8289     if (path[1] == '\0') {
8290       strcpy(rslt,"[]");
8291       if (utf8_flag != NULL)
8292         *utf8_flag = 0;
8293       return rslt;
8294     }
8295     else {
8296       if (path[1] == '.' && path[2] == '\0') {
8297         strcpy(rslt,"[-]");
8298         if (utf8_flag != NULL)
8299            *utf8_flag = 0;
8300         return rslt;
8301       }
8302     }
8303   }
8304
8305    /* Posix specifications are now a native VMS format */
8306   /*--------------------------------------------------*/
8307 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8308   if (decc_posix_compliant_pathnames) {
8309     if (strncmp(path,"\"^UP^",5) == 0) {
8310       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8311       return rslt;
8312     }
8313   }
8314 #endif
8315
8316   /* This is really the only way to see if this is already in VMS format */
8317   sts = vms_split_path
8318        (path,
8319         &v_spec,
8320         &v_len,
8321         &r_spec,
8322         &r_len,
8323         &d_spec,
8324         &d_len,
8325         &n_spec,
8326         &n_len,
8327         &e_spec,
8328         &e_len,
8329         &vs_spec,
8330         &vs_len);
8331   if (sts == 0) {
8332     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8333        replacement, because the above parse just took care of most of
8334        what is needed to do vmspath when the specification is already
8335        in VMS format.
8336
8337        And if it is not already, it is easier to do the conversion as
8338        part of this routine than to call this routine and then work on
8339        the result.
8340      */
8341
8342     /* If VMS punctuation was found, it is already VMS format */
8343     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8344       if (utf8_flag != NULL)
8345         *utf8_flag = 0;
8346       my_strlcpy(rslt, path, VMS_MAXRSS);
8347       if (vms_debug_fileify) {
8348           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8349       }
8350       return rslt;
8351     }
8352     /* Now, what to do with trailing "." cases where there is no
8353        extension?  If this is a UNIX specification, and EFS characters
8354        are enabled, then the trailing "." should be converted to a "^.".
8355        But if this was already a VMS specification, then it should be
8356        left alone.
8357
8358        So in the case of ambiguity, leave the specification alone.
8359      */
8360
8361
8362     /* If there is a possibility of UTF8, then if any UTF8 characters
8363         are present, then they must be converted to VTF-7
8364      */
8365     if (utf8_flag != NULL)
8366       *utf8_flag = 0;
8367     my_strlcpy(rslt, path, VMS_MAXRSS);
8368     if (vms_debug_fileify) {
8369         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8370     }
8371     return rslt;
8372   }
8373
8374   dirend = strrchr(path,'/');
8375
8376   if (dirend == NULL) {
8377      char *macro_start;
8378      int has_macro;
8379
8380      /* If we get here with no UNIX directory delimiters, then this is
8381         not a complete file specification, either garbage a UNIX glob
8382         specification that can not be converted to a VMS wildcard, or
8383         it a UNIX shell macro.  MakeMaker wants shell macros passed
8384         through AS-IS,
8385
8386         utf8 flag setting needs to be preserved.
8387       */
8388       hasdir = 0;
8389
8390       has_macro = 0;
8391       macro_start = strchr(path,'$');
8392       if (macro_start != NULL) {
8393           if (macro_start[1] == '(') {
8394               has_macro = 1;
8395           }
8396       }
8397       if ((decc_efs_charset == 0) || (has_macro)) {
8398           my_strlcpy(rslt, path, VMS_MAXRSS);
8399           if (vms_debug_fileify) {
8400               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8401           }
8402           return rslt;
8403       }
8404   }
8405   else if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8406     if (!*(dirend+2)) dirend +=2;
8407     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8408     if (decc_efs_charset == 0) {
8409       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8410     }
8411   }
8412
8413   cp1 = rslt;
8414   cp2 = path;
8415   lastdot = strrchr(cp2,'.');
8416   if (*cp2 == '/') {
8417     char *trndev;
8418     int islnm, rooted;
8419     STRLEN trnend;
8420
8421     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8422     if (!*(cp2+1)) {
8423       if (decc_disable_posix_root) {
8424         strcpy(rslt,"sys$disk:[000000]");
8425       }
8426       else {
8427         strcpy(rslt,"sys$posix_root:[000000]");
8428       }
8429       if (utf8_flag != NULL)
8430         *utf8_flag = 0;
8431       if (vms_debug_fileify) {
8432           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8433       }
8434       return rslt;
8435     }
8436     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8437     *cp1 = '\0';
8438     trndev = PerlMem_malloc(VMS_MAXRSS);
8439     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8440     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8441
8442      /* DECC special handling */
8443     if (!islnm) {
8444       if (strcmp(rslt,"bin") == 0) {
8445         strcpy(rslt,"sys$system");
8446         cp1 = rslt + 10;
8447         *cp1 = 0;
8448         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8449       }
8450       else if (strcmp(rslt,"tmp") == 0) {
8451         strcpy(rslt,"sys$scratch");
8452         cp1 = rslt + 11;
8453         *cp1 = 0;
8454         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8455       }
8456       else if (!decc_disable_posix_root) {
8457         strcpy(rslt, "sys$posix_root");
8458         cp1 = rslt + 14;
8459         *cp1 = 0;
8460         cp2 = path;
8461         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8462         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8463       }
8464       else if (strcmp(rslt,"dev") == 0) {
8465         if (strncmp(cp2,"/null", 5) == 0) {
8466           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8467             strcpy(rslt,"NLA0");
8468             cp1 = rslt + 4;
8469             *cp1 = 0;
8470             cp2 = cp2 + 5;
8471             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8472           }
8473         }
8474       }
8475     }
8476
8477     trnend = islnm ? strlen(trndev) - 1 : 0;
8478     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8479     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8480     /* If the first element of the path is a logical name, determine
8481      * whether it has to be translated so we can add more directories. */
8482     if (!islnm || rooted) {
8483       *(cp1++) = ':';
8484       *(cp1++) = '[';
8485       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8486       else cp2++;
8487     }
8488     else {
8489       if (cp2 != dirend) {
8490         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8491         cp1 = rslt + trnend;
8492         if (*cp2 != 0) {
8493           *(cp1++) = '.';
8494           cp2++;
8495         }
8496       }
8497       else {
8498         if (decc_disable_posix_root) {
8499           *(cp1++) = ':';
8500           hasdir = 0;
8501         }
8502       }
8503     }
8504     PerlMem_free(trndev);
8505   }
8506   else {
8507     *(cp1++) = '[';
8508     if (*cp2 == '.') {
8509       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8510         cp2 += 2;         /* skip over "./" - it's redundant */
8511         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8512       }
8513       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8514         *(cp1++) = '-';                                 /* "../" --> "-" */
8515         cp2 += 3;
8516       }
8517       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8518                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8519         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8520         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8521         cp2 += 4;
8522       }
8523       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8524         /* Escape the extra dots in EFS file specifications */
8525         *(cp1++) = '^';
8526       }
8527       if (cp2 > dirend) cp2 = dirend;
8528     }
8529     else *(cp1++) = '.';
8530   }
8531   for (; cp2 < dirend; cp2++) {
8532     if (*cp2 == '/') {
8533       if (*(cp2-1) == '/') continue;
8534       if (*(cp1-1) != '.') *(cp1++) = '.';
8535       infront = 0;
8536     }
8537     else if (!infront && *cp2 == '.') {
8538       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8539       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8540       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8541         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8542         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8543         else {
8544           *(cp1++) = '-';
8545         }
8546         cp2 += 2;
8547         if (cp2 == dirend) break;
8548       }
8549       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8550                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8551         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8552         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8553         if (!*(cp2+3)) {
8554           *(cp1++) = '.';  /* Simulate trailing '/' */
8555           cp2 += 2;  /* for loop will incr this to == dirend */
8556         }
8557         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8558       }
8559       else {
8560         if (decc_efs_charset == 0)
8561           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8562         else {
8563           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8564           *(cp1++) = '.';
8565         }
8566       }
8567     }
8568     else {
8569       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8570       if (*cp2 == '.') {
8571         if (decc_efs_charset == 0)
8572           *(cp1++) = '_';
8573         else {
8574           *(cp1++) = '^';
8575           *(cp1++) = '.';
8576         }
8577       }
8578       else                  *(cp1++) =  *cp2;
8579       infront = 1;
8580     }
8581   }
8582   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8583   if (hasdir) *(cp1++) = ']';
8584   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8585   /* fixme for ODS5 */
8586   no_type_seen = 0;
8587   if (cp2 > lastdot)
8588     no_type_seen = 1;
8589   while (*cp2) {
8590     switch(*cp2) {
8591     case '?':
8592         if (decc_efs_charset == 0)
8593           *(cp1++) = '%';
8594         else
8595           *(cp1++) = '?';
8596         cp2++;
8597     case ' ':
8598         *(cp1)++ = '^';
8599         *(cp1)++ = '_';
8600         cp2++;
8601         break;
8602     case '.':
8603         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8604             decc_readdir_dropdotnotype) {
8605           *(cp1)++ = '^';
8606           *(cp1)++ = '.';
8607           cp2++;
8608
8609           /* trailing dot ==> '^..' on VMS */
8610           if (*cp2 == '\0') {
8611             *(cp1++) = '.';
8612             no_type_seen = 0;
8613           }
8614         }
8615         else {
8616           *(cp1++) = *(cp2++);
8617           no_type_seen = 0;
8618         }
8619         break;
8620     case '$':
8621          /* This could be a macro to be passed through */
8622         *(cp1++) = *(cp2++);
8623         if (*cp2 == '(') {
8624         const char * save_cp2;
8625         char * save_cp1;
8626         int is_macro;
8627
8628             /* paranoid check */
8629             save_cp2 = cp2;
8630             save_cp1 = cp1;
8631             is_macro = 0;
8632
8633             /* Test through */
8634             *(cp1++) = *(cp2++);
8635             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8636                 *(cp1++) = *(cp2++);
8637                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8638                     *(cp1++) = *(cp2++);
8639                 }
8640                 if (*cp2 == ')') {
8641                     *(cp1++) = *(cp2++);
8642                     is_macro = 1;
8643                 }
8644             }
8645             if (is_macro == 0) {
8646                 /* Not really a macro - never mind */
8647                 cp2 = save_cp2;
8648                 cp1 = save_cp1;
8649             }
8650         }
8651         break;
8652     case '\"':
8653     case '~':
8654     case '`':
8655     case '!':
8656     case '#':
8657     case '%':
8658     case '^':
8659         /* Don't escape again if following character is
8660          * already something we escape.
8661          */
8662         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8663             *(cp1++) = *(cp2++);
8664             break;
8665         }
8666         /* But otherwise fall through and escape it. */
8667     case '&':
8668     case '(':
8669     case ')':
8670     case '=':
8671     case '+':
8672     case '\'':
8673     case '@':
8674     case '[':
8675     case ']':
8676     case '{':
8677     case '}':
8678     case ':':
8679     case '\\':
8680     case '|':
8681     case '<':
8682     case '>':
8683         *(cp1++) = '^';
8684         *(cp1++) = *(cp2++);
8685         break;
8686     case ';':
8687         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8688          * which is wrong.  UNIX notation should be ".dir." unless
8689          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8690          * changing this behavior could break more things at this time.
8691          * efs character set effectively does not allow "." to be a version
8692          * delimiter as a further complication about changing this.
8693          */
8694         if (decc_filename_unix_report != 0) {
8695           *(cp1++) = '^';
8696         }
8697         *(cp1++) = *(cp2++);
8698         break;
8699     default:
8700         *(cp1++) = *(cp2++);
8701     }
8702   }
8703   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8704   char *lcp1;
8705     lcp1 = cp1;
8706     lcp1--;
8707      /* Fix me for "^]", but that requires making sure that you do
8708       * not back up past the start of the filename
8709       */
8710     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8711       *cp1++ = '.';
8712   }
8713   *cp1 = '\0';
8714
8715   if (utf8_flag != NULL)
8716     *utf8_flag = 0;
8717   if (vms_debug_fileify) {
8718       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8719   }
8720   return rslt;
8721
8722 }  /* end of int_tovmsspec() */
8723
8724
8725 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8726 static char *mp_do_tovmsspec
8727    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8728   static char __tovmsspec_retbuf[VMS_MAXRSS];
8729     char * vmsspec, *ret_spec, *ret_buf;
8730
8731     vmsspec = NULL;
8732     ret_buf = buf;
8733     if (ret_buf == NULL) {
8734         if (ts) {
8735             Newx(vmsspec, VMS_MAXRSS, char);
8736             if (vmsspec == NULL)
8737                 _ckvmssts(SS$_INSFMEM);
8738             ret_buf = vmsspec;
8739         } else {
8740             ret_buf = __tovmsspec_retbuf;
8741         }
8742     }
8743
8744     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8745
8746     if (ret_spec == NULL) {
8747        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8748        if (vmsspec)
8749            Safefree(vmsspec);
8750     }
8751
8752     return ret_spec;
8753
8754 }  /* end of mp_do_tovmsspec() */
8755 /*}}}*/
8756 /* External entry points */
8757 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8758   { return do_tovmsspec(path,buf,0,NULL); }
8759 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8760   { return do_tovmsspec(path,buf,1,NULL); }
8761 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8762   { return do_tovmsspec(path,buf,0,utf8_fl); }
8763 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8764   { return do_tovmsspec(path,buf,1,utf8_fl); }
8765
8766 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8767 /* Internal routine for use with out an explicit context present */
8768 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
8769
8770     char * ret_spec, *pathified;
8771
8772     if (path == NULL)
8773         return NULL;
8774
8775     pathified = PerlMem_malloc(VMS_MAXRSS);
8776     if (pathified == NULL)
8777         _ckvmssts_noperl(SS$_INSFMEM);
8778
8779     ret_spec = int_pathify_dirspec(path, pathified);
8780
8781     if (ret_spec == NULL) {
8782         PerlMem_free(pathified);
8783         return NULL;
8784     }
8785
8786     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8787
8788     PerlMem_free(pathified);
8789     return ret_spec;
8790
8791 }
8792
8793 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8794 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8795   static char __tovmspath_retbuf[VMS_MAXRSS];
8796   int vmslen;
8797   char *pathified, *vmsified, *cp;
8798
8799   if (path == NULL) return NULL;
8800   pathified = PerlMem_malloc(VMS_MAXRSS);
8801   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8802   if (int_pathify_dirspec(path, pathified) == NULL) {
8803     PerlMem_free(pathified);
8804     return NULL;
8805   }
8806
8807   vmsified = NULL;
8808   if (buf == NULL)
8809      Newx(vmsified, VMS_MAXRSS, char);
8810   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8811     PerlMem_free(pathified);
8812     if (vmsified) Safefree(vmsified);
8813     return NULL;
8814   }
8815   PerlMem_free(pathified);
8816   if (buf) {
8817     return buf;
8818   }
8819   else if (ts) {
8820     vmslen = strlen(vmsified);
8821     Newx(cp,vmslen+1,char);
8822     memcpy(cp,vmsified,vmslen);
8823     cp[vmslen] = '\0';
8824     Safefree(vmsified);
8825     return cp;
8826   }
8827   else {
8828     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8829     Safefree(vmsified);
8830     return __tovmspath_retbuf;
8831   }
8832
8833 }  /* end of do_tovmspath() */
8834 /*}}}*/
8835 /* External entry points */
8836 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8837   { return do_tovmspath(path,buf,0, NULL); }
8838 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8839   { return do_tovmspath(path,buf,1, NULL); }
8840 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8841   { return do_tovmspath(path,buf,0,utf8_fl); }
8842 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8843   { return do_tovmspath(path,buf,1,utf8_fl); }
8844
8845
8846 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8847 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8848   static char __tounixpath_retbuf[VMS_MAXRSS];
8849   int unixlen;
8850   char *pathified, *unixified, *cp;
8851
8852   if (path == NULL) return NULL;
8853   pathified = PerlMem_malloc(VMS_MAXRSS);
8854   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8855   if (int_pathify_dirspec(path, pathified) == NULL) {
8856     PerlMem_free(pathified);
8857     return NULL;
8858   }
8859
8860   unixified = NULL;
8861   if (buf == NULL) {
8862       Newx(unixified, VMS_MAXRSS, char);
8863   }
8864   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8865     PerlMem_free(pathified);
8866     if (unixified) Safefree(unixified);
8867     return NULL;
8868   }
8869   PerlMem_free(pathified);
8870   if (buf) {
8871     return buf;
8872   }
8873   else if (ts) {
8874     unixlen = strlen(unixified);
8875     Newx(cp,unixlen+1,char);
8876     memcpy(cp,unixified,unixlen);
8877     cp[unixlen] = '\0';
8878     Safefree(unixified);
8879     return cp;
8880   }
8881   else {
8882     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
8883     Safefree(unixified);
8884     return __tounixpath_retbuf;
8885   }
8886
8887 }  /* end of do_tounixpath() */
8888 /*}}}*/
8889 /* External entry points */
8890 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8891   { return do_tounixpath(path,buf,0,NULL); }
8892 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8893   { return do_tounixpath(path,buf,1,NULL); }
8894 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8895   { return do_tounixpath(path,buf,0,utf8_fl); }
8896 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8897   { return do_tounixpath(path,buf,1,utf8_fl); }
8898
8899 /*
8900  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8901  *
8902  *****************************************************************************
8903  *                                                                           *
8904  *  Copyright (C) 1989-1994, 2007 by                                         *
8905  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8906  *                                                                           *
8907  *  Permission is hereby granted for the reproduction of this software       *
8908  *  on condition that this copyright notice is included in source            *
8909  *  distributions of the software.  The code may be modified and             *
8910  *  distributed under the same terms as Perl itself.                         *
8911  *                                                                           *
8912  *  27-Aug-1994 Modified for inclusion in perl5                              *
8913  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8914  *****************************************************************************
8915  */
8916
8917 /*
8918  * getredirection() is intended to aid in porting C programs
8919  * to VMS (Vax-11 C).  The native VMS environment does not support
8920  * '>' and '<' I/O redirection, or command line wild card expansion,
8921  * or a command line pipe mechanism using the '|' AND background
8922  * command execution '&'.  All of these capabilities are provided to any
8923  * C program which calls this procedure as the first thing in the
8924  * main program.
8925  * The piping mechanism will probably work with almost any 'filter' type
8926  * of program.  With suitable modification, it may useful for other
8927  * portability problems as well.
8928  *
8929  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8930  */
8931 struct list_item
8932     {
8933     struct list_item *next;
8934     char *value;
8935     };
8936
8937 static void add_item(struct list_item **head,
8938                      struct list_item **tail,
8939                      char *value,
8940                      int *count);
8941
8942 static void mp_expand_wild_cards(pTHX_ char *item,
8943                                 struct list_item **head,
8944                                 struct list_item **tail,
8945                                 int *count);
8946
8947 static int background_process(pTHX_ int argc, char **argv);
8948
8949 static void pipe_and_fork(pTHX_ char **cmargv);
8950
8951 /*{{{ void getredirection(int *ac, char ***av)*/
8952 static void
8953 mp_getredirection(pTHX_ int *ac, char ***av)
8954 /*
8955  * Process vms redirection arg's.  Exit if any error is seen.
8956  * If getredirection() processes an argument, it is erased
8957  * from the vector.  getredirection() returns a new argc and argv value.
8958  * In the event that a background command is requested (by a trailing "&"),
8959  * this routine creates a background subprocess, and simply exits the program.
8960  *
8961  * Warning: do not try to simplify the code for vms.  The code
8962  * presupposes that getredirection() is called before any data is
8963  * read from stdin or written to stdout.
8964  *
8965  * Normal usage is as follows:
8966  *
8967  *      main(argc, argv)
8968  *      int             argc;
8969  *      char            *argv[];
8970  *      {
8971  *              getredirection(&argc, &argv);
8972  *      }
8973  */
8974 {
8975     int                 argc = *ac;     /* Argument Count         */
8976     char                **argv = *av;   /* Argument Vector        */
8977     char                *ap;            /* Argument pointer       */
8978     int                 j;              /* argv[] index           */
8979     int                 item_count = 0; /* Count of Items in List */
8980     struct list_item    *list_head = 0; /* First Item in List       */
8981     struct list_item    *list_tail;     /* Last Item in List        */
8982     char                *in = NULL;     /* Input File Name          */
8983     char                *out = NULL;    /* Output File Name         */
8984     char                *outmode = "w"; /* Mode to Open Output File */
8985     char                *err = NULL;    /* Error File Name          */
8986     char                *errmode = "w"; /* Mode to Open Error File  */
8987     int                 cmargc = 0;     /* Piped Command Arg Count  */
8988     char                **cmargv = NULL;/* Piped Command Arg Vector */
8989
8990     /*
8991      * First handle the case where the last thing on the line ends with
8992      * a '&'.  This indicates the desire for the command to be run in a
8993      * subprocess, so we satisfy that desire.
8994      */
8995     ap = argv[argc-1];
8996     if (0 == strcmp("&", ap))
8997        exit(background_process(aTHX_ --argc, argv));
8998     if (*ap && '&' == ap[strlen(ap)-1])
8999         {
9000         ap[strlen(ap)-1] = '\0';
9001        exit(background_process(aTHX_ argc, argv));
9002         }
9003     /*
9004      * Now we handle the general redirection cases that involve '>', '>>',
9005      * '<', and pipes '|'.
9006      */
9007     for (j = 0; j < argc; ++j)
9008         {
9009         if (0 == strcmp("<", argv[j]))
9010             {
9011             if (j+1 >= argc)
9012                 {
9013                 fprintf(stderr,"No input file after < on command line");
9014                 exit(LIB$_WRONUMARG);
9015                 }
9016             in = argv[++j];
9017             continue;
9018             }
9019         if ('<' == *(ap = argv[j]))
9020             {
9021             in = 1 + ap;
9022             continue;
9023             }
9024         if (0 == strcmp(">", ap))
9025             {
9026             if (j+1 >= argc)
9027                 {
9028                 fprintf(stderr,"No output file after > on command line");
9029                 exit(LIB$_WRONUMARG);
9030                 }
9031             out = argv[++j];
9032             continue;
9033             }
9034         if ('>' == *ap)
9035             {
9036             if ('>' == ap[1])
9037                 {
9038                 outmode = "a";
9039                 if ('\0' == ap[2])
9040                     out = argv[++j];
9041                 else
9042                     out = 2 + ap;
9043                 }
9044             else
9045                 out = 1 + ap;
9046             if (j >= argc)
9047                 {
9048                 fprintf(stderr,"No output file after > or >> on command line");
9049                 exit(LIB$_WRONUMARG);
9050                 }
9051             continue;
9052             }
9053         if (('2' == *ap) && ('>' == ap[1]))
9054             {
9055             if ('>' == ap[2])
9056                 {
9057                 errmode = "a";
9058                 if ('\0' == ap[3])
9059                     err = argv[++j];
9060                 else
9061                     err = 3 + ap;
9062                 }
9063             else
9064                 if ('\0' == ap[2])
9065                     err = argv[++j];
9066                 else
9067                     err = 2 + ap;
9068             if (j >= argc)
9069                 {
9070                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9071                 exit(LIB$_WRONUMARG);
9072                 }
9073             continue;
9074             }
9075         if (0 == strcmp("|", argv[j]))
9076             {
9077             if (j+1 >= argc)
9078                 {
9079                 fprintf(stderr,"No command into which to pipe on command line");
9080                 exit(LIB$_WRONUMARG);
9081                 }
9082             cmargc = argc-(j+1);
9083             cmargv = &argv[j+1];
9084             argc = j;
9085             continue;
9086             }
9087         if ('|' == *(ap = argv[j]))
9088             {
9089             ++argv[j];
9090             cmargc = argc-j;
9091             cmargv = &argv[j];
9092             argc = j;
9093             continue;
9094             }
9095         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9096         }
9097     /*
9098      * Allocate and fill in the new argument vector, Some Unix's terminate
9099      * the list with an extra null pointer.
9100      */
9101     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9102     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9103     *av = argv;
9104     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9105         argv[j] = list_head->value;
9106     *ac = item_count;
9107     if (cmargv != NULL)
9108         {
9109         if (out != NULL)
9110             {
9111             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9112             exit(LIB$_INVARGORD);
9113             }
9114         pipe_and_fork(aTHX_ cmargv);
9115         }
9116
9117     /* Check for input from a pipe (mailbox) */
9118
9119     if (in == NULL && 1 == isapipe(0))
9120         {
9121         char mbxname[L_tmpnam];
9122         long int bufsize;
9123         long int dvi_item = DVI$_DEVBUFSIZ;
9124         $DESCRIPTOR(mbxnam, "");
9125         $DESCRIPTOR(mbxdevnam, "");
9126
9127         /* Input from a pipe, reopen it in binary mode to disable       */
9128         /* carriage control processing.                                 */
9129
9130         fgetname(stdin, mbxname, 1);
9131         mbxnam.dsc$a_pointer = mbxname;
9132         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9133         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9134         mbxdevnam.dsc$a_pointer = mbxname;
9135         mbxdevnam.dsc$w_length = sizeof(mbxname);
9136         dvi_item = DVI$_DEVNAM;
9137         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9138         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9139         set_errno(0);
9140         set_vaxc_errno(1);
9141         freopen(mbxname, "rb", stdin);
9142         if (errno != 0)
9143             {
9144             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9145             exit(vaxc$errno);
9146             }
9147         }
9148     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9149         {
9150         fprintf(stderr,"Can't open input file %s as stdin",in);
9151         exit(vaxc$errno);
9152         }
9153     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9154         {
9155         fprintf(stderr,"Can't open output file %s as stdout",out);
9156         exit(vaxc$errno);
9157         }
9158         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9159
9160     if (err != NULL) {
9161         if (strcmp(err,"&1") == 0) {
9162             dup2(fileno(stdout), fileno(stderr));
9163             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9164         } else {
9165         FILE *tmperr;
9166         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9167             {
9168             fprintf(stderr,"Can't open error file %s as stderr",err);
9169             exit(vaxc$errno);
9170             }
9171             fclose(tmperr);
9172            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9173                 {
9174                 exit(vaxc$errno);
9175                 }
9176             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9177         }
9178         }
9179 #ifdef ARGPROC_DEBUG
9180     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9181     for (j = 0; j < *ac;  ++j)
9182         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9183 #endif
9184    /* Clear errors we may have hit expanding wildcards, so they don't
9185       show up in Perl's $! later */
9186    set_errno(0); set_vaxc_errno(1);
9187 }  /* end of getredirection() */
9188 /*}}}*/
9189
9190 static void add_item(struct list_item **head,
9191                      struct list_item **tail,
9192                      char *value,
9193                      int *count)
9194 {
9195     if (*head == 0)
9196         {
9197         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9198         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9199         *tail = *head;
9200         }
9201     else {
9202         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9203         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9204         *tail = (*tail)->next;
9205         }
9206     (*tail)->value = value;
9207     ++(*count);
9208 }
9209
9210 static void mp_expand_wild_cards(pTHX_ char *item,
9211                               struct list_item **head,
9212                               struct list_item **tail,
9213                               int *count)
9214 {
9215 int expcount = 0;
9216 unsigned long int context = 0;
9217 int isunix = 0;
9218 int item_len = 0;
9219 char *had_version;
9220 char *had_device;
9221 int had_directory;
9222 char *devdir,*cp;
9223 char *vmsspec;
9224 $DESCRIPTOR(filespec, "");
9225 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9226 $DESCRIPTOR(resultspec, "");
9227 unsigned long int lff_flags = 0;
9228 int sts;
9229 int rms_sts;
9230
9231 #ifdef VMS_LONGNAME_SUPPORT
9232     lff_flags = LIB$M_FIL_LONG_NAMES;
9233 #endif
9234
9235     for (cp = item; *cp; cp++) {
9236         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9237         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9238     }
9239     if (!*cp || isspace(*cp))
9240         {
9241         add_item(head, tail, item, count);
9242         return;
9243         }
9244     else
9245         {
9246      /* "double quoted" wild card expressions pass as is */
9247      /* From DCL that means using e.g.:                  */
9248      /* perl program """perl.*"""                        */
9249      item_len = strlen(item);
9250      if ( '"' == *item && '"' == item[item_len-1] )
9251        {
9252        item++;
9253        item[item_len-2] = '\0';
9254        add_item(head, tail, item, count);
9255        return;
9256        }
9257      }
9258     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9259     resultspec.dsc$b_class = DSC$K_CLASS_D;
9260     resultspec.dsc$a_pointer = NULL;
9261     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9262     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9263     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9264       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9265     if (!isunix || !filespec.dsc$a_pointer)
9266       filespec.dsc$a_pointer = item;
9267     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9268     /*
9269      * Only return version specs, if the caller specified a version
9270      */
9271     had_version = strchr(item, ';');
9272     /*
9273      * Only return device and directory specs, if the caller specified either.
9274      */
9275     had_device = strchr(item, ':');
9276     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9277
9278     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9279                                  (&filespec, &resultspec, &context,
9280                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9281         {
9282         char *string;
9283         char *c;
9284
9285         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9286         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9287         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9288         if (NULL == had_version)
9289             *(strrchr(string, ';')) = '\0';
9290         if ((!had_directory) && (had_device == NULL))
9291             {
9292             if (NULL == (devdir = strrchr(string, ']')))
9293                 devdir = strrchr(string, '>');
9294             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9295             }
9296         /*
9297          * Be consistent with what the C RTL has already done to the rest of
9298          * the argv items and lowercase all of these names.
9299          */
9300         if (!decc_efs_case_preserve) {
9301             for (c = string; *c; ++c)
9302             if (isupper(*c))
9303                 *c = tolower(*c);
9304         }
9305         if (isunix) trim_unixpath(string,item,1);
9306         add_item(head, tail, string, count);
9307         ++expcount;
9308     }
9309     PerlMem_free(vmsspec);
9310     if (sts != RMS$_NMF)
9311         {
9312         set_vaxc_errno(sts);
9313         switch (sts)
9314             {
9315             case RMS$_FNF: case RMS$_DNF:
9316                 set_errno(ENOENT); break;
9317             case RMS$_DIR:
9318                 set_errno(ENOTDIR); break;
9319             case RMS$_DEV:
9320                 set_errno(ENODEV); break;
9321             case RMS$_FNM: case RMS$_SYN:
9322                 set_errno(EINVAL); break;
9323             case RMS$_PRV:
9324                 set_errno(EACCES); break;
9325             default:
9326                 _ckvmssts_noperl(sts);
9327             }
9328         }
9329     if (expcount == 0)
9330         add_item(head, tail, item, count);
9331     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9332     _ckvmssts_noperl(lib$find_file_end(&context));
9333 }
9334
9335 static int child_st[2];/* Event Flag set when child process completes   */
9336
9337 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9338
9339 static unsigned long int exit_handler(void)
9340 {
9341 short iosb[4];
9342
9343     if (0 == child_st[0])
9344         {
9345 #ifdef ARGPROC_DEBUG
9346         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9347 #endif
9348         fflush(stdout);     /* Have to flush pipe for binary data to    */
9349                             /* terminate properly -- <tp@mccall.com>    */
9350         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9351         sys$dassgn(child_chan);
9352         fclose(stdout);
9353         sys$synch(0, child_st);
9354         }
9355     return(1);
9356 }
9357
9358 static void sig_child(int chan)
9359 {
9360 #ifdef ARGPROC_DEBUG
9361     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9362 #endif
9363     if (child_st[0] == 0)
9364         child_st[0] = 1;
9365 }
9366
9367 static struct exit_control_block exit_block =
9368     {
9369     0,
9370     exit_handler,
9371     1,
9372     &exit_block.exit_status,
9373     0
9374     };
9375
9376 static void
9377 pipe_and_fork(pTHX_ char **cmargv)
9378 {
9379     PerlIO *fp;
9380     struct dsc$descriptor_s *vmscmd;
9381     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9382     int sts, j, l, ismcr, quote, tquote = 0;
9383
9384     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9385     vms_execfree(vmscmd);
9386
9387     j = l = 0;
9388     p = subcmd;
9389     q = cmargv[0];
9390     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9391               && toupper(*(q+2)) == 'R' && !*(q+3);
9392
9393     while (q && l < MAX_DCL_LINE_LENGTH) {
9394         if (!*q) {
9395             if (j > 0 && quote) {
9396                 *p++ = '"';
9397                 l++;
9398             }
9399             q = cmargv[++j];
9400             if (q) {
9401                 if (ismcr && j > 1) quote = 1;
9402                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9403                 *p++ = ' ';
9404                 l++;
9405                 if (quote || tquote) {
9406                     *p++ = '"';
9407                     l++;
9408                 }
9409             }
9410         } else {
9411             if ((quote||tquote) && *q == '"') {
9412                 *p++ = '"';
9413                 l++;
9414             }
9415             *p++ = *q++;
9416             l++;
9417         }
9418     }
9419     *p = '\0';
9420
9421     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9422     if (fp == NULL) {
9423         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9424     }
9425 }
9426
9427 static int background_process(pTHX_ int argc, char **argv)
9428 {
9429 char command[MAX_DCL_SYMBOL + 1] = "$";
9430 $DESCRIPTOR(value, "");
9431 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9432 static $DESCRIPTOR(null, "NLA0:");
9433 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9434 char pidstring[80];
9435 $DESCRIPTOR(pidstr, "");
9436 int pid;
9437 unsigned long int flags = 17, one = 1, retsts;
9438 int len;
9439
9440     len = my_strlcat(command, argv[0], sizeof(command));
9441     while (--argc && (len < MAX_DCL_SYMBOL))
9442         {
9443         my_strlcat(command, " \"", sizeof(command));
9444         my_strlcat(command, *(++argv), sizeof(command));
9445         len = my_strlcat(command, "\"", sizeof(command));
9446         }
9447     value.dsc$a_pointer = command;
9448     value.dsc$w_length = strlen(value.dsc$a_pointer);
9449     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9450     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9451     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9452         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9453     }
9454     else {
9455         _ckvmssts_noperl(retsts);
9456     }
9457 #ifdef ARGPROC_DEBUG
9458     PerlIO_printf(Perl_debug_log, "%s\n", command);
9459 #endif
9460     sprintf(pidstring, "%08X", pid);
9461     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9462     pidstr.dsc$a_pointer = pidstring;
9463     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9464     lib$set_symbol(&pidsymbol, &pidstr);
9465     return(SS$_NORMAL);
9466 }
9467 /*}}}*/
9468 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9469
9470
9471 /* OS-specific initialization at image activation (not thread startup) */
9472 /* Older VAXC header files lack these constants */
9473 #ifndef JPI$_RIGHTS_SIZE
9474 #  define JPI$_RIGHTS_SIZE 817
9475 #endif
9476 #ifndef KGB$M_SUBSYSTEM
9477 #  define KGB$M_SUBSYSTEM 0x8
9478 #endif
9479
9480 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9481
9482 /*{{{void vms_image_init(int *, char ***)*/
9483 void
9484 vms_image_init(int *argcp, char ***argvp)
9485 {
9486   int status;
9487   char eqv[LNM$C_NAMLENGTH+1] = "";
9488   unsigned int len, tabct = 8, tabidx = 0;
9489   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9490   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9491   unsigned short int dummy, rlen;
9492   struct dsc$descriptor_s **tabvec;
9493 #if defined(PERL_IMPLICIT_CONTEXT)
9494   pTHX = NULL;
9495 #endif
9496   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9497                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9498                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9499                                  {          0,                0,    0,      0} };
9500
9501 #ifdef KILL_BY_SIGPRC
9502     Perl_csighandler_init();
9503 #endif
9504
9505 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9506     /* This was moved from the pre-image init handler because on threaded */
9507     /* Perl it was always returning 0 for the default value. */
9508     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9509     if (status > 0) {
9510         int s;
9511         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9512         if (s > 0) {
9513             int initial;
9514             initial = decc$feature_get_value(s, 4);
9515             if (initial > 0) {
9516                 /* initial is: 0 if nothing has set the feature */
9517                 /*            -1 if initialized to default */
9518                 /*             1 if set by logical name */
9519                 /*             2 if set by decc$feature_set_value */
9520                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9521
9522                 /* If the value is not valid, force the feature off */
9523                 if (decc_disable_posix_root < 0) {
9524                     decc$feature_set_value(s, 1, 1);
9525                     decc_disable_posix_root = 1;
9526                 }
9527             }
9528             else {
9529                 /* Nothing has asked for it explicitly, so use our own default. */
9530                 decc_disable_posix_root = 1;
9531                 decc$feature_set_value(s, 1, 1);
9532             }
9533         }
9534     }
9535 #endif
9536
9537   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9538   _ckvmssts_noperl(iosb[0]);
9539   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9540     if (iprv[i]) {           /* Running image installed with privs? */
9541       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9542       will_taint = TRUE;
9543       break;
9544     }
9545   }
9546   /* Rights identifiers might trigger tainting as well. */
9547   if (!will_taint && (rlen || rsz)) {
9548     while (rlen < rsz) {
9549       /* We didn't get all the identifiers on the first pass.  Allocate a
9550        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9551        * were needed to hold all identifiers at time of last call; we'll
9552        * allocate that many unsigned long ints), and go back and get 'em.
9553        * If it gave us less than it wanted to despite ample buffer space,
9554        * something's broken.  Is your system missing a system identifier?
9555        */
9556       if (rsz <= jpilist[1].buflen) {
9557          /* Perl_croak accvios when used this early in startup. */
9558          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9559                          rsz, (unsigned long) jpilist[1].buflen,
9560                          "Check your rights database for corruption.\n");
9561          exit(SS$_ABORT);
9562       }
9563       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9564       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9565       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9566       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9567       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9568       _ckvmssts_noperl(iosb[0]);
9569     }
9570     mask = jpilist[1].bufadr;
9571     /* Check attribute flags for each identifier (2nd longword); protected
9572      * subsystem identifiers trigger tainting.
9573      */
9574     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9575       if (mask[i] & KGB$M_SUBSYSTEM) {
9576         will_taint = TRUE;
9577         break;
9578       }
9579     }
9580     if (mask != rlst) PerlMem_free(mask);
9581   }
9582
9583   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9584    * logical, some versions of the CRTL will add a phanthom /000000/
9585    * directory.  This needs to be removed.
9586    */
9587   if (decc_filename_unix_report) {
9588   char * zeros;
9589   int ulen;
9590     ulen = strlen(argvp[0][0]);
9591     if (ulen > 7) {
9592       zeros = strstr(argvp[0][0], "/000000/");
9593       if (zeros != NULL) {
9594         int mlen;
9595         mlen = ulen - (zeros - argvp[0][0]) - 7;
9596         memmove(zeros, &zeros[7], mlen);
9597         ulen = ulen - 7;
9598         argvp[0][0][ulen] = '\0';
9599       }
9600     }
9601     /* It also may have a trailing dot that needs to be removed otherwise
9602      * it will be converted to VMS mode incorrectly.
9603      */
9604     ulen--;
9605     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9606       argvp[0][0][ulen] = '\0';
9607   }
9608
9609   /* We need to use this hack to tell Perl it should run with tainting,
9610    * since its tainting flag may be part of the PL_curinterp struct, which
9611    * hasn't been allocated when vms_image_init() is called.
9612    */
9613   if (will_taint) {
9614     char **newargv, **oldargv;
9615     oldargv = *argvp;
9616     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9617     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9618     newargv[0] = oldargv[0];
9619     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9620     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9621     strcpy(newargv[1], "-T");
9622     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9623     (*argcp)++;
9624     newargv[*argcp] = NULL;
9625     /* We orphan the old argv, since we don't know where it's come from,
9626      * so we don't know how to free it.
9627      */
9628     *argvp = newargv;
9629   }
9630   else {  /* Did user explicitly request tainting? */
9631     int i;
9632     char *cp, **av = *argvp;
9633     for (i = 1; i < *argcp; i++) {
9634       if (*av[i] != '-') break;
9635       for (cp = av[i]+1; *cp; cp++) {
9636         if (*cp == 'T') { will_taint = 1; break; }
9637         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9638                   strchr("DFIiMmx",*cp)) break;
9639       }
9640       if (will_taint) break;
9641     }
9642   }
9643
9644   for (tabidx = 0;
9645        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9646        tabidx++) {
9647     if (!tabidx) {
9648       tabvec = (struct dsc$descriptor_s **)
9649             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9650       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9651     }
9652     else if (tabidx >= tabct) {
9653       tabct += 8;
9654       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9655       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9656     }
9657     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9658     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9659     tabvec[tabidx]->dsc$w_length  = 0;
9660     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9661     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9662     tabvec[tabidx]->dsc$a_pointer = NULL;
9663     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9664   }
9665   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9666
9667   getredirection(argcp,argvp);
9668 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9669   {
9670 # include <reentrancy.h>
9671   decc$set_reentrancy(C$C_MULTITHREAD);
9672   }
9673 #endif
9674   return;
9675 }
9676 /*}}}*/
9677
9678
9679 /* trim_unixpath()
9680  * Trim Unix-style prefix off filespec, so it looks like what a shell
9681  * glob expansion would return (i.e. from specified prefix on, not
9682  * full path).  Note that returned filespec is Unix-style, regardless
9683  * of whether input filespec was VMS-style or Unix-style.
9684  *
9685  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9686  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9687  * vector of options; at present, only bit 0 is used, and if set tells
9688  * trim unixpath to try the current default directory as a prefix when
9689  * presented with a possibly ambiguous ... wildcard.
9690  *
9691  * Returns !=0 on success, with trimmed filespec replacing contents of
9692  * fspec, and 0 on failure, with contents of fpsec unchanged.
9693  */
9694 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9695 int
9696 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9697 {
9698   char *unixified, *unixwild,
9699        *template, *base, *end, *cp1, *cp2;
9700   register int tmplen, reslen = 0, dirs = 0;
9701
9702   if (!wildspec || !fspec) return 0;
9703
9704   unixwild = PerlMem_malloc(VMS_MAXRSS);
9705   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9706   template = unixwild;
9707   if (strpbrk(wildspec,"]>:") != NULL) {
9708     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9709         PerlMem_free(unixwild);
9710         return 0;
9711     }
9712   }
9713   else {
9714     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9715   }
9716   unixified = PerlMem_malloc(VMS_MAXRSS);
9717   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9718   if (strpbrk(fspec,"]>:") != NULL) {
9719     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9720         PerlMem_free(unixwild);
9721         PerlMem_free(unixified);
9722         return 0;
9723     }
9724     else base = unixified;
9725     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9726      * check to see that final result fits into (isn't longer than) fspec */
9727     reslen = strlen(fspec);
9728   }
9729   else base = fspec;
9730
9731   /* No prefix or absolute path on wildcard, so nothing to remove */
9732   if (!*template || *template == '/') {
9733     PerlMem_free(unixwild);
9734     if (base == fspec) {
9735         PerlMem_free(unixified);
9736         return 1;
9737     }
9738     tmplen = strlen(unixified);
9739     if (tmplen > reslen) {
9740         PerlMem_free(unixified);
9741         return 0;  /* not enough space */
9742     }
9743     /* Copy unixified resultant, including trailing NUL */
9744     memmove(fspec,unixified,tmplen+1);
9745     PerlMem_free(unixified);
9746     return 1;
9747   }
9748
9749   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9750   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9751     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9752     for (cp1 = end ;cp1 >= base; cp1--)
9753       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9754         { cp1++; break; }
9755     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9756     PerlMem_free(unixified);
9757     PerlMem_free(unixwild);
9758     return 1;
9759   }
9760   else {
9761     char *tpl, *lcres;
9762     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9763     int ells = 1, totells, segdirs, match;
9764     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9765                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9766
9767     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9768     totells = ells;
9769     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9770     tpl = PerlMem_malloc(VMS_MAXRSS);
9771     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9772     if (ellipsis == template && opts & 1) {
9773       /* Template begins with an ellipsis.  Since we can't tell how many
9774        * directory names at the front of the resultant to keep for an
9775        * arbitrary starting point, we arbitrarily choose the current
9776        * default directory as a starting point.  If it's there as a prefix,
9777        * clip it off.  If not, fall through and act as if the leading
9778        * ellipsis weren't there (i.e. return shortest possible path that
9779        * could match template).
9780        */
9781       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9782           PerlMem_free(tpl);
9783           PerlMem_free(unixified);
9784           PerlMem_free(unixwild);
9785           return 0;
9786       }
9787       if (!decc_efs_case_preserve) {
9788         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9789           if (_tolower(*cp1) != _tolower(*cp2)) break;
9790       }
9791       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9792       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9793       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9794         memmove(fspec,cp2+1,end - cp2);
9795         PerlMem_free(tpl);
9796         PerlMem_free(unixified);
9797         PerlMem_free(unixwild);
9798         return 1;
9799       }
9800     }
9801     /* First off, back up over constant elements at end of path */
9802     if (dirs) {
9803       for (front = end ; front >= base; front--)
9804          if (*front == '/' && !dirs--) { front++; break; }
9805     }
9806     lcres = PerlMem_malloc(VMS_MAXRSS);
9807     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9808     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9809          cp1++,cp2++) {
9810             if (!decc_efs_case_preserve) {
9811                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9812             }
9813             else {
9814                 *cp2 = *cp1;
9815             }
9816     }
9817     if (cp1 != '\0') {
9818         PerlMem_free(tpl);
9819         PerlMem_free(unixified);
9820         PerlMem_free(unixwild);
9821         PerlMem_free(lcres);
9822         return 0;  /* Path too long. */
9823     }
9824     lcend = cp2;
9825     *cp2 = '\0';  /* Pick up with memcpy later */
9826     lcfront = lcres + (front - base);
9827     /* Now skip over each ellipsis and try to match the path in front of it. */
9828     while (ells--) {
9829       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9830         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9831             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9832       if (cp1 < template) break; /* template started with an ellipsis */
9833       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9834         ellipsis = cp1; continue;
9835       }
9836       wilddsc.dsc$a_pointer = tpl;
9837       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9838       nextell = cp1;
9839       for (segdirs = 0, cp2 = tpl;
9840            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9841            cp1++, cp2++) {
9842          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9843          else {
9844             if (!decc_efs_case_preserve) {
9845               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9846             }
9847             else {
9848               *cp2 = *cp1;  /* else preserve case for match */
9849             }
9850          }
9851          if (*cp2 == '/') segdirs++;
9852       }
9853       if (cp1 != ellipsis - 1) {
9854           PerlMem_free(tpl);
9855           PerlMem_free(unixified);
9856           PerlMem_free(unixwild);
9857           PerlMem_free(lcres);
9858           return 0; /* Path too long */
9859       }
9860       /* Back up at least as many dirs as in template before matching */
9861       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9862         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9863       for (match = 0; cp1 > lcres;) {
9864         resdsc.dsc$a_pointer = cp1;
9865         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9866           match++;
9867           if (match == 1) lcfront = cp1;
9868         }
9869         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9870       }
9871       if (!match) {
9872         PerlMem_free(tpl);
9873         PerlMem_free(unixified);
9874         PerlMem_free(unixwild);
9875         PerlMem_free(lcres);
9876         return 0;  /* Can't find prefix ??? */
9877       }
9878       if (match > 1 && opts & 1) {
9879         /* This ... wildcard could cover more than one set of dirs (i.e.
9880          * a set of similar dir names is repeated).  If the template
9881          * contains more than 1 ..., upstream elements could resolve the
9882          * ambiguity, but it's not worth a full backtracking setup here.
9883          * As a quick heuristic, clip off the current default directory
9884          * if it's present to find the trimmed spec, else use the
9885          * shortest string that this ... could cover.
9886          */
9887         char def[NAM$C_MAXRSS+1], *st;
9888
9889         if (getcwd(def, sizeof def,0) == NULL) {
9890             PerlMem_free(unixified);
9891             PerlMem_free(unixwild);
9892             PerlMem_free(lcres);
9893             PerlMem_free(tpl);
9894             return 0;
9895         }
9896         if (!decc_efs_case_preserve) {
9897           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9898             if (_tolower(*cp1) != _tolower(*cp2)) break;
9899         }
9900         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9901         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9902         if (*cp1 == '\0' && *cp2 == '/') {
9903           memmove(fspec,cp2+1,end - cp2);
9904           PerlMem_free(tpl);
9905           PerlMem_free(unixified);
9906           PerlMem_free(unixwild);
9907           PerlMem_free(lcres);
9908           return 1;
9909         }
9910         /* Nope -- stick with lcfront from above and keep going. */
9911       }
9912     }
9913     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9914     PerlMem_free(tpl);
9915     PerlMem_free(unixified);
9916     PerlMem_free(unixwild);
9917     PerlMem_free(lcres);
9918     return 1;
9919   }
9920
9921 }  /* end of trim_unixpath() */
9922 /*}}}*/
9923
9924
9925 /*
9926  *  VMS readdir() routines.
9927  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9928  *
9929  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9930  *  Minor modifications to original routines.
9931  */
9932
9933 /* readdir may have been redefined by reentr.h, so make sure we get
9934  * the local version for what we do here.
9935  */
9936 #ifdef readdir
9937 # undef readdir
9938 #endif
9939 #if !defined(PERL_IMPLICIT_CONTEXT)
9940 # define readdir Perl_readdir
9941 #else
9942 # define readdir(a) Perl_readdir(aTHX_ a)
9943 #endif
9944
9945     /* Number of elements in vms_versions array */
9946 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9947
9948 /*
9949  *  Open a directory, return a handle for later use.
9950  */
9951 /*{{{ DIR *opendir(char*name) */
9952 DIR *
9953 Perl_opendir(pTHX_ const char *name)
9954 {
9955     DIR *dd;
9956     char *dir;
9957     Stat_t sb;
9958
9959     Newx(dir, VMS_MAXRSS, char);
9960     if (int_tovmspath(name, dir, NULL) == NULL) {
9961       Safefree(dir);
9962       return NULL;
9963     }
9964     /* Check access before stat; otherwise stat does not
9965      * accurately report whether it's a directory.
9966      */
9967     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9968       /* cando_by_name has already set errno */
9969       Safefree(dir);
9970       return NULL;
9971     }
9972     if (flex_stat(dir,&sb) == -1) return NULL;
9973     if (!S_ISDIR(sb.st_mode)) {
9974       Safefree(dir);
9975       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9976       return NULL;
9977     }
9978     /* Get memory for the handle, and the pattern. */
9979     Newx(dd,1,DIR);
9980     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9981
9982     /* Fill in the fields; mainly playing with the descriptor. */
9983     sprintf(dd->pattern, "%s*.*",dir);
9984     Safefree(dir);
9985     dd->context = 0;
9986     dd->count = 0;
9987     dd->flags = 0;
9988     /* By saying we always want the result of readdir() in unix format, we
9989      * are really saying we want all the escapes removed.  Otherwise the caller,
9990      * having no way to know whether it's already in VMS format, might send it
9991      * through tovmsspec again, thus double escaping.
9992      */
9993     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9994     dd->pat.dsc$a_pointer = dd->pattern;
9995     dd->pat.dsc$w_length = strlen(dd->pattern);
9996     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9997     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9998 #if defined(USE_ITHREADS)
9999     Newx(dd->mutex,1,perl_mutex);
10000     MUTEX_INIT( (perl_mutex *) dd->mutex );
10001 #else
10002     dd->mutex = NULL;
10003 #endif
10004
10005     return dd;
10006 }  /* end of opendir() */
10007 /*}}}*/
10008
10009 /*
10010  *  Set the flag to indicate we want versions or not.
10011  */
10012 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10013 void
10014 vmsreaddirversions(DIR *dd, int flag)
10015 {
10016     if (flag)
10017         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10018     else
10019         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10020 }
10021 /*}}}*/
10022
10023 /*
10024  *  Free up an opened directory.
10025  */
10026 /*{{{ void closedir(DIR *dd)*/
10027 void
10028 Perl_closedir(DIR *dd)
10029 {
10030     int sts;
10031
10032     sts = lib$find_file_end(&dd->context);
10033     Safefree(dd->pattern);
10034 #if defined(USE_ITHREADS)
10035     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10036     Safefree(dd->mutex);
10037 #endif
10038     Safefree(dd);
10039 }
10040 /*}}}*/
10041
10042 /*
10043  *  Collect all the version numbers for the current file.
10044  */
10045 static void
10046 collectversions(pTHX_ DIR *dd)
10047 {
10048     struct dsc$descriptor_s     pat;
10049     struct dsc$descriptor_s     res;
10050     struct dirent *e;
10051     char *p, *text, *buff;
10052     int i;
10053     unsigned long context, tmpsts;
10054
10055     /* Convenient shorthand. */
10056     e = &dd->entry;
10057
10058     /* Add the version wildcard, ignoring the "*.*" put on before */
10059     i = strlen(dd->pattern);
10060     Newx(text,i + e->d_namlen + 3,char);
10061     my_strlcpy(text, dd->pattern, i + 1);
10062     sprintf(&text[i - 3], "%s;*", e->d_name);
10063
10064     /* Set up the pattern descriptor. */
10065     pat.dsc$a_pointer = text;
10066     pat.dsc$w_length = i + e->d_namlen - 1;
10067     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10068     pat.dsc$b_class = DSC$K_CLASS_S;
10069
10070     /* Set up result descriptor. */
10071     Newx(buff, VMS_MAXRSS, char);
10072     res.dsc$a_pointer = buff;
10073     res.dsc$w_length = VMS_MAXRSS - 1;
10074     res.dsc$b_dtype = DSC$K_DTYPE_T;
10075     res.dsc$b_class = DSC$K_CLASS_S;
10076
10077     /* Read files, collecting versions. */
10078     for (context = 0, e->vms_verscount = 0;
10079          e->vms_verscount < VERSIZE(e);
10080          e->vms_verscount++) {
10081         unsigned long rsts;
10082         unsigned long flags = 0;
10083
10084 #ifdef VMS_LONGNAME_SUPPORT
10085         flags = LIB$M_FIL_LONG_NAMES;
10086 #endif
10087         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10088         if (tmpsts == RMS$_NMF || context == 0) break;
10089         _ckvmssts(tmpsts);
10090         buff[VMS_MAXRSS - 1] = '\0';
10091         if ((p = strchr(buff, ';')))
10092             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10093         else
10094             e->vms_versions[e->vms_verscount] = -1;
10095     }
10096
10097     _ckvmssts(lib$find_file_end(&context));
10098     Safefree(text);
10099     Safefree(buff);
10100
10101 }  /* end of collectversions() */
10102
10103 /*
10104  *  Read the next entry from the directory.
10105  */
10106 /*{{{ struct dirent *readdir(DIR *dd)*/
10107 struct dirent *
10108 Perl_readdir(pTHX_ DIR *dd)
10109 {
10110     struct dsc$descriptor_s     res;
10111     char *p, *buff;
10112     unsigned long int tmpsts;
10113     unsigned long rsts;
10114     unsigned long flags = 0;
10115     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10116     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10117
10118     /* Set up result descriptor, and get next file. */
10119     Newx(buff, VMS_MAXRSS, char);
10120     res.dsc$a_pointer = buff;
10121     res.dsc$w_length = VMS_MAXRSS - 1;
10122     res.dsc$b_dtype = DSC$K_DTYPE_T;
10123     res.dsc$b_class = DSC$K_CLASS_S;
10124
10125 #ifdef VMS_LONGNAME_SUPPORT
10126     flags = LIB$M_FIL_LONG_NAMES;
10127 #endif
10128
10129     tmpsts = lib$find_file
10130         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10131     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10132     if (!(tmpsts & 1)) {
10133       set_vaxc_errno(tmpsts);
10134       switch (tmpsts) {
10135         case RMS$_PRV:
10136           set_errno(EACCES); break;
10137         case RMS$_DEV:
10138           set_errno(ENODEV); break;
10139         case RMS$_DIR:
10140           set_errno(ENOTDIR); break;
10141         case RMS$_FNF: case RMS$_DNF:
10142           set_errno(ENOENT); break;
10143         default:
10144           set_errno(EVMSERR);
10145       }
10146       Safefree(buff);
10147       return NULL;
10148     }
10149     dd->count++;
10150     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10151     buff[res.dsc$w_length] = '\0';
10152     p = buff + res.dsc$w_length;
10153     while (--p >= buff) if (!isspace(*p)) break;
10154     *p = '\0';
10155     if (!decc_efs_case_preserve) {
10156       for (p = buff; *p; p++) *p = _tolower(*p);
10157     }
10158
10159     /* Skip any directory component and just copy the name. */
10160     sts = vms_split_path
10161        (buff,
10162         &v_spec,
10163         &v_len,
10164         &r_spec,
10165         &r_len,
10166         &d_spec,
10167         &d_len,
10168         &n_spec,
10169         &n_len,
10170         &e_spec,
10171         &e_len,
10172         &vs_spec,
10173         &vs_len);
10174
10175     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10176
10177         /* In Unix report mode, remove the ".dir;1" from the name */
10178         /* if it is a real directory. */
10179         if (decc_filename_unix_report || decc_efs_charset) {
10180             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10181                 Stat_t statbuf;
10182                 int ret_sts;
10183
10184                 ret_sts = flex_lstat(buff, &statbuf);
10185                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10186                     e_len = 0;
10187                     e_spec[0] = 0;
10188                 }
10189             }
10190         }
10191
10192         /* Drop NULL extensions on UNIX file specification */
10193         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10194             e_len = 0;
10195             e_spec[0] = '\0';
10196         }
10197     }
10198
10199     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10200     dd->entry.d_name[n_len + e_len] = '\0';
10201     dd->entry.d_namlen = strlen(dd->entry.d_name);
10202
10203     /* Convert the filename to UNIX format if needed */
10204     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10205
10206         /* Translate the encoded characters. */
10207         /* Fixme: Unicode handling could result in embedded 0 characters */
10208         if (strchr(dd->entry.d_name, '^') != NULL) {
10209             char new_name[256];
10210             char * q;
10211             p = dd->entry.d_name;
10212             q = new_name;
10213             while (*p != 0) {
10214                 int inchars_read, outchars_added;
10215                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10216                 p += inchars_read;
10217                 q += outchars_added;
10218                 /* fix-me */
10219                 /* if outchars_added > 1, then this is a wide file specification */
10220                 /* Wide file specifications need to be passed in Perl */
10221                 /* counted strings apparently with a Unicode flag */
10222             }
10223             *q = 0;
10224             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10225         }
10226     }
10227
10228     dd->entry.vms_verscount = 0;
10229     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10230     Safefree(buff);
10231     return &dd->entry;
10232
10233 }  /* end of readdir() */
10234 /*}}}*/
10235
10236 /*
10237  *  Read the next entry from the directory -- thread-safe version.
10238  */
10239 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10240 int
10241 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10242 {
10243     int retval;
10244
10245     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10246
10247     entry = readdir(dd);
10248     *result = entry;
10249     retval = ( *result == NULL ? errno : 0 );
10250
10251     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10252
10253     return retval;
10254
10255 }  /* end of readdir_r() */
10256 /*}}}*/
10257
10258 /*
10259  *  Return something that can be used in a seekdir later.
10260  */
10261 /*{{{ long telldir(DIR *dd)*/
10262 long
10263 Perl_telldir(DIR *dd)
10264 {
10265     return dd->count;
10266 }
10267 /*}}}*/
10268
10269 /*
10270  *  Return to a spot where we used to be.  Brute force.
10271  */
10272 /*{{{ void seekdir(DIR *dd,long count)*/
10273 void
10274 Perl_seekdir(pTHX_ DIR *dd, long count)
10275 {
10276     int old_flags;
10277
10278     /* If we haven't done anything yet... */
10279     if (dd->count == 0)
10280         return;
10281
10282     /* Remember some state, and clear it. */
10283     old_flags = dd->flags;
10284     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10285     _ckvmssts(lib$find_file_end(&dd->context));
10286     dd->context = 0;
10287
10288     /* The increment is in readdir(). */
10289     for (dd->count = 0; dd->count < count; )
10290         readdir(dd);
10291
10292     dd->flags = old_flags;
10293
10294 }  /* end of seekdir() */
10295 /*}}}*/
10296
10297 /* VMS subprocess management
10298  *
10299  * my_vfork() - just a vfork(), after setting a flag to record that
10300  * the current script is trying a Unix-style fork/exec.
10301  *
10302  * vms_do_aexec() and vms_do_exec() are called in response to the
10303  * perl 'exec' function.  If this follows a vfork call, then they
10304  * call out the regular perl routines in doio.c which do an
10305  * execvp (for those who really want to try this under VMS).
10306  * Otherwise, they do exactly what the perl docs say exec should
10307  * do - terminate the current script and invoke a new command
10308  * (See below for notes on command syntax.)
10309  *
10310  * do_aspawn() and do_spawn() implement the VMS side of the perl
10311  * 'system' function.
10312  *
10313  * Note on command arguments to perl 'exec' and 'system': When handled
10314  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10315  * are concatenated to form a DCL command string.  If the first non-numeric
10316  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10317  * the command string is handed off to DCL directly.  Otherwise,
10318  * the first token of the command is taken as the filespec of an image
10319  * to run.  The filespec is expanded using a default type of '.EXE' and
10320  * the process defaults for device, directory, etc., and if found, the resultant
10321  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10322  * the command string as parameters.  This is perhaps a bit complicated,
10323  * but I hope it will form a happy medium between what VMS folks expect
10324  * from lib$spawn and what Unix folks expect from exec.
10325  */
10326
10327 static int vfork_called;
10328
10329 /*{{{int my_vfork(void)*/
10330 int
10331 my_vfork(void)
10332 {
10333   vfork_called++;
10334   return vfork();
10335 }
10336 /*}}}*/
10337
10338
10339 static void
10340 vms_execfree(struct dsc$descriptor_s *vmscmd)
10341 {
10342   if (vmscmd) {
10343       if (vmscmd->dsc$a_pointer) {
10344           PerlMem_free(vmscmd->dsc$a_pointer);
10345       }
10346       PerlMem_free(vmscmd);
10347   }
10348 }
10349
10350 static char *
10351 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10352 {
10353   char *junk, *tmps = NULL;
10354   register size_t cmdlen = 0;
10355   size_t rlen;
10356   register SV **idx;
10357   STRLEN n_a;
10358
10359   idx = mark;
10360   if (really) {
10361     tmps = SvPV(really,rlen);
10362     if (*tmps) {
10363       cmdlen += rlen + 1;
10364       idx++;
10365     }
10366   }
10367
10368   for (idx++; idx <= sp; idx++) {
10369     if (*idx) {
10370       junk = SvPVx(*idx,rlen);
10371       cmdlen += rlen ? rlen + 1 : 0;
10372     }
10373   }
10374   Newx(PL_Cmd, cmdlen+1, char);
10375
10376   if (tmps && *tmps) {
10377     my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10378     mark++;
10379   }
10380   else *PL_Cmd = '\0';
10381   while (++mark <= sp) {
10382     if (*mark) {
10383       char *s = SvPVx(*mark,n_a);
10384       if (!*s) continue;
10385       if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10386       my_strlcat(PL_Cmd, s, cmdlen+1);
10387     }
10388   }
10389   return PL_Cmd;
10390
10391 }  /* end of setup_argstr() */
10392
10393
10394 static unsigned long int
10395 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10396                    struct dsc$descriptor_s **pvmscmd)
10397 {
10398   char * vmsspec;
10399   char * resspec;
10400   char image_name[NAM$C_MAXRSS+1];
10401   char image_argv[NAM$C_MAXRSS+1];
10402   $DESCRIPTOR(defdsc,".EXE");
10403   $DESCRIPTOR(defdsc2,".");
10404   struct dsc$descriptor_s resdsc;
10405   struct dsc$descriptor_s *vmscmd;
10406   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10407   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10408   register char *s, *rest, *cp, *wordbreak;
10409   char * cmd;
10410   int cmdlen;
10411   register int isdcl;
10412
10413   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10414   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10415
10416   /* vmsspec is a DCL command buffer, not just a filename */
10417   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10418   if (vmsspec == NULL)
10419       _ckvmssts_noperl(SS$_INSFMEM);
10420
10421   resspec = PerlMem_malloc(VMS_MAXRSS);
10422   if (resspec == NULL)
10423       _ckvmssts_noperl(SS$_INSFMEM);
10424
10425   /* Make a copy for modification */
10426   cmdlen = strlen(incmd);
10427   cmd = PerlMem_malloc(cmdlen+1);
10428   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10429   my_strlcpy(cmd, incmd, cmdlen + 1);
10430   image_name[0] = 0;
10431   image_argv[0] = 0;
10432
10433   resdsc.dsc$a_pointer = resspec;
10434   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10435   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10436   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10437
10438   vmscmd->dsc$a_pointer = NULL;
10439   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10440   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10441   vmscmd->dsc$w_length = 0;
10442   if (pvmscmd) *pvmscmd = vmscmd;
10443
10444   if (suggest_quote) *suggest_quote = 0;
10445
10446   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10447     PerlMem_free(cmd);
10448     PerlMem_free(vmsspec);
10449     PerlMem_free(resspec);
10450     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10451   }
10452
10453   s = cmd;
10454
10455   while (*s && isspace(*s)) s++;
10456
10457   if (*s == '@' || *s == '$') {
10458     vmsspec[0] = *s;  rest = s + 1;
10459     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10460   }
10461   else { cp = vmsspec; rest = s; }
10462   if (*rest == '.' || *rest == '/') {
10463     char *cp2;
10464     for (cp2 = resspec;
10465          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10466          rest++, cp2++) *cp2 = *rest;
10467     *cp2 = '\0';
10468     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10469       s = vmsspec;
10470
10471       /* When a UNIX spec with no file type is translated to VMS, */
10472       /* A trailing '.' is appended under ODS-5 rules.            */
10473       /* Here we do not want that trailing "." as it prevents     */
10474       /* Looking for a implied ".exe" type. */
10475       if (decc_efs_charset) {
10476           int i;
10477           i = strlen(vmsspec);
10478           if (vmsspec[i-1] == '.') {
10479               vmsspec[i-1] = '\0';
10480           }
10481       }
10482
10483       if (*rest) {
10484         for (cp2 = vmsspec + strlen(vmsspec);
10485              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10486              rest++, cp2++) *cp2 = *rest;
10487         *cp2 = '\0';
10488       }
10489     }
10490   }
10491   /* Intuit whether verb (first word of cmd) is a DCL command:
10492    *   - if first nonspace char is '@', it's a DCL indirection
10493    * otherwise
10494    *   - if verb contains a filespec separator, it's not a DCL command
10495    *   - if it doesn't, caller tells us whether to default to a DCL
10496    *     command, or to a local image unless told it's DCL (by leading '$')
10497    */
10498   if (*s == '@') {
10499       isdcl = 1;
10500       if (suggest_quote) *suggest_quote = 1;
10501   } else {
10502     register char *filespec = strpbrk(s,":<[.;");
10503     rest = wordbreak = strpbrk(s," \"\t/");
10504     if (!wordbreak) wordbreak = s + strlen(s);
10505     if (*s == '$') check_img = 0;
10506     if (filespec && (filespec < wordbreak)) isdcl = 0;
10507     else isdcl = !check_img;
10508   }
10509
10510   if (!isdcl) {
10511     int rsts;
10512     imgdsc.dsc$a_pointer = s;
10513     imgdsc.dsc$w_length = wordbreak - s;
10514     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10515     if (!(retsts&1)) {
10516         _ckvmssts_noperl(lib$find_file_end(&cxt));
10517         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10518       if (!(retsts & 1) && *s == '$') {
10519         _ckvmssts_noperl(lib$find_file_end(&cxt));
10520         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10521         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10522         if (!(retsts&1)) {
10523           _ckvmssts_noperl(lib$find_file_end(&cxt));
10524           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10525         }
10526       }
10527     }
10528     _ckvmssts_noperl(lib$find_file_end(&cxt));
10529
10530     if (retsts & 1) {
10531       FILE *fp;
10532       s = resspec;
10533       while (*s && !isspace(*s)) s++;
10534       *s = '\0';
10535
10536       /* check that it's really not DCL with no file extension */
10537       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10538       if (fp) {
10539         char b[256] = {0,0,0,0};
10540         read(fileno(fp), b, 256);
10541         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10542         if (isdcl) {
10543           int shebang_len;
10544
10545           /* Check for script */
10546           shebang_len = 0;
10547           if ((b[0] == '#') && (b[1] == '!'))
10548              shebang_len = 2;
10549 #ifdef ALTERNATE_SHEBANG
10550           else {
10551             shebang_len = strlen(ALTERNATE_SHEBANG);
10552             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10553               char * perlstr;
10554                 perlstr = strstr("perl",b);
10555                 if (perlstr == NULL)
10556                   shebang_len = 0;
10557             }
10558             else
10559               shebang_len = 0;
10560           }
10561 #endif
10562
10563           if (shebang_len > 0) {
10564           int i;
10565           int j;
10566           char tmpspec[NAM$C_MAXRSS + 1];
10567
10568             i = shebang_len;
10569              /* Image is following after white space */
10570             /*--------------------------------------*/
10571             while (isprint(b[i]) && isspace(b[i]))
10572                 i++;
10573
10574             j = 0;
10575             while (isprint(b[i]) && !isspace(b[i])) {
10576                 tmpspec[j++] = b[i++];
10577                 if (j >= NAM$C_MAXRSS)
10578                    break;
10579             }
10580             tmpspec[j] = '\0';
10581
10582              /* There may be some default parameters to the image */
10583             /*---------------------------------------------------*/
10584             j = 0;
10585             while (isprint(b[i])) {
10586                 image_argv[j++] = b[i++];
10587                 if (j >= NAM$C_MAXRSS)
10588                    break;
10589             }
10590             while ((j > 0) && !isprint(image_argv[j-1]))
10591                 j--;
10592             image_argv[j] = 0;
10593
10594             /* It will need to be converted to VMS format and validated */
10595             if (tmpspec[0] != '\0') {
10596               char * iname;
10597
10598                /* Try to find the exact program requested to be run */
10599               /*---------------------------------------------------*/
10600               iname = int_rmsexpand
10601                  (tmpspec, image_name, ".exe",
10602                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10603               if (iname != NULL) {
10604                 if (cando_by_name_int
10605                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10606                   /* MCR prefix needed */
10607                   isdcl = 0;
10608                 }
10609                 else {
10610                    /* Try again with a null type */
10611                   /*----------------------------*/
10612                   iname = int_rmsexpand
10613                     (tmpspec, image_name, ".",
10614                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10615                   if (iname != NULL) {
10616                     if (cando_by_name_int
10617                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10618                       /* MCR prefix needed */
10619                       isdcl = 0;
10620                     }
10621                   }
10622                 }
10623
10624                  /* Did we find the image to run the script? */
10625                 /*------------------------------------------*/
10626                 if (isdcl) {
10627                   char *tchr;
10628
10629                    /* Assume DCL or foreign command exists */
10630                   /*--------------------------------------*/
10631                   tchr = strrchr(tmpspec, '/');
10632                   if (tchr != NULL) {
10633                     tchr++;
10634                   }
10635                   else {
10636                     tchr = tmpspec;
10637                   }
10638                   my_strlcpy(image_name, tchr, sizeof(image_name));
10639                 }
10640               }
10641             }
10642           }
10643         }
10644         fclose(fp);
10645       }
10646       if (check_img && isdcl) {
10647           PerlMem_free(cmd);
10648           PerlMem_free(resspec);
10649           PerlMem_free(vmsspec);
10650           return RMS$_FNF;
10651       }
10652
10653       if (cando_by_name(S_IXUSR,0,resspec)) {
10654         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10655         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10656         if (!isdcl) {
10657             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10658             if (image_name[0] != 0) {
10659                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10660                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10661             }
10662         } else if (image_name[0] != 0) {
10663             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10664             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10665         } else {
10666             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10667         }
10668         if (suggest_quote) *suggest_quote = 1;
10669
10670         /* If there is an image name, use original command */
10671         if (image_name[0] == 0)
10672             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10673         else {
10674             rest = cmd;
10675             while (*rest && isspace(*rest)) rest++;
10676         }
10677
10678         if (image_argv[0] != 0) {
10679           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10680           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10681         }
10682         if (rest) {
10683            int rest_len;
10684            int vmscmd_len;
10685
10686            rest_len = strlen(rest);
10687            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10688            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10689               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10690            else
10691              retsts = CLI$_BUFOVF;
10692         }
10693         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10694         PerlMem_free(cmd);
10695         PerlMem_free(vmsspec);
10696         PerlMem_free(resspec);
10697         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10698       }
10699       else
10700         retsts = RMS$_PRV;
10701     }
10702   }
10703   /* It's either a DCL command or we couldn't find a suitable image */
10704   vmscmd->dsc$w_length = strlen(cmd);
10705
10706   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10707   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10708
10709   PerlMem_free(cmd);
10710   PerlMem_free(resspec);
10711   PerlMem_free(vmsspec);
10712
10713   /* check if it's a symbol (for quoting purposes) */
10714   if (suggest_quote && !*suggest_quote) {
10715     int iss;
10716     char equiv[LNM$C_NAMLENGTH];
10717     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10718     eqvdsc.dsc$a_pointer = equiv;
10719
10720     iss = lib$get_symbol(vmscmd,&eqvdsc);
10721     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10722   }
10723   if (!(retsts & 1)) {
10724     /* just hand off status values likely to be due to user error */
10725     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10726         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10727        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10728     else { _ckvmssts_noperl(retsts); }
10729   }
10730
10731   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10732
10733 }  /* end of setup_cmddsc() */
10734
10735
10736 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10737 bool
10738 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10739 {
10740 bool exec_sts;
10741 char * cmd;
10742
10743   if (sp > mark) {
10744     if (vfork_called) {           /* this follows a vfork - act Unixish */
10745       vfork_called--;
10746       if (vfork_called < 0) {
10747         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10748         vfork_called = 0;
10749       }
10750       else return do_aexec(really,mark,sp);
10751     }
10752                                            /* no vfork - act VMSish */
10753     cmd = setup_argstr(aTHX_ really,mark,sp);
10754     exec_sts = vms_do_exec(cmd);
10755     Safefree(cmd);  /* Clean up from setup_argstr() */
10756     return exec_sts;
10757   }
10758
10759   return FALSE;
10760 }  /* end of vms_do_aexec() */
10761 /*}}}*/
10762
10763 /* {{{bool vms_do_exec(char *cmd) */
10764 bool
10765 Perl_vms_do_exec(pTHX_ const char *cmd)
10766 {
10767   struct dsc$descriptor_s *vmscmd;
10768
10769   if (vfork_called) {             /* this follows a vfork - act Unixish */
10770     vfork_called--;
10771     if (vfork_called < 0) {
10772       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10773       vfork_called = 0;
10774     }
10775     else return do_exec(cmd);
10776   }
10777
10778   {                               /* no vfork - act VMSish */
10779     unsigned long int retsts;
10780
10781     TAINT_ENV();
10782     TAINT_PROPER("exec");
10783     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10784       retsts = lib$do_command(vmscmd);
10785
10786     switch (retsts) {
10787       case RMS$_FNF: case RMS$_DNF:
10788         set_errno(ENOENT); break;
10789       case RMS$_DIR:
10790         set_errno(ENOTDIR); break;
10791       case RMS$_DEV:
10792         set_errno(ENODEV); break;
10793       case RMS$_PRV:
10794         set_errno(EACCES); break;
10795       case RMS$_SYN:
10796         set_errno(EINVAL); break;
10797       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10798         set_errno(E2BIG); break;
10799       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10800         _ckvmssts_noperl(retsts); /* fall through */
10801       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10802         set_errno(EVMSERR);
10803     }
10804     set_vaxc_errno(retsts);
10805     if (ckWARN(WARN_EXEC)) {
10806       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10807              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10808     }
10809     vms_execfree(vmscmd);
10810   }
10811
10812   return FALSE;
10813
10814 }  /* end of vms_do_exec() */
10815 /*}}}*/
10816
10817 int do_spawn2(pTHX_ const char *, int);
10818
10819 int
10820 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10821 {
10822 unsigned long int sts;
10823 char * cmd;
10824 int flags = 0;
10825
10826   if (sp > mark) {
10827
10828     /* We'll copy the (undocumented?) Win32 behavior and allow a
10829      * numeric first argument.  But the only value we'll support
10830      * through do_aspawn is a value of 1, which means spawn without
10831      * waiting for completion -- other values are ignored.
10832      */
10833     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10834         ++mark;
10835         flags = SvIVx(*mark);
10836     }
10837
10838     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10839         flags = CLI$M_NOWAIT;
10840     else
10841         flags = 0;
10842
10843     cmd = setup_argstr(aTHX_ really, mark, sp);
10844     sts = do_spawn2(aTHX_ cmd, flags);
10845     /* pp_sys will clean up cmd */
10846     return sts;
10847   }
10848   return SS$_ABORT;
10849 }  /* end of do_aspawn() */
10850 /*}}}*/
10851
10852
10853 /* {{{int do_spawn(char* cmd) */
10854 int
10855 Perl_do_spawn(pTHX_ char* cmd)
10856 {
10857     PERL_ARGS_ASSERT_DO_SPAWN;
10858
10859     return do_spawn2(aTHX_ cmd, 0);
10860 }
10861 /*}}}*/
10862
10863 /* {{{int do_spawn_nowait(char* cmd) */
10864 int
10865 Perl_do_spawn_nowait(pTHX_ char* cmd)
10866 {
10867     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10868
10869     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10870 }
10871 /*}}}*/
10872
10873 /* {{{int do_spawn2(char *cmd) */
10874 int
10875 do_spawn2(pTHX_ const char *cmd, int flags)
10876 {
10877   unsigned long int sts, substs;
10878
10879   /* The caller of this routine expects to Safefree(PL_Cmd) */
10880   Newx(PL_Cmd,10,char);
10881
10882   TAINT_ENV();
10883   TAINT_PROPER("spawn");
10884   if (!cmd || !*cmd) {
10885     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10886     if (!(sts & 1)) {
10887       switch (sts) {
10888         case RMS$_FNF:  case RMS$_DNF:
10889           set_errno(ENOENT); break;
10890         case RMS$_DIR:
10891           set_errno(ENOTDIR); break;
10892         case RMS$_DEV:
10893           set_errno(ENODEV); break;
10894         case RMS$_PRV:
10895           set_errno(EACCES); break;
10896         case RMS$_SYN:
10897           set_errno(EINVAL); break;
10898         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10899           set_errno(E2BIG); break;
10900         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10901           _ckvmssts_noperl(sts); /* fall through */
10902         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10903           set_errno(EVMSERR);
10904       }
10905       set_vaxc_errno(sts);
10906       if (ckWARN(WARN_EXEC)) {
10907         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10908                     Strerror(errno));
10909       }
10910     }
10911     sts = substs;
10912   }
10913   else {
10914     char mode[3];
10915     PerlIO * fp;
10916     if (flags & CLI$M_NOWAIT)
10917         strcpy(mode, "n");
10918     else
10919         strcpy(mode, "nW");
10920
10921     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10922     if (fp != NULL)
10923       my_pclose(fp);
10924     /* sts will be the pid in the nowait case */
10925   }
10926   return sts;
10927 }  /* end of do_spawn2() */
10928 /*}}}*/
10929
10930
10931 static unsigned int *sockflags, sockflagsize;
10932
10933 /*
10934  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10935  * routines found in some versions of the CRTL can't deal with sockets.
10936  * We don't shim the other file open routines since a socket isn't
10937  * likely to be opened by a name.
10938  */
10939 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10940 FILE *my_fdopen(int fd, const char *mode)
10941 {
10942   FILE *fp = fdopen(fd, mode);
10943
10944   if (fp) {
10945     unsigned int fdoff = fd / sizeof(unsigned int);
10946     Stat_t sbuf; /* native stat; we don't need flex_stat */
10947     if (!sockflagsize || fdoff > sockflagsize) {
10948       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10949       else           Newx  (sockflags,fdoff+2,unsigned int);
10950       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10951       sockflagsize = fdoff + 2;
10952     }
10953     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
10954       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10955   }
10956   return fp;
10957
10958 }
10959 /*}}}*/
10960
10961
10962 /*
10963  * Clear the corresponding bit when the (possibly) socket stream is closed.
10964  * There still a small hole: we miss an implicit close which might occur
10965  * via freopen().  >> Todo
10966  */
10967 /*{{{ int my_fclose(FILE *fp)*/
10968 int my_fclose(FILE *fp) {
10969   if (fp) {
10970     unsigned int fd = fileno(fp);
10971     unsigned int fdoff = fd / sizeof(unsigned int);
10972
10973     if (sockflagsize && fdoff < sockflagsize)
10974       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10975   }
10976   return fclose(fp);
10977 }
10978 /*}}}*/
10979
10980
10981 /*
10982  * A simple fwrite replacement which outputs itmsz*nitm chars without
10983  * introducing record boundaries every itmsz chars.
10984  * We are using fputs, which depends on a terminating null.  We may
10985  * well be writing binary data, so we need to accommodate not only
10986  * data with nulls sprinkled in the middle but also data with no null
10987  * byte at the end.
10988  */
10989 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10990 int
10991 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10992 {
10993   register char *cp, *end, *cpd;
10994   char *data;
10995   register unsigned int fd = fileno(dest);
10996   register unsigned int fdoff = fd / sizeof(unsigned int);
10997   int retval;
10998   int bufsize = itmsz * nitm + 1;
10999
11000   if (fdoff < sockflagsize &&
11001       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11002     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11003     return nitm;
11004   }
11005
11006   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11007   memcpy( data, src, itmsz*nitm );
11008   data[itmsz*nitm] = '\0';
11009
11010   end = data + itmsz * nitm;
11011   retval = (int) nitm; /* on success return # items written */
11012
11013   cpd = data;
11014   while (cpd <= end) {
11015     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11016     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11017     if (cp < end)
11018       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11019     cpd = cp + 1;
11020   }
11021
11022   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11023   return retval;
11024
11025 }  /* end of my_fwrite() */
11026 /*}}}*/
11027
11028 /*{{{ int my_flush(FILE *fp)*/
11029 int
11030 Perl_my_flush(pTHX_ FILE *fp)
11031 {
11032     int res;
11033     if ((res = fflush(fp)) == 0 && fp) {
11034 #ifdef VMS_DO_SOCKETS
11035         Stat_t s;
11036         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11037 #endif
11038             res = fsync(fileno(fp));
11039     }
11040 /*
11041  * If the flush succeeded but set end-of-file, we need to clear
11042  * the error because our caller may check ferror().  BTW, this
11043  * probably means we just flushed an empty file.
11044  */
11045     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11046
11047     return res;
11048 }
11049 /*}}}*/
11050
11051 /* fgetname() is not returning the correct file specifications when
11052  * decc_filename_unix_report mode is active.  So we have to have it
11053  * aways return filenames in VMS mode and convert it ourselves.
11054  */
11055
11056 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11057 char *
11058 Perl_my_fgetname(FILE *fp, char * buf) {
11059     char * retname;
11060     char * vms_name;
11061
11062     retname = fgetname(fp, buf, 1);
11063
11064     /* If we are in VMS mode, then we are done */
11065     if (!decc_filename_unix_report || (retname == NULL)) {
11066        return retname;
11067     }
11068
11069     /* Convert this to Unix format */
11070     vms_name = PerlMem_malloc(VMS_MAXRSS);
11071     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11072     retname = int_tounixspec(vms_name, buf, NULL);
11073     PerlMem_free(vms_name);
11074
11075     return retname;
11076 }
11077 /*}}}*/
11078
11079 /*
11080  * Here are replacements for the following Unix routines in the VMS environment:
11081  *      getpwuid    Get information for a particular UIC or UID
11082  *      getpwnam    Get information for a named user
11083  *      getpwent    Get information for each user in the rights database
11084  *      setpwent    Reset search to the start of the rights database
11085  *      endpwent    Finish searching for users in the rights database
11086  *
11087  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11088  * (defined in pwd.h), which contains the following fields:-
11089  *      struct passwd {
11090  *              char        *pw_name;    Username (in lower case)
11091  *              char        *pw_passwd;  Hashed password
11092  *              unsigned int pw_uid;     UIC
11093  *              unsigned int pw_gid;     UIC group  number
11094  *              char        *pw_unixdir; Default device/directory (VMS-style)
11095  *              char        *pw_gecos;   Owner name
11096  *              char        *pw_dir;     Default device/directory (Unix-style)
11097  *              char        *pw_shell;   Default CLI name (eg. DCL)
11098  *      };
11099  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11100  *
11101  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11102  * not the UIC member number (eg. what's returned by getuid()),
11103  * getpwuid() can accept either as input (if uid is specified, the caller's
11104  * UIC group is used), though it won't recognise gid=0.
11105  *
11106  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11107  * information about other users in your group or in other groups, respectively.
11108  * If the required privilege is not available, then these routines fill only
11109  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11110  * string).
11111  *
11112  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11113  */
11114
11115 /* sizes of various UAF record fields */
11116 #define UAI$S_USERNAME 12
11117 #define UAI$S_IDENT    31
11118 #define UAI$S_OWNER    31
11119 #define UAI$S_DEFDEV   31
11120 #define UAI$S_DEFDIR   63
11121 #define UAI$S_DEFCLI   31
11122 #define UAI$S_PWD       8
11123
11124 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11125                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11126                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11127
11128 static char __empty[]= "";
11129 static struct passwd __passwd_empty=
11130     {(char *) __empty, (char *) __empty, 0, 0,
11131      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11132 static int contxt= 0;
11133 static struct passwd __pwdcache;
11134 static char __pw_namecache[UAI$S_IDENT+1];
11135
11136 /*
11137  * This routine does most of the work extracting the user information.
11138  */
11139 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11140 {
11141     static struct {
11142         unsigned char length;
11143         char pw_gecos[UAI$S_OWNER+1];
11144     } owner;
11145     static union uicdef uic;
11146     static struct {
11147         unsigned char length;
11148         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11149     } defdev;
11150     static struct {
11151         unsigned char length;
11152         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11153     } defdir;
11154     static struct {
11155         unsigned char length;
11156         char pw_shell[UAI$S_DEFCLI+1];
11157     } defcli;
11158     static char pw_passwd[UAI$S_PWD+1];
11159
11160     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11161     struct dsc$descriptor_s name_desc;
11162     unsigned long int sts;
11163
11164     static struct itmlst_3 itmlst[]= {
11165         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11166         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11167         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11168         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11169         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11170         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11171         {0,                0,           NULL,    NULL}};
11172
11173     name_desc.dsc$w_length=  strlen(name);
11174     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11175     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11176     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11177
11178 /*  Note that sys$getuai returns many fields as counted strings. */
11179     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11180     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11181       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11182     }
11183     else { _ckvmssts(sts); }
11184     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11185
11186     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11187     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11188     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11189     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11190     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11191     owner.pw_gecos[lowner]=            '\0';
11192     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11193     defcli.pw_shell[ldefcli]=          '\0';
11194     if (valid_uic(uic)) {
11195         pwd->pw_uid= uic.uic$l_uic;
11196         pwd->pw_gid= uic.uic$v_group;
11197     }
11198     else
11199       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11200     pwd->pw_passwd=  pw_passwd;
11201     pwd->pw_gecos=   owner.pw_gecos;
11202     pwd->pw_dir=     defdev.pw_dir;
11203     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11204     pwd->pw_shell=   defcli.pw_shell;
11205     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11206         int ldir;
11207         ldir= strlen(pwd->pw_unixdir) - 1;
11208         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11209     }
11210     else
11211         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11212     if (!decc_efs_case_preserve)
11213         __mystrtolower(pwd->pw_unixdir);
11214     return 1;
11215 }
11216
11217 /*
11218  * Get information for a named user.
11219 */
11220 /*{{{struct passwd *getpwnam(char *name)*/
11221 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11222 {
11223     struct dsc$descriptor_s name_desc;
11224     union uicdef uic;
11225     unsigned long int sts;
11226
11227     __pwdcache = __passwd_empty;
11228     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11229       /* We still may be able to determine pw_uid and pw_gid */
11230       name_desc.dsc$w_length=  strlen(name);
11231       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11232       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11233       name_desc.dsc$a_pointer= (char *) name;
11234       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11235         __pwdcache.pw_uid= uic.uic$l_uic;
11236         __pwdcache.pw_gid= uic.uic$v_group;
11237       }
11238       else {
11239         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11240           set_vaxc_errno(sts);
11241           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11242           return NULL;
11243         }
11244         else { _ckvmssts(sts); }
11245       }
11246     }
11247     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11248     __pwdcache.pw_name= __pw_namecache;
11249     return &__pwdcache;
11250 }  /* end of my_getpwnam() */
11251 /*}}}*/
11252
11253 /*
11254  * Get information for a particular UIC or UID.
11255  * Called by my_getpwent with uid=-1 to list all users.
11256 */
11257 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11258 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11259 {
11260     const $DESCRIPTOR(name_desc,__pw_namecache);
11261     unsigned short lname;
11262     union uicdef uic;
11263     unsigned long int status;
11264
11265     if (uid == (unsigned int) -1) {
11266       do {
11267         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11268         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11269           set_vaxc_errno(status);
11270           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11271           my_endpwent();
11272           return NULL;
11273         }
11274         else { _ckvmssts(status); }
11275       } while (!valid_uic (uic));
11276     }
11277     else {
11278       uic.uic$l_uic= uid;
11279       if (!uic.uic$v_group)
11280         uic.uic$v_group= PerlProc_getgid();
11281       if (valid_uic(uic))
11282         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11283       else status = SS$_IVIDENT;
11284       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11285           status == RMS$_PRV) {
11286         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11287         return NULL;
11288       }
11289       else { _ckvmssts(status); }
11290     }
11291     __pw_namecache[lname]= '\0';
11292     __mystrtolower(__pw_namecache);
11293
11294     __pwdcache = __passwd_empty;
11295     __pwdcache.pw_name = __pw_namecache;
11296
11297 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11298     The identifier's value is usually the UIC, but it doesn't have to be,
11299     so if we can, we let fillpasswd update this. */
11300     __pwdcache.pw_uid =  uic.uic$l_uic;
11301     __pwdcache.pw_gid =  uic.uic$v_group;
11302
11303     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11304     return &__pwdcache;
11305
11306 }  /* end of my_getpwuid() */
11307 /*}}}*/
11308
11309 /*
11310  * Get information for next user.
11311 */
11312 /*{{{struct passwd *my_getpwent()*/
11313 struct passwd *Perl_my_getpwent(pTHX)
11314 {
11315     return (my_getpwuid((unsigned int) -1));
11316 }
11317 /*}}}*/
11318
11319 /*
11320  * Finish searching rights database for users.
11321 */
11322 /*{{{void my_endpwent()*/
11323 void Perl_my_endpwent(pTHX)
11324 {
11325     if (contxt) {
11326       _ckvmssts(sys$finish_rdb(&contxt));
11327       contxt= 0;
11328     }
11329 }
11330 /*}}}*/
11331
11332 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11333  * my_utime(), and flex_stat(), all of which operate on UTC unless
11334  * VMSISH_TIMES is true.
11335  */
11336 /* method used to handle UTC conversions:
11337  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11338  */
11339 static int gmtime_emulation_type;
11340 /* number of secs to add to UTC POSIX-style time to get local time */
11341 static long int utc_offset_secs;
11342
11343 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11344  * in vmsish.h.  #undef them here so we can call the CRTL routines
11345  * directly.
11346  */
11347 #undef gmtime
11348 #undef localtime
11349 #undef time
11350
11351
11352 static time_t toutc_dst(time_t loc) {
11353   struct tm *rsltmp;
11354
11355   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11356   loc -= utc_offset_secs;
11357   if (rsltmp->tm_isdst) loc -= 3600;
11358   return loc;
11359 }
11360 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11361        ((gmtime_emulation_type || my_time(NULL)), \
11362        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11363        ((secs) - utc_offset_secs))))
11364
11365 static time_t toloc_dst(time_t utc) {
11366   struct tm *rsltmp;
11367
11368   utc += utc_offset_secs;
11369   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11370   if (rsltmp->tm_isdst) utc += 3600;
11371   return utc;
11372 }
11373 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11374        ((gmtime_emulation_type || my_time(NULL)), \
11375        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11376        ((secs) + utc_offset_secs))))
11377
11378 /* my_time(), my_localtime(), my_gmtime()
11379  * By default traffic in UTC time values, using CRTL gmtime() or
11380  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11381  * Note: We need to use these functions even when the CRTL has working
11382  * UTC support, since they also handle C<use vmsish qw(times);>
11383  *
11384  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11385  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11386  */
11387
11388 /*{{{time_t my_time(time_t *timep)*/
11389 time_t Perl_my_time(pTHX_ time_t *timep)
11390 {
11391   time_t when;
11392   struct tm *tm_p;
11393
11394   if (gmtime_emulation_type == 0) {
11395     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11396                               /* results of calls to gmtime() and localtime() */
11397                               /* for same &base */
11398
11399     gmtime_emulation_type++;
11400     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11401       char off[LNM$C_NAMLENGTH+1];;
11402
11403       gmtime_emulation_type++;
11404       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11405         gmtime_emulation_type++;
11406         utc_offset_secs = 0;
11407         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11408       }
11409       else { utc_offset_secs = atol(off); }
11410     }
11411     else { /* We've got a working gmtime() */
11412       struct tm gmt, local;
11413
11414       gmt = *tm_p;
11415       tm_p = localtime(&base);
11416       local = *tm_p;
11417       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11418       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11419       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11420       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11421     }
11422   }
11423
11424   when = time(NULL);
11425 # ifdef VMSISH_TIME
11426   if (VMSISH_TIME) when = _toloc(when);
11427 # endif
11428   if (timep != NULL) *timep = when;
11429   return when;
11430
11431 }  /* end of my_time() */
11432 /*}}}*/
11433
11434
11435 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11436 struct tm *
11437 Perl_my_gmtime(pTHX_ const time_t *timep)
11438 {
11439   time_t when;
11440   struct tm *rsltmp;
11441
11442   if (timep == NULL) {
11443     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11444     return NULL;
11445   }
11446   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11447
11448   when = *timep;
11449 # ifdef VMSISH_TIME
11450   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11451 #  endif
11452   return gmtime(&when);
11453 }  /* end of my_gmtime() */
11454 /*}}}*/
11455
11456
11457 /*{{{struct tm *my_localtime(const time_t *timep)*/
11458 struct tm *
11459 Perl_my_localtime(pTHX_ const time_t *timep)
11460 {
11461   time_t when, whenutc;
11462   struct tm *rsltmp;
11463   int dst, offset;
11464
11465   if (timep == NULL) {
11466     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11467     return NULL;
11468   }
11469   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11470   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11471
11472   when = *timep;
11473 # ifdef VMSISH_TIME
11474   if (VMSISH_TIME) when = _toutc(when);
11475 # endif
11476   /* CRTL localtime() wants UTC as input, does tz correction itself */
11477   return localtime(&when);
11478
11479   /* CRTL localtime() wants local time as input, so does no tz correction */
11480   rsltmp = localtime(&when);
11481   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11482   return rsltmp;
11483
11484 } /*  end of my_localtime() */
11485 /*}}}*/
11486
11487 /* Reset definitions for later calls */
11488 #define gmtime(t)    my_gmtime(t)
11489 #define localtime(t) my_localtime(t)
11490 #define time(t)      my_time(t)
11491
11492
11493 /* my_utime - update modification/access time of a file
11494  *
11495  * VMS 7.3 and later implementation
11496  * Only the UTC translation is home-grown. The rest is handled by the
11497  * CRTL utime(), which will take into account the relevant feature
11498  * logicals and ODS-5 volume characteristics for true access times.
11499  *
11500  * pre VMS 7.3 implementation:
11501  * The calling sequence is identical to POSIX utime(), but under
11502  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11503  * not maintain access times.  Restrictions differ from the POSIX
11504  * definition in that the time can be changed as long as the
11505  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11506  * no separate checks are made to insure that the caller is the
11507  * owner of the file or has special privs enabled.
11508  * Code here is based on Joe Meadows' FILE utility.
11509  *
11510  */
11511
11512 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11513  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11514  * in 100 ns intervals.
11515  */
11516 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11517
11518 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11519 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11520 {
11521 #if __CRTL_VER >= 70300000
11522   struct utimbuf utc_utimes, *utc_utimesp;
11523
11524   if (utimes != NULL) {
11525     utc_utimes.actime = utimes->actime;
11526     utc_utimes.modtime = utimes->modtime;
11527 # ifdef VMSISH_TIME
11528     /* If input was local; convert to UTC for sys svc */
11529     if (VMSISH_TIME) {
11530       utc_utimes.actime = _toutc(utimes->actime);
11531       utc_utimes.modtime = _toutc(utimes->modtime);
11532     }
11533 # endif
11534     utc_utimesp = &utc_utimes;
11535   }
11536   else {
11537     utc_utimesp = NULL;
11538   }
11539
11540   return utime(file, utc_utimesp);
11541
11542 #else /* __CRTL_VER < 70300000 */
11543
11544   register int i;
11545   int sts;
11546   long int bintime[2], len = 2, lowbit, unixtime,
11547            secscale = 10000000; /* seconds --> 100 ns intervals */
11548   unsigned long int chan, iosb[2], retsts;
11549   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11550   struct FAB myfab = cc$rms_fab;
11551   struct NAM mynam = cc$rms_nam;
11552 #if defined (__DECC) && defined (__VAX)
11553   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11554    * at least through VMS V6.1, which causes a type-conversion warning.
11555    */
11556 #  pragma message save
11557 #  pragma message disable cvtdiftypes
11558 #endif
11559   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11560   struct fibdef myfib;
11561 #if defined (__DECC) && defined (__VAX)
11562   /* This should be right after the declaration of myatr, but due
11563    * to a bug in VAX DEC C, this takes effect a statement early.
11564    */
11565 #  pragma message restore
11566 #endif
11567   /* cast ok for read only parameter */
11568   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11569                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11570                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11571
11572   if (file == NULL || *file == '\0') {
11573     SETERRNO(ENOENT, LIB$_INVARG);
11574     return -1;
11575   }
11576
11577   /* Convert to VMS format ensuring that it will fit in 255 characters */
11578   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11579       SETERRNO(ENOENT, LIB$_INVARG);
11580       return -1;
11581   }
11582   if (utimes != NULL) {
11583     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11584      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11585      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11586      * as input, we force the sign bit to be clear by shifting unixtime right
11587      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11588      */
11589     lowbit = (utimes->modtime & 1) ? secscale : 0;
11590     unixtime = (long int) utimes->modtime;
11591 #   ifdef VMSISH_TIME
11592     /* If input was UTC; convert to local for sys svc */
11593     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11594 #   endif
11595     unixtime >>= 1;  secscale <<= 1;
11596     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11597     if (!(retsts & 1)) {
11598       SETERRNO(EVMSERR, retsts);
11599       return -1;
11600     }
11601     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11602     if (!(retsts & 1)) {
11603       SETERRNO(EVMSERR, retsts);
11604       return -1;
11605     }
11606   }
11607   else {
11608     /* Just get the current time in VMS format directly */
11609     retsts = sys$gettim(bintime);
11610     if (!(retsts & 1)) {
11611       SETERRNO(EVMSERR, retsts);
11612       return -1;
11613     }
11614   }
11615
11616   myfab.fab$l_fna = vmsspec;
11617   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11618   myfab.fab$l_nam = &mynam;
11619   mynam.nam$l_esa = esa;
11620   mynam.nam$b_ess = (unsigned char) sizeof esa;
11621   mynam.nam$l_rsa = rsa;
11622   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11623   if (decc_efs_case_preserve)
11624       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11625
11626   /* Look for the file to be affected, letting RMS parse the file
11627    * specification for us as well.  I have set errno using only
11628    * values documented in the utime() man page for VMS POSIX.
11629    */
11630   retsts = sys$parse(&myfab,0,0);
11631   if (!(retsts & 1)) {
11632     set_vaxc_errno(retsts);
11633     if      (retsts == RMS$_PRV) set_errno(EACCES);
11634     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11635     else                         set_errno(EVMSERR);
11636     return -1;
11637   }
11638   retsts = sys$search(&myfab,0,0);
11639   if (!(retsts & 1)) {
11640     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11641     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11642     set_vaxc_errno(retsts);
11643     if      (retsts == RMS$_PRV) set_errno(EACCES);
11644     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11645     else                         set_errno(EVMSERR);
11646     return -1;
11647   }
11648
11649   devdsc.dsc$w_length = mynam.nam$b_dev;
11650   /* cast ok for read only parameter */
11651   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11652
11653   retsts = sys$assign(&devdsc,&chan,0,0);
11654   if (!(retsts & 1)) {
11655     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11656     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11657     set_vaxc_errno(retsts);
11658     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11659     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11660     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11661     else                               set_errno(EVMSERR);
11662     return -1;
11663   }
11664
11665   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11666   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11667
11668   memset((void *) &myfib, 0, sizeof myfib);
11669 #if defined(__DECC) || defined(__DECCXX)
11670   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11671   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11672   /* This prevents the revision time of the file being reset to the current
11673    * time as a result of our IO$_MODIFY $QIO. */
11674   myfib.fib$l_acctl = FIB$M_NORECORD;
11675 #else
11676   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11677   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11678   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11679 #endif
11680   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11681   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11682   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11683   _ckvmssts(sys$dassgn(chan));
11684   if (retsts & 1) retsts = iosb[0];
11685   if (!(retsts & 1)) {
11686     set_vaxc_errno(retsts);
11687     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11688     else                      set_errno(EVMSERR);
11689     return -1;
11690   }
11691
11692   return 0;
11693
11694 #endif /* #if __CRTL_VER >= 70300000 */
11695
11696 }  /* end of my_utime() */
11697 /*}}}*/
11698
11699 /*
11700  * flex_stat, flex_lstat, flex_fstat
11701  * basic stat, but gets it right when asked to stat
11702  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11703  */
11704
11705 #ifndef _USE_STD_STAT
11706 /* encode_dev packs a VMS device name string into an integer to allow
11707  * simple comparisons. This can be used, for example, to check whether two
11708  * files are located on the same device, by comparing their encoded device
11709  * names. Even a string comparison would not do, because stat() reuses the
11710  * device name buffer for each call; so without encode_dev, it would be
11711  * necessary to save the buffer and use strcmp (this would mean a number of
11712  * changes to the standard Perl code, to say nothing of what a Perl script
11713  * would have to do.
11714  *
11715  * The device lock id, if it exists, should be unique (unless perhaps compared
11716  * with lock ids transferred from other nodes). We have a lock id if the disk is
11717  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11718  * device names. Thus we use the lock id in preference, and only if that isn't
11719  * available, do we try to pack the device name into an integer (flagged by
11720  * the sign bit (LOCKID_MASK) being set).
11721  *
11722  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11723  * name and its encoded form, but it seems very unlikely that we will find
11724  * two files on different disks that share the same encoded device names,
11725  * and even more remote that they will share the same file id (if the test
11726  * is to check for the same file).
11727  *
11728  * A better method might be to use sys$device_scan on the first call, and to
11729  * search for the device, returning an index into the cached array.
11730  * The number returned would be more intelligible.
11731  * This is probably not worth it, and anyway would take quite a bit longer
11732  * on the first call.
11733  */
11734 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11735 static mydev_t encode_dev (pTHX_ const char *dev)
11736 {
11737   int i;
11738   unsigned long int f;
11739   mydev_t enc;
11740   char c;
11741   const char *q;
11742
11743   if (!dev || !dev[0]) return 0;
11744
11745 #if LOCKID_MASK
11746   {
11747     struct dsc$descriptor_s dev_desc;
11748     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11749
11750     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11751        can try that first. */
11752     dev_desc.dsc$w_length =  strlen (dev);
11753     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11754     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11755     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11756     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11757     if (!$VMS_STATUS_SUCCESS(status)) {
11758       switch (status) {
11759         case SS$_NOSUCHDEV:
11760           SETERRNO(ENODEV, status);
11761           return 0;
11762         default:
11763           _ckvmssts(status);
11764       }
11765     }
11766     if (lockid) return (lockid & ~LOCKID_MASK);
11767   }
11768 #endif
11769
11770   /* Otherwise we try to encode the device name */
11771   enc = 0;
11772   f = 1;
11773   i = 0;
11774   for (q = dev + strlen(dev); q--; q >= dev) {
11775     if (*q == ':')
11776         break;
11777     if (isdigit (*q))
11778       c= (*q) - '0';
11779     else if (isalpha (toupper (*q)))
11780       c= toupper (*q) - 'A' + (char)10;
11781     else
11782       continue; /* Skip '$'s */
11783     i++;
11784     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11785     if (i>1) f *= 36;
11786     enc += f * (unsigned long int) c;
11787   }
11788   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11789
11790 }  /* end of encode_dev() */
11791 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11792         device_no = encode_dev(aTHX_ devname)
11793 #else
11794 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11795         device_no = new_dev_no
11796 #endif
11797
11798 static int
11799 is_null_device(const char *name)
11800 {
11801   if (decc_bug_devnull != 0) {
11802     if (strncmp("/dev/null", name, 9) == 0)
11803       return 1;
11804   }
11805     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11806        The underscore prefix, controller letter, and unit number are
11807        independently optional; for our purposes, the colon punctuation
11808        is not.  The colon can be trailed by optional directory and/or
11809        filename, but two consecutive colons indicates a nodename rather
11810        than a device.  [pr]  */
11811   if (*name == '_') ++name;
11812   if (tolower(*name++) != 'n') return 0;
11813   if (tolower(*name++) != 'l') return 0;
11814   if (tolower(*name) == 'a') ++name;
11815   if (*name == '0') ++name;
11816   return (*name++ == ':') && (*name != ':');
11817 }
11818
11819 static int
11820 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11821
11822 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11823
11824 static I32
11825 Perl_cando_by_name_int
11826    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11827 {
11828   char usrname[L_cuserid];
11829   struct dsc$descriptor_s usrdsc =
11830          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11831   char *vmsname = NULL, *fileified = NULL;
11832   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11833   unsigned short int retlen, trnlnm_iter_count;
11834   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11835   union prvdef curprv;
11836   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11837          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11838          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11839   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11840          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11841          {0,0,0,0}};
11842   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11843          {0,0,0,0}};
11844   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11845   Stat_t st;
11846   static int profile_context = -1;
11847
11848   if (!fname || !*fname) return FALSE;
11849
11850   /* Make sure we expand logical names, since sys$check_access doesn't */
11851   fileified = PerlMem_malloc(VMS_MAXRSS);
11852   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11853   if (!strpbrk(fname,"/]>:")) {
11854       my_strlcpy(fileified, fname, VMS_MAXRSS);
11855       trnlnm_iter_count = 0;
11856       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11857         trnlnm_iter_count++;
11858         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11859       }
11860       fname = fileified;
11861   }
11862
11863   vmsname = PerlMem_malloc(VMS_MAXRSS);
11864   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11865   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11866     /* Don't know if already in VMS format, so make sure */
11867     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11868       PerlMem_free(fileified);
11869       PerlMem_free(vmsname);
11870       return FALSE;
11871     }
11872   }
11873   else {
11874     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11875   }
11876
11877   /* sys$check_access needs a file spec, not a directory spec.
11878    * flex_stat now will handle a null thread context during startup.
11879    */
11880
11881   retlen = namdsc.dsc$w_length = strlen(vmsname);
11882   if (vmsname[retlen-1] == ']'
11883       || vmsname[retlen-1] == '>'
11884       || vmsname[retlen-1] == ':'
11885       || (!flex_stat_int(vmsname, &st, 1) &&
11886           S_ISDIR(st.st_mode))) {
11887
11888       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11889         PerlMem_free(fileified);
11890         PerlMem_free(vmsname);
11891         return FALSE;
11892       }
11893       fname = fileified;
11894   }
11895   else {
11896       fname = vmsname;
11897   }
11898
11899   retlen = namdsc.dsc$w_length = strlen(fname);
11900   namdsc.dsc$a_pointer = (char *)fname;
11901
11902   switch (bit) {
11903     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11904       access = ARM$M_EXECUTE;
11905       flags = CHP$M_READ;
11906       break;
11907     case S_IRUSR: case S_IRGRP: case S_IROTH:
11908       access = ARM$M_READ;
11909       flags = CHP$M_READ | CHP$M_USEREADALL;
11910       break;
11911     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11912       access = ARM$M_WRITE;
11913       flags = CHP$M_READ | CHP$M_WRITE;
11914       break;
11915     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11916       access = ARM$M_DELETE;
11917       flags = CHP$M_READ | CHP$M_WRITE;
11918       break;
11919     default:
11920       if (fileified != NULL)
11921         PerlMem_free(fileified);
11922       if (vmsname != NULL)
11923         PerlMem_free(vmsname);
11924       return FALSE;
11925   }
11926
11927   /* Before we call $check_access, create a user profile with the current
11928    * process privs since otherwise it just uses the default privs from the
11929    * UAF and might give false positives or negatives.  This only works on
11930    * VMS versions v6.0 and later since that's when sys$create_user_profile
11931    * became available.
11932    */
11933
11934   /* get current process privs and username */
11935   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11936   _ckvmssts_noperl(iosb[0]);
11937
11938   /* find out the space required for the profile */
11939   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11940                                     &usrprodsc.dsc$w_length,&profile_context));
11941
11942   /* allocate space for the profile and get it filled in */
11943   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11944   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11945   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11946                                     &usrprodsc.dsc$w_length,&profile_context));
11947
11948   /* use the profile to check access to the file; free profile & analyze results */
11949   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11950   PerlMem_free(usrprodsc.dsc$a_pointer);
11951   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11952
11953   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11954       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11955       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11956     set_vaxc_errno(retsts);
11957     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11958     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11959     else set_errno(ENOENT);
11960     if (fileified != NULL)
11961       PerlMem_free(fileified);
11962     if (vmsname != NULL)
11963       PerlMem_free(vmsname);
11964     return FALSE;
11965   }
11966   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11967     if (fileified != NULL)
11968       PerlMem_free(fileified);
11969     if (vmsname != NULL)
11970       PerlMem_free(vmsname);
11971     return TRUE;
11972   }
11973   _ckvmssts_noperl(retsts);
11974
11975   if (fileified != NULL)
11976     PerlMem_free(fileified);
11977   if (vmsname != NULL)
11978     PerlMem_free(vmsname);
11979   return FALSE;  /* Should never get here */
11980
11981 }
11982
11983 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11984 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11985  * subset of the applicable information.
11986  */
11987 bool
11988 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11989 {
11990   return cando_by_name_int
11991         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11992 }  /* end of cando() */
11993 /*}}}*/
11994
11995
11996 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11997 I32
11998 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11999 {
12000    return cando_by_name_int(bit, effective, fname, 0);
12001
12002 }  /* end of cando_by_name() */
12003 /*}}}*/
12004
12005
12006 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12007 int
12008 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12009 {
12010   if (!fstat(fd, &statbufp->crtl_stat)) {
12011     char *cptr;
12012     char *vms_filename;
12013     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12014     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12015
12016     /* Save name for cando by name in VMS format */
12017     cptr = getname(fd, vms_filename, 1);
12018
12019     /* This should not happen, but just in case */
12020     if (cptr == NULL) {
12021         statbufp->st_devnam[0] = 0;
12022     }
12023     else {
12024         /* Make sure that the saved name fits in 255 characters */
12025         cptr = int_rmsexpand_vms
12026                        (vms_filename,
12027                         statbufp->st_devnam,
12028                         0);
12029         if (cptr == NULL)
12030             statbufp->st_devnam[0] = 0;
12031     }
12032     PerlMem_free(vms_filename);
12033
12034     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12035     VMS_DEVICE_ENCODE
12036         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12037
12038 #   ifdef VMSISH_TIME
12039     if (VMSISH_TIME) {
12040       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12041       statbufp->st_atime = _toloc(statbufp->st_atime);
12042       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12043     }
12044 #   endif
12045     return 0;
12046   }
12047   return -1;
12048
12049 }  /* end of flex_fstat() */
12050 /*}}}*/
12051
12052 static int
12053 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12054 {
12055     char *temp_fspec = NULL;
12056     char *fileified = NULL;
12057     const char *save_spec;
12058     char *ret_spec;
12059     int retval = -1;
12060     char efs_hack = 0;
12061     char already_fileified = 0;
12062     dSAVEDERRNO;
12063
12064     if (!fspec) {
12065         errno = EINVAL;
12066         return retval;
12067     }
12068
12069     if (decc_bug_devnull != 0) {
12070       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12071         memset(statbufp,0,sizeof *statbufp);
12072         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12073         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12074         statbufp->st_uid = 0x00010001;
12075         statbufp->st_gid = 0x0001;
12076         time((time_t *)&statbufp->st_mtime);
12077         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12078         return 0;
12079       }
12080     }
12081
12082     SAVE_ERRNO;
12083
12084 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12085   /*
12086    * If we are in POSIX filespec mode, accept the filename as is.
12087    */
12088   if (decc_posix_compliant_pathnames == 0) {
12089 #endif
12090
12091     /* Try for a simple stat first.  If fspec contains a filename without
12092      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12093      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12094      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12095      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12096      * the file with null type, specify this by calling flex_stat() with
12097      * a '.' at the end of fspec.
12098      */
12099
12100     if (lstat_flag == 0)
12101         retval = stat(fspec, &statbufp->crtl_stat);
12102     else
12103         retval = lstat(fspec, &statbufp->crtl_stat);
12104
12105     if (!retval) {
12106         save_spec = fspec;
12107     }
12108     else {
12109         /* In the odd case where we have write but not read access
12110          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12111          */
12112         fileified = PerlMem_malloc(VMS_MAXRSS);
12113         if (fileified == NULL)
12114               _ckvmssts_noperl(SS$_INSFMEM);
12115
12116         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12117         if (ret_spec != NULL) {
12118             if (lstat_flag == 0)
12119                 retval = stat(fileified, &statbufp->crtl_stat);
12120             else
12121                 retval = lstat(fileified, &statbufp->crtl_stat);
12122             save_spec = fileified;
12123             already_fileified = 1;
12124         }
12125     }
12126
12127     if (retval && vms_bug_stat_filename) {
12128
12129         temp_fspec = PerlMem_malloc(VMS_MAXRSS);
12130         if (temp_fspec == NULL)
12131             _ckvmssts_noperl(SS$_INSFMEM);
12132
12133         /* We should try again as a vmsified file specification. */
12134
12135         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12136         if (ret_spec != NULL) {
12137             if (lstat_flag == 0)
12138                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12139             else
12140                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12141             save_spec = temp_fspec;
12142         }
12143     }
12144
12145     if (retval) {
12146         /* Last chance - allow multiple dots without EFS CHARSET */
12147         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12148          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12149          * enable it if it isn't already.
12150          */
12151 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12152         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12153             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12154 #endif
12155         if (lstat_flag == 0)
12156             retval = stat(fspec, &statbufp->crtl_stat);
12157         else
12158             retval = lstat(fspec, &statbufp->crtl_stat);
12159         save_spec = fspec;
12160 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12161         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12162             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12163             efs_hack = 1;
12164         }
12165 #endif
12166     }
12167
12168 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12169   } else {
12170     if (lstat_flag == 0)
12171       retval = stat(temp_fspec, &statbufp->crtl_stat);
12172     else
12173       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12174       save_spec = temp_fspec;
12175   }
12176 #endif
12177
12178 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12179   /* As you were... */
12180   if (!decc_efs_charset)
12181     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12182 #endif
12183
12184     if (!retval) {
12185       char *cptr;
12186       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12187
12188       /* If this is an lstat, do not follow the link */
12189       if (lstat_flag)
12190         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12191
12192 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12193       /* If we used the efs_hack above, we must also use it here for */
12194       /* perl_cando to work */
12195       if (efs_hack && (decc_efs_charset_index > 0)) {
12196           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12197       }
12198 #endif
12199
12200       /* If we've got a directory, save a fileified, expanded version of it
12201        * in st_devnam.  If not a directory, just an expanded version.
12202        */
12203       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12204           fileified = PerlMem_malloc(VMS_MAXRSS);
12205           if (fileified == NULL)
12206               _ckvmssts_noperl(SS$_INSFMEM);
12207
12208           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12209           if (cptr != NULL)
12210               save_spec = fileified;
12211       }
12212
12213       cptr = int_rmsexpand(save_spec,
12214                            statbufp->st_devnam,
12215                            NULL,
12216                            rmsex_flags,
12217                            0,
12218                            0);
12219
12220 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12221       if (efs_hack && (decc_efs_charset_index > 0)) {
12222           decc$feature_set_value(decc_efs_charset, 1, 0);
12223       }
12224 #endif
12225
12226       /* Fix me: If this is NULL then stat found a file, and we could */
12227       /* not convert the specification to VMS - Should never happen */
12228       if (cptr == NULL)
12229         statbufp->st_devnam[0] = 0;
12230
12231       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12232       VMS_DEVICE_ENCODE
12233         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12234 #     ifdef VMSISH_TIME
12235       if (VMSISH_TIME) {
12236         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12237         statbufp->st_atime = _toloc(statbufp->st_atime);
12238         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12239       }
12240 #     endif
12241     }
12242     /* If we were successful, leave errno where we found it */
12243     if (retval == 0) RESTORE_ERRNO;
12244     if (temp_fspec)
12245         PerlMem_free(temp_fspec);
12246     if (fileified)
12247         PerlMem_free(fileified);
12248     return retval;
12249
12250 }  /* end of flex_stat_int() */
12251
12252
12253 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12254 int
12255 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12256 {
12257    return flex_stat_int(fspec, statbufp, 0);
12258 }
12259 /*}}}*/
12260
12261 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12262 int
12263 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12264 {
12265    return flex_stat_int(fspec, statbufp, 1);
12266 }
12267 /*}}}*/
12268
12269
12270 /*{{{char *my_getlogin()*/
12271 /* VMS cuserid == Unix getlogin, except calling sequence */
12272 char *
12273 my_getlogin(void)
12274 {
12275     static char user[L_cuserid];
12276     return cuserid(user);
12277 }
12278 /*}}}*/
12279
12280
12281 /*  rmscopy - copy a file using VMS RMS routines
12282  *
12283  *  Copies contents and attributes of spec_in to spec_out, except owner
12284  *  and protection information.  Name and type of spec_in are used as
12285  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12286  *  should try to propagate timestamps from the input file to the output file.
12287  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12288  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12289  *  propagated to the output file at creation iff the output file specification
12290  *  did not contain an explicit name or type, and the revision date is always
12291  *  updated at the end of the copy operation.  If it is greater than 0, then
12292  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12293  *  other than the revision date should be propagated, and bit 1 indicates
12294  *  that the revision date should be propagated.
12295  *
12296  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12297  *
12298  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12299  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12300  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12301  * as part of the Perl standard distribution under the terms of the
12302  * GNU General Public License or the Perl Artistic License.  Copies
12303  * of each may be found in the Perl standard distribution.
12304  */ /* FIXME */
12305 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12306 int
12307 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12308 {
12309     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12310          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12311     unsigned long int sts;
12312     int dna_len;
12313     struct FAB fab_in, fab_out;
12314     struct RAB rab_in, rab_out;
12315     rms_setup_nam(nam);
12316     rms_setup_nam(nam_out);
12317     struct XABDAT xabdat;
12318     struct XABFHC xabfhc;
12319     struct XABRDT xabrdt;
12320     struct XABSUM xabsum;
12321
12322     vmsin = PerlMem_malloc(VMS_MAXRSS);
12323     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12324     vmsout = PerlMem_malloc(VMS_MAXRSS);
12325     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12326     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12327         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12328       PerlMem_free(vmsin);
12329       PerlMem_free(vmsout);
12330       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12331       return 0;
12332     }
12333
12334     esa = PerlMem_malloc(VMS_MAXRSS);
12335     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12336     esal = NULL;
12337 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12338     esal = PerlMem_malloc(VMS_MAXRSS);
12339     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12340 #endif
12341     fab_in = cc$rms_fab;
12342     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12343     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12344     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12345     fab_in.fab$l_fop = FAB$M_SQO;
12346     rms_bind_fab_nam(fab_in, nam);
12347     fab_in.fab$l_xab = (void *) &xabdat;
12348
12349     rsa = PerlMem_malloc(VMS_MAXRSS);
12350     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12351     rsal = NULL;
12352 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12353     rsal = PerlMem_malloc(VMS_MAXRSS);
12354     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12355 #endif
12356     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12357     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12358     rms_nam_esl(nam) = 0;
12359     rms_nam_rsl(nam) = 0;
12360     rms_nam_esll(nam) = 0;
12361     rms_nam_rsll(nam) = 0;
12362 #ifdef NAM$M_NO_SHORT_UPCASE
12363     if (decc_efs_case_preserve)
12364         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12365 #endif
12366
12367     xabdat = cc$rms_xabdat;        /* To get creation date */
12368     xabdat.xab$l_nxt = (void *) &xabfhc;
12369
12370     xabfhc = cc$rms_xabfhc;        /* To get record length */
12371     xabfhc.xab$l_nxt = (void *) &xabsum;
12372
12373     xabsum = cc$rms_xabsum;        /* To get key and area information */
12374
12375     if (!((sts = sys$open(&fab_in)) & 1)) {
12376       PerlMem_free(vmsin);
12377       PerlMem_free(vmsout);
12378       PerlMem_free(esa);
12379       if (esal != NULL)
12380         PerlMem_free(esal);
12381       PerlMem_free(rsa);
12382       if (rsal != NULL)
12383         PerlMem_free(rsal);
12384       set_vaxc_errno(sts);
12385       switch (sts) {
12386         case RMS$_FNF: case RMS$_DNF:
12387           set_errno(ENOENT); break;
12388         case RMS$_DIR:
12389           set_errno(ENOTDIR); break;
12390         case RMS$_DEV:
12391           set_errno(ENODEV); break;
12392         case RMS$_SYN:
12393           set_errno(EINVAL); break;
12394         case RMS$_PRV:
12395           set_errno(EACCES); break;
12396         default:
12397           set_errno(EVMSERR);
12398       }
12399       return 0;
12400     }
12401
12402     nam_out = nam;
12403     fab_out = fab_in;
12404     fab_out.fab$w_ifi = 0;
12405     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12406     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12407     fab_out.fab$l_fop = FAB$M_SQO;
12408     rms_bind_fab_nam(fab_out, nam_out);
12409     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12410     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12411     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12412     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12413     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12414     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12415     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12416     esal_out = NULL;
12417     rsal_out = NULL;
12418 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12419     esal_out = PerlMem_malloc(VMS_MAXRSS);
12420     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12421     rsal_out = PerlMem_malloc(VMS_MAXRSS);
12422     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12423 #endif
12424     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12425     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12426
12427     if (preserve_dates == 0) {  /* Act like DCL COPY */
12428       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12429       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12430       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12431         PerlMem_free(vmsin);
12432         PerlMem_free(vmsout);
12433         PerlMem_free(esa);
12434         if (esal != NULL)
12435             PerlMem_free(esal);
12436         PerlMem_free(rsa);
12437         if (rsal != NULL)
12438             PerlMem_free(rsal);
12439         PerlMem_free(esa_out);
12440         if (esal_out != NULL)
12441             PerlMem_free(esal_out);
12442         PerlMem_free(rsa_out);
12443         if (rsal_out != NULL)
12444             PerlMem_free(rsal_out);
12445         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12446         set_vaxc_errno(sts);
12447         return 0;
12448       }
12449       fab_out.fab$l_xab = (void *) &xabdat;
12450       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12451         preserve_dates = 1;
12452     }
12453     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12454       preserve_dates =0;      /* bitmask from this point forward   */
12455
12456     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12457     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12458       PerlMem_free(vmsin);
12459       PerlMem_free(vmsout);
12460       PerlMem_free(esa);
12461       if (esal != NULL)
12462           PerlMem_free(esal);
12463       PerlMem_free(rsa);
12464       if (rsal != NULL)
12465           PerlMem_free(rsal);
12466       PerlMem_free(esa_out);
12467       if (esal_out != NULL)
12468           PerlMem_free(esal_out);
12469       PerlMem_free(rsa_out);
12470       if (rsal_out != NULL)
12471           PerlMem_free(rsal_out);
12472       set_vaxc_errno(sts);
12473       switch (sts) {
12474         case RMS$_DNF:
12475           set_errno(ENOENT); break;
12476         case RMS$_DIR:
12477           set_errno(ENOTDIR); break;
12478         case RMS$_DEV:
12479           set_errno(ENODEV); break;
12480         case RMS$_SYN:
12481           set_errno(EINVAL); break;
12482         case RMS$_PRV:
12483           set_errno(EACCES); break;
12484         default:
12485           set_errno(EVMSERR);
12486       }
12487       return 0;
12488     }
12489     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12490     if (preserve_dates & 2) {
12491       /* sys$close() will process xabrdt, not xabdat */
12492       xabrdt = cc$rms_xabrdt;
12493 #ifndef __GNUC__
12494       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12495 #else
12496       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12497        * is unsigned long[2], while DECC & VAXC use a struct */
12498       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12499 #endif
12500       fab_out.fab$l_xab = (void *) &xabrdt;
12501     }
12502
12503     ubf = PerlMem_malloc(32256);
12504     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12505     rab_in = cc$rms_rab;
12506     rab_in.rab$l_fab = &fab_in;
12507     rab_in.rab$l_rop = RAB$M_BIO;
12508     rab_in.rab$l_ubf = ubf;
12509     rab_in.rab$w_usz = 32256;
12510     if (!((sts = sys$connect(&rab_in)) & 1)) {
12511       sys$close(&fab_in); sys$close(&fab_out);
12512       PerlMem_free(vmsin);
12513       PerlMem_free(vmsout);
12514       PerlMem_free(ubf);
12515       PerlMem_free(esa);
12516       if (esal != NULL)
12517           PerlMem_free(esal);
12518       PerlMem_free(rsa);
12519       if (rsal != NULL)
12520           PerlMem_free(rsal);
12521       PerlMem_free(esa_out);
12522       if (esal_out != NULL)
12523           PerlMem_free(esal_out);
12524       PerlMem_free(rsa_out);
12525       if (rsal_out != NULL)
12526           PerlMem_free(rsal_out);
12527       set_errno(EVMSERR); set_vaxc_errno(sts);
12528       return 0;
12529     }
12530
12531     rab_out = cc$rms_rab;
12532     rab_out.rab$l_fab = &fab_out;
12533     rab_out.rab$l_rbf = ubf;
12534     if (!((sts = sys$connect(&rab_out)) & 1)) {
12535       sys$close(&fab_in); sys$close(&fab_out);
12536       PerlMem_free(vmsin);
12537       PerlMem_free(vmsout);
12538       PerlMem_free(ubf);
12539       PerlMem_free(esa);
12540       if (esal != NULL)
12541           PerlMem_free(esal);
12542       PerlMem_free(rsa);
12543       if (rsal != NULL)
12544           PerlMem_free(rsal);
12545       PerlMem_free(esa_out);
12546       if (esal_out != NULL)
12547           PerlMem_free(esal_out);
12548       PerlMem_free(rsa_out);
12549       if (rsal_out != NULL)
12550           PerlMem_free(rsal_out);
12551       set_errno(EVMSERR); set_vaxc_errno(sts);
12552       return 0;
12553     }
12554
12555     while ((sts = sys$read(&rab_in))) {  /* always true  */
12556       if (sts == RMS$_EOF) break;
12557       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12558       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12559         sys$close(&fab_in); sys$close(&fab_out);
12560         PerlMem_free(vmsin);
12561         PerlMem_free(vmsout);
12562         PerlMem_free(ubf);
12563         PerlMem_free(esa);
12564         if (esal != NULL)
12565             PerlMem_free(esal);
12566         PerlMem_free(rsa);
12567         if (rsal != NULL)
12568             PerlMem_free(rsal);
12569         PerlMem_free(esa_out);
12570         if (esal_out != NULL)
12571             PerlMem_free(esal_out);
12572         PerlMem_free(rsa_out);
12573         if (rsal_out != NULL)
12574             PerlMem_free(rsal_out);
12575         set_errno(EVMSERR); set_vaxc_errno(sts);
12576         return 0;
12577       }
12578     }
12579
12580
12581     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12582     sys$close(&fab_in);  sys$close(&fab_out);
12583     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12584
12585     PerlMem_free(vmsin);
12586     PerlMem_free(vmsout);
12587     PerlMem_free(ubf);
12588     PerlMem_free(esa);
12589     if (esal != NULL)
12590         PerlMem_free(esal);
12591     PerlMem_free(rsa);
12592     if (rsal != NULL)
12593         PerlMem_free(rsal);
12594     PerlMem_free(esa_out);
12595     if (esal_out != NULL)
12596         PerlMem_free(esal_out);
12597     PerlMem_free(rsa_out);
12598     if (rsal_out != NULL)
12599         PerlMem_free(rsal_out);
12600
12601     if (!(sts & 1)) {
12602       set_errno(EVMSERR); set_vaxc_errno(sts);
12603       return 0;
12604     }
12605
12606     return 1;
12607
12608 }  /* end of rmscopy() */
12609 /*}}}*/
12610
12611
12612 /***  The following glue provides 'hooks' to make some of the routines
12613  * from this file available from Perl.  These routines are sufficiently
12614  * basic, and are required sufficiently early in the build process,
12615  * that's it's nice to have them available to miniperl as well as the
12616  * full Perl, so they're set up here instead of in an extension.  The
12617  * Perl code which handles importation of these names into a given
12618  * package lives in [.VMS]Filespec.pm in @INC.
12619  */
12620
12621 void
12622 rmsexpand_fromperl(pTHX_ CV *cv)
12623 {
12624   dXSARGS;
12625   char *fspec, *defspec = NULL, *rslt;
12626   STRLEN n_a;
12627   int fs_utf8, dfs_utf8;
12628
12629   fs_utf8 = 0;
12630   dfs_utf8 = 0;
12631   if (!items || items > 2)
12632     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12633   fspec = SvPV(ST(0),n_a);
12634   fs_utf8 = SvUTF8(ST(0));
12635   if (!fspec || !*fspec) XSRETURN_UNDEF;
12636   if (items == 2) {
12637     defspec = SvPV(ST(1),n_a);
12638     dfs_utf8 = SvUTF8(ST(1));
12639   }
12640   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12641   ST(0) = sv_newmortal();
12642   if (rslt != NULL) {
12643     sv_usepvn(ST(0),rslt,strlen(rslt));
12644     if (fs_utf8) {
12645         SvUTF8_on(ST(0));
12646     }
12647   }
12648   XSRETURN(1);
12649 }
12650
12651 void
12652 vmsify_fromperl(pTHX_ CV *cv)
12653 {
12654   dXSARGS;
12655   char *vmsified;
12656   STRLEN n_a;
12657   int utf8_fl;
12658
12659   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12660   utf8_fl = SvUTF8(ST(0));
12661   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12662   ST(0) = sv_newmortal();
12663   if (vmsified != NULL) {
12664     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12665     if (utf8_fl) {
12666         SvUTF8_on(ST(0));
12667     }
12668   }
12669   XSRETURN(1);
12670 }
12671
12672 void
12673 unixify_fromperl(pTHX_ CV *cv)
12674 {
12675   dXSARGS;
12676   char *unixified;
12677   STRLEN n_a;
12678   int utf8_fl;
12679
12680   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12681   utf8_fl = SvUTF8(ST(0));
12682   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12683   ST(0) = sv_newmortal();
12684   if (unixified != NULL) {
12685     sv_usepvn(ST(0),unixified,strlen(unixified));
12686     if (utf8_fl) {
12687         SvUTF8_on(ST(0));
12688     }
12689   }
12690   XSRETURN(1);
12691 }
12692
12693 void
12694 fileify_fromperl(pTHX_ CV *cv)
12695 {
12696   dXSARGS;
12697   char *fileified;
12698   STRLEN n_a;
12699   int utf8_fl;
12700
12701   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12702   utf8_fl = SvUTF8(ST(0));
12703   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12704   ST(0) = sv_newmortal();
12705   if (fileified != NULL) {
12706     sv_usepvn(ST(0),fileified,strlen(fileified));
12707     if (utf8_fl) {
12708         SvUTF8_on(ST(0));
12709     }
12710   }
12711   XSRETURN(1);
12712 }
12713
12714 void
12715 pathify_fromperl(pTHX_ CV *cv)
12716 {
12717   dXSARGS;
12718   char *pathified;
12719   STRLEN n_a;
12720   int utf8_fl;
12721
12722   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12723   utf8_fl = SvUTF8(ST(0));
12724   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12725   ST(0) = sv_newmortal();
12726   if (pathified != NULL) {
12727     sv_usepvn(ST(0),pathified,strlen(pathified));
12728     if (utf8_fl) {
12729         SvUTF8_on(ST(0));
12730     }
12731   }
12732   XSRETURN(1);
12733 }
12734
12735 void
12736 vmspath_fromperl(pTHX_ CV *cv)
12737 {
12738   dXSARGS;
12739   char *vmspath;
12740   STRLEN n_a;
12741   int utf8_fl;
12742
12743   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12744   utf8_fl = SvUTF8(ST(0));
12745   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12746   ST(0) = sv_newmortal();
12747   if (vmspath != NULL) {
12748     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12749     if (utf8_fl) {
12750         SvUTF8_on(ST(0));
12751     }
12752   }
12753   XSRETURN(1);
12754 }
12755
12756 void
12757 unixpath_fromperl(pTHX_ CV *cv)
12758 {
12759   dXSARGS;
12760   char *unixpath;
12761   STRLEN n_a;
12762   int utf8_fl;
12763
12764   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12765   utf8_fl = SvUTF8(ST(0));
12766   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12767   ST(0) = sv_newmortal();
12768   if (unixpath != NULL) {
12769     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12770     if (utf8_fl) {
12771         SvUTF8_on(ST(0));
12772     }
12773   }
12774   XSRETURN(1);
12775 }
12776
12777 void
12778 candelete_fromperl(pTHX_ CV *cv)
12779 {
12780   dXSARGS;
12781   char *fspec, *fsp;
12782   SV *mysv;
12783   IO *io;
12784   STRLEN n_a;
12785
12786   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12787
12788   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12789   Newx(fspec, VMS_MAXRSS, char);
12790   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12791   if (isGV_with_GP(mysv)) {
12792     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12793       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12794       ST(0) = &PL_sv_no;
12795       Safefree(fspec);
12796       XSRETURN(1);
12797     }
12798     fsp = fspec;
12799   }
12800   else {
12801     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12802       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12803       ST(0) = &PL_sv_no;
12804       Safefree(fspec);
12805       XSRETURN(1);
12806     }
12807   }
12808
12809   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12810   Safefree(fspec);
12811   XSRETURN(1);
12812 }
12813
12814 void
12815 rmscopy_fromperl(pTHX_ CV *cv)
12816 {
12817   dXSARGS;
12818   char *inspec, *outspec, *inp, *outp;
12819   int date_flag;
12820   SV *mysv;
12821   IO *io;
12822   STRLEN n_a;
12823
12824   if (items < 2 || items > 3)
12825     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12826
12827   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12828   Newx(inspec, VMS_MAXRSS, char);
12829   if (isGV_with_GP(mysv)) {
12830     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12831       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12832       ST(0) = sv_2mortal(newSViv(0));
12833       Safefree(inspec);
12834       XSRETURN(1);
12835     }
12836     inp = inspec;
12837   }
12838   else {
12839     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12840       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12841       ST(0) = sv_2mortal(newSViv(0));
12842       Safefree(inspec);
12843       XSRETURN(1);
12844     }
12845   }
12846   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12847   Newx(outspec, VMS_MAXRSS, char);
12848   if (isGV_with_GP(mysv)) {
12849     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12850       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12851       ST(0) = sv_2mortal(newSViv(0));
12852       Safefree(inspec);
12853       Safefree(outspec);
12854       XSRETURN(1);
12855     }
12856     outp = outspec;
12857   }
12858   else {
12859     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12860       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12861       ST(0) = sv_2mortal(newSViv(0));
12862       Safefree(inspec);
12863       Safefree(outspec);
12864       XSRETURN(1);
12865     }
12866   }
12867   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12868
12869   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12870   Safefree(inspec);
12871   Safefree(outspec);
12872   XSRETURN(1);
12873 }
12874
12875 /* The mod2fname is limited to shorter filenames by design, so it should
12876  * not be modified to support longer EFS pathnames
12877  */
12878 void
12879 mod2fname(pTHX_ CV *cv)
12880 {
12881   dXSARGS;
12882   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12883        workbuff[NAM$C_MAXRSS*1 + 1];
12884   int counter, num_entries;
12885   /* ODS-5 ups this, but we want to be consistent, so... */
12886   int max_name_len = 39;
12887   AV *in_array = (AV *)SvRV(ST(0));
12888
12889   num_entries = av_len(in_array);
12890
12891   /* All the names start with PL_. */
12892   strcpy(ultimate_name, "PL_");
12893
12894   /* Clean up our working buffer */
12895   Zero(work_name, sizeof(work_name), char);
12896
12897   /* Run through the entries and build up a working name */
12898   for(counter = 0; counter <= num_entries; counter++) {
12899     /* If it's not the first name then tack on a __ */
12900     if (counter) {
12901       my_strlcat(work_name, "__", sizeof(work_name));
12902     }
12903     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12904   }
12905
12906   /* Check to see if we actually have to bother...*/
12907   if (strlen(work_name) + 3 <= max_name_len) {
12908     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12909   } else {
12910     /* It's too darned big, so we need to go strip. We use the same */
12911     /* algorithm as xsubpp does. First, strip out doubled __ */
12912     char *source, *dest, last;
12913     dest = workbuff;
12914     last = 0;
12915     for (source = work_name; *source; source++) {
12916       if (last == *source && last == '_') {
12917         continue;
12918       }
12919       *dest++ = *source;
12920       last = *source;
12921     }
12922     /* Go put it back */
12923     my_strlcpy(work_name, workbuff, sizeof(work_name));
12924     /* Is it still too big? */
12925     if (strlen(work_name) + 3 > max_name_len) {
12926       /* Strip duplicate letters */
12927       last = 0;
12928       dest = workbuff;
12929       for (source = work_name; *source; source++) {
12930         if (last == toupper(*source)) {
12931         continue;
12932         }
12933         *dest++ = *source;
12934         last = toupper(*source);
12935       }
12936       my_strlcpy(work_name, workbuff, sizeof(work_name));
12937     }
12938
12939     /* Is it *still* too big? */
12940     if (strlen(work_name) + 3 > max_name_len) {
12941       /* Too bad, we truncate */
12942       work_name[max_name_len - 2] = 0;
12943     }
12944     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12945   }
12946
12947   /* Okay, return it */
12948   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12949   XSRETURN(1);
12950 }
12951
12952 void
12953 hushexit_fromperl(pTHX_ CV *cv)
12954 {
12955     dXSARGS;
12956
12957     if (items > 0) {
12958         VMSISH_HUSHED = SvTRUE(ST(0));
12959     }
12960     ST(0) = boolSV(VMSISH_HUSHED);
12961     XSRETURN(1);
12962 }
12963
12964
12965 PerlIO *
12966 Perl_vms_start_glob
12967    (pTHX_ SV *tmpglob,
12968     IO *io)
12969 {
12970     PerlIO *fp;
12971     struct vs_str_st *rslt;
12972     char *vmsspec;
12973     char *rstr;
12974     char *begin, *cp;
12975     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12976     PerlIO *tmpfp;
12977     STRLEN i;
12978     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12979     struct dsc$descriptor_vs rsdsc;
12980     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12981     unsigned long hasver = 0, isunix = 0;
12982     unsigned long int lff_flags = 0;
12983     int rms_sts;
12984     int vms_old_glob = 1;
12985
12986     if (!SvOK(tmpglob)) {
12987         SETERRNO(ENOENT,RMS$_FNF);
12988         return NULL;
12989     }
12990
12991     vms_old_glob = !decc_filename_unix_report;
12992
12993 #ifdef VMS_LONGNAME_SUPPORT
12994     lff_flags = LIB$M_FIL_LONG_NAMES;
12995 #endif
12996     /* The Newx macro will not allow me to assign a smaller array
12997      * to the rslt pointer, so we will assign it to the begin char pointer
12998      * and then copy the value into the rslt pointer.
12999      */
13000     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13001     rslt = (struct vs_str_st *)begin;
13002     rslt->length = 0;
13003     rstr = &rslt->str[0];
13004     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13005     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13006     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13007     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13008
13009     Newx(vmsspec, VMS_MAXRSS, char);
13010
13011         /* We could find out if there's an explicit dev/dir or version
13012            by peeking into lib$find_file's internal context at
13013            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13014            but that's unsupported, so I don't want to do it now and
13015            have it bite someone in the future. */
13016         /* Fix-me: vms_split_path() is the only way to do this, the
13017            existing method will fail with many legal EFS or UNIX specifications
13018          */
13019
13020     cp = SvPV(tmpglob,i);
13021
13022     for (; i; i--) {
13023         if (cp[i] == ';') hasver = 1;
13024         if (cp[i] == '.') {
13025             if (sts) hasver = 1;
13026             else sts = 1;
13027         }
13028         if (cp[i] == '/') {
13029             hasdir = isunix = 1;
13030             break;
13031         }
13032         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13033             hasdir = 1;
13034             break;
13035         }
13036     }
13037
13038     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13039     if ((hasdir == 0) && decc_filename_unix_report) {
13040         isunix = 1;
13041     }
13042
13043     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13044         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13045         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13046         int wildstar = 0;
13047         int wildquery = 0;
13048         int found = 0;
13049         Stat_t st;
13050         int stat_sts;
13051         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13052         if (!stat_sts && S_ISDIR(st.st_mode)) {
13053             char * vms_dir;
13054             const char * fname;
13055             STRLEN fname_len;
13056
13057             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13058             /* path delimiter of ':>]', if so, then the old behavior has */
13059             /* obviously been specifically requested */
13060
13061             fname = SvPVX_const(tmpglob);
13062             fname_len = strlen(fname);
13063             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13064             if (vms_old_glob || (vms_dir != NULL)) {
13065                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13066                                             SvPVX(tmpglob),vmsspec,NULL);
13067                 ok = (wilddsc.dsc$a_pointer != NULL);
13068                 /* maybe passed 'foo' rather than '[.foo]', thus not
13069                    detected above */
13070                 hasdir = 1;
13071             } else {
13072                 /* Operate just on the directory, the special stat/fstat for */
13073                 /* leaves the fileified  specification in the st_devnam */
13074                 /* member. */
13075                 wilddsc.dsc$a_pointer = st.st_devnam;
13076                 ok = 1;
13077             }
13078         }
13079         else {
13080             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13081             ok = (wilddsc.dsc$a_pointer != NULL);
13082         }
13083         if (ok)
13084             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13085
13086         /* If not extended character set, replace ? with % */
13087         /* With extended character set, ? is a wildcard single character */
13088         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13089             if (*cp == '?') {
13090                 wildquery = 1;
13091                 if (!decc_efs_charset)
13092                     *cp = '%';
13093             } else if (*cp == '%') {
13094                 wildquery = 1;
13095             } else if (*cp == '*') {
13096                 wildstar = 1;
13097             }
13098         }
13099
13100         if (ok) {
13101             wv_sts = vms_split_path(
13102                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13103                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13104                 &wvs_spec, &wvs_len);
13105         } else {
13106             wn_spec = NULL;
13107             wn_len = 0;
13108             we_spec = NULL;
13109             we_len = 0;
13110         }
13111
13112         sts = SS$_NORMAL;
13113         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13114          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13115          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13116          int valid_find;
13117
13118             valid_find = 0;
13119             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13120                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13121             if (!$VMS_STATUS_SUCCESS(sts))
13122                 break;
13123
13124             /* with varying string, 1st word of buffer contains result length */
13125             rstr[rslt->length] = '\0';
13126
13127              /* Find where all the components are */
13128              v_sts = vms_split_path
13129                        (rstr,
13130                         &v_spec,
13131                         &v_len,
13132                         &r_spec,
13133                         &r_len,
13134                         &d_spec,
13135                         &d_len,
13136                         &n_spec,
13137                         &n_len,
13138                         &e_spec,
13139                         &e_len,
13140                         &vs_spec,
13141                         &vs_len);
13142
13143             /* If no version on input, truncate the version on output */
13144             if (!hasver && (vs_len > 0)) {
13145                 *vs_spec = '\0';
13146                 vs_len = 0;
13147             }
13148
13149             if (isunix) {
13150
13151                 /* In Unix report mode, remove the ".dir;1" from the name */
13152                 /* if it is a real directory */
13153                 if (decc_filename_unix_report || decc_efs_charset) {
13154                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13155                         Stat_t statbuf;
13156                         int ret_sts;
13157
13158                         ret_sts = flex_lstat(rstr, &statbuf);
13159                         if ((ret_sts == 0) &&
13160                             S_ISDIR(statbuf.st_mode)) {
13161                             e_len = 0;
13162                             e_spec[0] = 0;
13163                         }
13164                     }
13165                 }
13166
13167                 /* No version & a null extension on UNIX handling */
13168                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13169                     e_len = 0;
13170                     *e_spec = '\0';
13171                 }
13172             }
13173
13174             if (!decc_efs_case_preserve) {
13175                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13176             }
13177
13178             /* Find File treats a Null extension as return all extensions */
13179             /* This is contrary to Perl expectations */
13180
13181             if (wildstar || wildquery || vms_old_glob) {
13182                 /* really need to see if the returned file name matched */
13183                 /* but for now will assume that it matches */
13184                 valid_find = 1;
13185             } else {
13186                 /* Exact Match requested */
13187                 /* How are directories handled? - like a file */
13188                 if ((e_len == we_len) && (n_len == wn_len)) {
13189                     int t1;
13190                     t1 = e_len;
13191                     if (t1 > 0)
13192                         t1 = strncmp(e_spec, we_spec, e_len);
13193                     if (t1 == 0) {
13194                        t1 = n_len;
13195                        if (t1 > 0)
13196                            t1 = strncmp(n_spec, we_spec, n_len);
13197                        if (t1 == 0)
13198                            valid_find = 1;
13199                     }
13200                 }
13201             }
13202
13203             if (valid_find) {
13204                 found++;
13205
13206                 if (hasdir) {
13207                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13208                     begin = rstr;
13209                 }
13210                 else {
13211                     /* Start with the name */
13212                     begin = n_spec;
13213                 }
13214                 strcat(begin,"\n");
13215                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13216             }
13217         }
13218         if (cxt) (void)lib$find_file_end(&cxt);
13219
13220         if (!found) {
13221             /* Be POSIXish: return the input pattern when no matches */
13222             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13223             strcat(rstr,"\n");
13224             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13225         }
13226
13227         if (ok && sts != RMS$_NMF &&
13228             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13229         if (!ok) {
13230             if (!(sts & 1)) {
13231                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13232             }
13233             PerlIO_close(tmpfp);
13234             fp = NULL;
13235         }
13236         else {
13237             PerlIO_rewind(tmpfp);
13238             IoTYPE(io) = IoTYPE_RDONLY;
13239             IoIFP(io) = fp = tmpfp;
13240             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13241         }
13242     }
13243     Safefree(vmsspec);
13244     Safefree(rslt);
13245     return fp;
13246 }
13247
13248
13249 static char *
13250 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13251                    int *utf8_fl);
13252
13253 void
13254 unixrealpath_fromperl(pTHX_ CV *cv)
13255 {
13256     dXSARGS;
13257     char *fspec, *rslt_spec, *rslt;
13258     STRLEN n_a;
13259
13260     if (!items || items != 1)
13261         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13262
13263     fspec = SvPV(ST(0),n_a);
13264     if (!fspec || !*fspec) XSRETURN_UNDEF;
13265
13266     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13267     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13268
13269     ST(0) = sv_newmortal();
13270     if (rslt != NULL)
13271         sv_usepvn(ST(0),rslt,strlen(rslt));
13272     else
13273         Safefree(rslt_spec);
13274         XSRETURN(1);
13275 }
13276
13277 static char *
13278 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13279                    int *utf8_fl);
13280
13281 void
13282 vmsrealpath_fromperl(pTHX_ CV *cv)
13283 {
13284     dXSARGS;
13285     char *fspec, *rslt_spec, *rslt;
13286     STRLEN n_a;
13287
13288     if (!items || items != 1)
13289         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13290
13291     fspec = SvPV(ST(0),n_a);
13292     if (!fspec || !*fspec) XSRETURN_UNDEF;
13293
13294     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13295     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13296
13297     ST(0) = sv_newmortal();
13298     if (rslt != NULL)
13299         sv_usepvn(ST(0),rslt,strlen(rslt));
13300     else
13301         Safefree(rslt_spec);
13302         XSRETURN(1);
13303 }
13304
13305 #ifdef HAS_SYMLINK
13306 /*
13307  * A thin wrapper around decc$symlink to make sure we follow the
13308  * standard and do not create a symlink with a zero-length name.
13309  *
13310  * Also in ODS-2 mode, existing tests assume that the link target
13311  * will be converted to UNIX format.
13312  */
13313 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13314 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13315   if (!link_name || !*link_name) {
13316     SETERRNO(ENOENT, SS$_NOSUCHFILE);
13317     return -1;
13318   }
13319
13320   if (decc_efs_charset) {
13321       return symlink(contents, link_name);
13322   } else {
13323       int sts;
13324       char * utarget;
13325
13326       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13327       /* because in order to work, the symlink target must be in UNIX format */
13328
13329       /* As symbolic links can hold things other than files, we will only do */
13330       /* the conversion in in ODS-2 mode */
13331
13332       utarget = PerlMem_malloc(VMS_MAXRSS + 1);
13333       if (int_tounixspec(contents, utarget, NULL) == NULL) {
13334
13335           /* This should not fail, as an untranslatable filename */
13336           /* should be passed through */
13337           utarget = (char *)contents;
13338       }
13339       sts = symlink(utarget, link_name);
13340       PerlMem_free(utarget);
13341       return sts;
13342   }
13343
13344 }
13345 /*}}}*/
13346
13347 #endif /* HAS_SYMLINK */
13348
13349 int do_vms_case_tolerant(void);
13350
13351 void
13352 case_tolerant_process_fromperl(pTHX_ CV *cv)
13353 {
13354   dXSARGS;
13355   ST(0) = boolSV(do_vms_case_tolerant());
13356   XSRETURN(1);
13357 }
13358
13359 #ifdef USE_ITHREADS
13360
13361 void
13362 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13363                           struct interp_intern *dst)
13364 {
13365     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13366
13367     memcpy(dst,src,sizeof(struct interp_intern));
13368 }
13369
13370 #endif
13371
13372 void
13373 Perl_sys_intern_clear(pTHX)
13374 {
13375 }
13376
13377 void
13378 Perl_sys_intern_init(pTHX)
13379 {
13380     unsigned int ix = RAND_MAX;
13381     double x;
13382
13383     VMSISH_HUSHED = 0;
13384
13385     MY_POSIX_EXIT = vms_posix_exit;
13386
13387     x = (float)ix;
13388     MY_INV_RAND_MAX = 1./x;
13389 }
13390
13391 void
13392 init_os_extras(void)
13393 {
13394   dTHX;
13395   char* file = __FILE__;
13396   if (decc_disable_to_vms_logname_translation) {
13397     no_translate_barewords = TRUE;
13398   } else {
13399     no_translate_barewords = FALSE;
13400   }
13401
13402   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13403   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13404   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13405   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13406   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13407   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13408   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13409   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13410   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13411   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13412   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13413   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13414   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13415   newXSproto("VMS::Filespec::case_tolerant_process",
13416       case_tolerant_process_fromperl,file,"");
13417
13418   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13419
13420   return;
13421 }
13422
13423 #if __CRTL_VER == 80200000
13424 /* This missed getting in to the DECC SDK for 8.2 */
13425 char *realpath(const char *file_name, char * resolved_name, ...);
13426 #endif
13427
13428 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13429 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13430  * The perl fallback routine to provide realpath() is not as efficient
13431  * on OpenVMS.
13432  */
13433
13434 /* Hack, use old stat() as fastest way of getting ino_t and device */
13435 int decc$stat(const char *name, void * statbuf);
13436 #if !defined(__VAX) && __CRTL_VER >= 80200000
13437 int decc$lstat(const char *name, void * statbuf);
13438 #else
13439 #define decc$lstat decc$stat
13440 #endif
13441
13442
13443 /* Realpath is fragile.  In 8.3 it does not work if the feature
13444  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13445  * links are implemented in RMS, not the CRTL. It also can fail if the
13446  * user does not have read/execute access to some of the directories.
13447  * So in order for Do What I Mean mode to work, if realpath() fails,
13448  * fall back to looking up the filename by the device name and FID.
13449  */
13450
13451 int vms_fid_to_name(char * outname, int outlen,
13452                     const char * name, int lstat_flag, mode_t * mode)
13453 {
13454 #pragma message save
13455 #pragma message disable MISALGNDSTRCT
13456 #pragma message disable MISALGNDMEM
13457 #pragma member_alignment save
13458 #pragma nomember_alignment
13459 struct statbuf_t {
13460     char           * st_dev;
13461     unsigned short st_ino[3];
13462     unsigned short old_st_mode;
13463     unsigned long  padl[30];  /* plenty of room */
13464 } statbuf;
13465 #pragma message restore
13466 #pragma member_alignment restore
13467
13468     int sts;
13469     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13470     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13471     char *fileified;
13472     char *temp_fspec;
13473     char *ret_spec;
13474
13475     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13476      * unexpected answers
13477      */
13478
13479     fileified = PerlMem_malloc(VMS_MAXRSS);
13480     if (fileified == NULL)
13481         _ckvmssts_noperl(SS$_INSFMEM);
13482
13483     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
13484     if (temp_fspec == NULL)
13485         _ckvmssts_noperl(SS$_INSFMEM);
13486
13487     sts = -1;
13488     /* First need to try as a directory */
13489     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13490     if (ret_spec != NULL) {
13491         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13492         if (ret_spec != NULL) {
13493             if (lstat_flag == 0)
13494                 sts = decc$stat(fileified, &statbuf);
13495             else
13496                 sts = decc$lstat(fileified, &statbuf);
13497         }
13498     }
13499
13500     /* Then as a VMS file spec */
13501     if (sts != 0) {
13502         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13503         if (ret_spec != NULL) {
13504             if (lstat_flag == 0) {
13505                 sts = decc$stat(temp_fspec, &statbuf);
13506             } else {
13507                 sts = decc$lstat(temp_fspec, &statbuf);
13508             }
13509         }
13510     }
13511
13512     if (sts) {
13513         /* Next try - allow multiple dots with out EFS CHARSET */
13514         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13515          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13516          * enable it if it isn't already.
13517          */
13518 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13519         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13520             decc$feature_set_value(decc_efs_charset_index, 1, 1);
13521 #endif
13522         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13523         if (lstat_flag == 0) {
13524             sts = decc$stat(name, &statbuf);
13525         } else {
13526             sts = decc$lstat(name, &statbuf);
13527         }
13528 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13529         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13530             decc$feature_set_value(decc_efs_charset_index, 1, 0);
13531 #endif
13532     }
13533
13534
13535     /* and then because the Perl Unix to VMS conversion is not perfect */
13536     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13537     /* characters from filenames so we need to try it as-is */
13538     if (sts) {
13539         if (lstat_flag == 0) {
13540             sts = decc$stat(name, &statbuf);
13541         } else {
13542             sts = decc$lstat(name, &statbuf);
13543         }
13544     }
13545
13546     if (sts == 0) {
13547         int vms_sts;
13548
13549         dvidsc.dsc$a_pointer=statbuf.st_dev;
13550         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13551
13552         specdsc.dsc$a_pointer = outname;
13553         specdsc.dsc$w_length = outlen-1;
13554
13555         vms_sts = lib$fid_to_name
13556             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13557         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13558             outname[specdsc.dsc$w_length] = 0;
13559
13560             /* Return the mode */
13561             if (mode) {
13562                 *mode = statbuf.old_st_mode;
13563             }
13564         }
13565     }
13566     PerlMem_free(temp_fspec);
13567     PerlMem_free(fileified);
13568     return sts;
13569 }
13570
13571
13572
13573 static char *
13574 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13575                    int *utf8_fl)
13576 {
13577     char * rslt = NULL;
13578
13579 #ifdef HAS_SYMLINK
13580     if (decc_posix_compliant_pathnames > 0 ) {
13581         /* realpath currently only works if posix compliant pathnames are
13582          * enabled.  It may start working when they are not, but in that
13583          * case we still want the fallback behavior for backwards compatibility
13584          */
13585         rslt = realpath(filespec, outbuf);
13586     }
13587 #endif
13588
13589     if (rslt == NULL) {
13590         char * vms_spec;
13591         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13592         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13593         mode_t my_mode;
13594
13595         /* Fall back to fid_to_name */
13596
13597         Newx(vms_spec, VMS_MAXRSS + 1, char);
13598
13599         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13600         if (sts == 0) {
13601
13602
13603             /* Now need to trim the version off */
13604             sts = vms_split_path
13605                   (vms_spec,
13606                    &v_spec,
13607                    &v_len,
13608                    &r_spec,
13609                    &r_len,
13610                    &d_spec,
13611                    &d_len,
13612                    &n_spec,
13613                    &n_len,
13614                    &e_spec,
13615                    &e_len,
13616                    &vs_spec,
13617                    &vs_len);
13618
13619
13620                 if (sts == 0) {
13621                     int haslower = 0;
13622                     const char *cp;
13623
13624                     /* Trim off the version */
13625                     int file_len = v_len + r_len + d_len + n_len + e_len;
13626                     vms_spec[file_len] = 0;
13627
13628                     /* Trim off the .DIR if this is a directory */
13629                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13630                         if (S_ISDIR(my_mode)) {
13631                             e_len = 0;
13632                             e_spec[0] = 0;
13633                         }
13634                     }
13635
13636                     /* Drop NULL extensions on UNIX file specification */
13637                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
13638                         e_len = 0;
13639                         e_spec[0] = '\0';
13640                     }
13641
13642                     /* The result is expected to be in UNIX format */
13643                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13644
13645                     /* Downcase if input had any lower case letters and
13646                      * case preservation is not in effect.
13647                      */
13648                     if (!decc_efs_case_preserve) {
13649                         for (cp = filespec; *cp; cp++)
13650                             if (islower(*cp)) { haslower = 1; break; }
13651
13652                         if (haslower) __mystrtolower(rslt);
13653                     }
13654                 }
13655         } else {
13656
13657             /* Now for some hacks to deal with backwards and forward */
13658             /* compatibility */
13659             if (!decc_efs_charset) {
13660
13661                 /* 1. ODS-2 mode wants to do a syntax only translation */
13662                 rslt = int_rmsexpand(filespec, outbuf,
13663                                     NULL, 0, NULL, utf8_fl);
13664
13665             } else {
13666                 if (decc_filename_unix_report) {
13667                     char * dir_name;
13668                     char * vms_dir_name;
13669                     char * file_name;
13670
13671                     /* 2. ODS-5 / UNIX report mode should return a failure */
13672                     /*    if the parent directory also does not exist */
13673                     /*    Otherwise, get the real path for the parent */
13674                     /*    and add the child to it. */
13675
13676                     /* basename / dirname only available for VMS 7.0+ */
13677                     /* So we may need to implement them as common routines */
13678
13679                     Newx(dir_name, VMS_MAXRSS + 1, char);
13680                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13681                     dir_name[0] = '\0';
13682                     file_name = NULL;
13683
13684                     /* First try a VMS parse */
13685                     sts = vms_split_path
13686                           (filespec,
13687                            &v_spec,
13688                            &v_len,
13689                            &r_spec,
13690                            &r_len,
13691                            &d_spec,
13692                            &d_len,
13693                            &n_spec,
13694                            &n_len,
13695                            &e_spec,
13696                            &e_len,
13697                            &vs_spec,
13698                            &vs_len);
13699
13700                     if (sts == 0) {
13701                         /* This is VMS */
13702
13703                         int dir_len = v_len + r_len + d_len + n_len;
13704                         if (dir_len > 0) {
13705                            memcpy(dir_name, filespec, dir_len);
13706                            dir_name[dir_len] = '\0';
13707                            file_name = (char *)&filespec[dir_len + 1];
13708                         }
13709                     } else {
13710                         /* This must be UNIX */
13711                         char * tchar;
13712
13713                         tchar = strrchr(filespec, '/');
13714
13715                         if (tchar != NULL) {
13716                             int dir_len = tchar - filespec;
13717                             memcpy(dir_name, filespec, dir_len);
13718                             dir_name[dir_len] = '\0';
13719                             file_name = (char *) &filespec[dir_len + 1];
13720                         }
13721                     }
13722
13723                     /* Dir name is defaulted */
13724                     if (dir_name[0] == 0) {
13725                         dir_name[0] = '.';
13726                         dir_name[1] = '\0';
13727                     }
13728
13729                     /* Need realpath for the directory */
13730                     sts = vms_fid_to_name(vms_dir_name,
13731                                           VMS_MAXRSS + 1,
13732                                           dir_name, 0, NULL);
13733
13734                     if (sts == 0) {
13735                         /* Now need to pathify it. */
13736                         char *tdir = int_pathify_dirspec(vms_dir_name,
13737                                                          outbuf);
13738
13739                         /* And now add the original filespec to it */
13740                         if (file_name != NULL) {
13741                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13742                         }
13743                         return outbuf;
13744                     }
13745                     Safefree(vms_dir_name);
13746                     Safefree(dir_name);
13747                 }
13748             }
13749         }
13750         Safefree(vms_spec);
13751     }
13752     return rslt;
13753 }
13754
13755 static char *
13756 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13757                    int *utf8_fl)
13758 {
13759     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13760     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13761
13762     /* Fall back to fid_to_name */
13763
13764     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13765     if (sts != 0) {
13766         return NULL;
13767     }
13768     else {
13769
13770
13771         /* Now need to trim the version off */
13772         sts = vms_split_path
13773                   (outbuf,
13774                    &v_spec,
13775                    &v_len,
13776                    &r_spec,
13777                    &r_len,
13778                    &d_spec,
13779                    &d_len,
13780                    &n_spec,
13781                    &n_len,
13782                    &e_spec,
13783                    &e_len,
13784                    &vs_spec,
13785                    &vs_len);
13786
13787
13788         if (sts == 0) {
13789             int haslower = 0;
13790             const char *cp;
13791
13792             /* Trim off the version */
13793             int file_len = v_len + r_len + d_len + n_len + e_len;
13794             outbuf[file_len] = 0;
13795
13796             /* Downcase if input had any lower case letters and
13797              * case preservation is not in effect.
13798              */
13799             if (!decc_efs_case_preserve) {
13800                 for (cp = filespec; *cp; cp++)
13801                     if (islower(*cp)) { haslower = 1; break; }
13802
13803                 if (haslower) __mystrtolower(outbuf);
13804             }
13805         }
13806     }
13807     return outbuf;
13808 }
13809
13810
13811 /*}}}*/
13812 /* External entry points */
13813 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13814 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13815
13816 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13817 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13818
13819 /* case_tolerant */
13820
13821 /*{{{int do_vms_case_tolerant(void)*/
13822 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13823  * controlled by a process setting.
13824  */
13825 int do_vms_case_tolerant(void)
13826 {
13827     return vms_process_case_tolerant;
13828 }
13829 /*}}}*/
13830 /* External entry points */
13831 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13832 int Perl_vms_case_tolerant(void)
13833 { return do_vms_case_tolerant(); }
13834 #else
13835 int Perl_vms_case_tolerant(void)
13836 { return vms_process_case_tolerant; }
13837 #endif
13838
13839
13840  /* Start of DECC RTL Feature handling */
13841
13842
13843 /* C RTL Feature settings */
13844
13845 static int set_features
13846    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
13847     int (* cli_routine)(void),  /* Not documented */
13848     void *image_info)           /* Not documented */
13849 {
13850     int status;
13851     int s;
13852     char val_str[10];
13853 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13854     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13855     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13856     unsigned long case_perm;
13857     unsigned long case_image;
13858 #endif
13859
13860     /* Allow an exception to bring Perl into the VMS debugger */
13861     vms_debug_on_exception = 0;
13862     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13863     if ($VMS_STATUS_SUCCESS(status)) {
13864        val_str[0] = _toupper(val_str[0]);
13865        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13866          vms_debug_on_exception = 1;
13867        else
13868          vms_debug_on_exception = 0;
13869     }
13870
13871     /* Debug unix/vms file translation routines */
13872     vms_debug_fileify = 0;
13873     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13874     if ($VMS_STATUS_SUCCESS(status)) {
13875         val_str[0] = _toupper(val_str[0]);
13876         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13877             vms_debug_fileify = 1;
13878         else
13879             vms_debug_fileify = 0;
13880     }
13881
13882
13883     /* Historically PERL has been doing vmsify / stat differently than */
13884     /* the CRTL.  In particular, under some conditions the CRTL will   */
13885     /* remove some illegal characters like spaces from filenames       */
13886     /* resulting in some differences.  The stat()/lstat() wrapper has  */
13887     /* been reporting such file names as invalid and fails to stat them */
13888     /* fixing this bug so that stat()/lstat() accept these like the     */
13889     /* CRTL does will result in several tests failing.                  */
13890     /* This should really be fixed, but for now, set up a feature to    */
13891     /* enable it so that the impact can be studied.                     */
13892     vms_bug_stat_filename = 0;
13893     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13894     if ($VMS_STATUS_SUCCESS(status)) {
13895         val_str[0] = _toupper(val_str[0]);
13896         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13897             vms_bug_stat_filename = 1;
13898         else
13899             vms_bug_stat_filename = 0;
13900     }
13901
13902
13903     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13904     vms_vtf7_filenames = 0;
13905     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13906     if ($VMS_STATUS_SUCCESS(status)) {
13907        val_str[0] = _toupper(val_str[0]);
13908        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13909          vms_vtf7_filenames = 1;
13910        else
13911          vms_vtf7_filenames = 0;
13912     }
13913
13914     /* unlink all versions on unlink() or rename() */
13915     vms_unlink_all_versions = 0;
13916     status = simple_trnlnm
13917         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13918     if ($VMS_STATUS_SUCCESS(status)) {
13919        val_str[0] = _toupper(val_str[0]);
13920        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13921          vms_unlink_all_versions = 1;
13922        else
13923          vms_unlink_all_versions = 0;
13924     }
13925
13926     /* Dectect running under GNV Bash or other UNIX like shell */
13927 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13928     gnv_unix_shell = 0;
13929     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13930     if ($VMS_STATUS_SUCCESS(status)) {
13931          gnv_unix_shell = 1;
13932          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13933          set_feature_default("DECC$EFS_CHARSET", 1);
13934          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13935          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13936          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13937          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13938          vms_unlink_all_versions = 1;
13939          vms_posix_exit = 1;
13940     }
13941 #endif
13942
13943     /* hacks to see if known bugs are still present for testing */
13944
13945     /* PCP mode requires creating /dev/null special device file */
13946     decc_bug_devnull = 0;
13947     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13948     if ($VMS_STATUS_SUCCESS(status)) {
13949        val_str[0] = _toupper(val_str[0]);
13950        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13951           decc_bug_devnull = 1;
13952        else
13953           decc_bug_devnull = 0;
13954     }
13955
13956     /* UNIX directory names with no paths are broken in a lot of places */
13957     decc_dir_barename = 1;
13958     status = simple_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13959     if ($VMS_STATUS_SUCCESS(status)) {
13960       val_str[0] = _toupper(val_str[0]);
13961       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13962         decc_dir_barename = 1;
13963       else
13964         decc_dir_barename = 0;
13965     }
13966
13967 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13968     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13969     if (s >= 0) {
13970         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13971         if (decc_disable_to_vms_logname_translation < 0)
13972             decc_disable_to_vms_logname_translation = 0;
13973     }
13974
13975     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13976     if (s >= 0) {
13977         decc_efs_case_preserve = decc$feature_get_value(s, 1);
13978         if (decc_efs_case_preserve < 0)
13979             decc_efs_case_preserve = 0;
13980     }
13981
13982     s = decc$feature_get_index("DECC$EFS_CHARSET");
13983     decc_efs_charset_index = s;
13984     if (s >= 0) {
13985         decc_efs_charset = decc$feature_get_value(s, 1);
13986         if (decc_efs_charset < 0)
13987             decc_efs_charset = 0;
13988     }
13989
13990     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13991     if (s >= 0) {
13992         decc_filename_unix_report = decc$feature_get_value(s, 1);
13993         if (decc_filename_unix_report > 0) {
13994             decc_filename_unix_report = 1;
13995             vms_posix_exit = 1;
13996         }
13997         else
13998             decc_filename_unix_report = 0;
13999     }
14000
14001     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14002     if (s >= 0) {
14003         decc_filename_unix_only = decc$feature_get_value(s, 1);
14004         if (decc_filename_unix_only > 0) {
14005             decc_filename_unix_only = 1;
14006         }
14007         else {
14008             decc_filename_unix_only = 0;
14009         }
14010     }
14011
14012     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14013     if (s >= 0) {
14014         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14015         if (decc_filename_unix_no_version < 0)
14016             decc_filename_unix_no_version = 0;
14017     }
14018
14019     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14020     if (s >= 0) {
14021         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14022         if (decc_readdir_dropdotnotype < 0)
14023             decc_readdir_dropdotnotype = 0;
14024     }
14025
14026 #if __CRTL_VER >= 80200000
14027     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14028     if (s >= 0) {
14029         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14030         if (decc_posix_compliant_pathnames < 0)
14031             decc_posix_compliant_pathnames = 0;
14032         if (decc_posix_compliant_pathnames > 4)
14033             decc_posix_compliant_pathnames = 0;
14034     }
14035
14036 #endif
14037 #else
14038     status = simple_trnlnm
14039         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14040     if ($VMS_STATUS_SUCCESS(status)) {
14041         val_str[0] = _toupper(val_str[0]);
14042         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14043            decc_disable_to_vms_logname_translation = 1;
14044         }
14045     }
14046
14047 #ifndef __VAX
14048     status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14049     if ($VMS_STATUS_SUCCESS(status)) {
14050         val_str[0] = _toupper(val_str[0]);
14051         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14052            decc_efs_case_preserve = 1;
14053         }
14054     }
14055 #endif
14056
14057     status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14058     if ($VMS_STATUS_SUCCESS(status)) {
14059         val_str[0] = _toupper(val_str[0]);
14060         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14061            decc_filename_unix_report = 1;
14062         }
14063     }
14064     status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14065     if ($VMS_STATUS_SUCCESS(status)) {
14066         val_str[0] = _toupper(val_str[0]);
14067         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14068            decc_filename_unix_only = 1;
14069            decc_filename_unix_report = 1;
14070         }
14071     }
14072     status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14073     if ($VMS_STATUS_SUCCESS(status)) {
14074         val_str[0] = _toupper(val_str[0]);
14075         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14076            decc_filename_unix_no_version = 1;
14077         }
14078     }
14079     status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14080     if ($VMS_STATUS_SUCCESS(status)) {
14081         val_str[0] = _toupper(val_str[0]);
14082         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14083            decc_readdir_dropdotnotype = 1;
14084         }
14085     }
14086 #endif
14087
14088 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14089
14090      /* Report true case tolerance */
14091     /*----------------------------*/
14092     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14093     if (!$VMS_STATUS_SUCCESS(status))
14094         case_perm = PPROP$K_CASE_BLIND;
14095     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14096     if (!$VMS_STATUS_SUCCESS(status))
14097         case_image = PPROP$K_CASE_BLIND;
14098     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14099         (case_image == PPROP$K_CASE_SENSITIVE))
14100         vms_process_case_tolerant = 0;
14101
14102 #endif
14103
14104     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14105     /* for strict backward compatibility */
14106     status = simple_trnlnm
14107         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14108     if ($VMS_STATUS_SUCCESS(status)) {
14109        val_str[0] = _toupper(val_str[0]);
14110        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14111          vms_posix_exit = 1;
14112        else
14113          vms_posix_exit = 0;
14114     }
14115
14116
14117     /* CRTL can be initialized past this point, but not before. */
14118 /*    DECC$CRTL_INIT(); */
14119
14120     return SS$_NORMAL;
14121 }
14122
14123 #ifdef __DECC
14124 #pragma nostandard
14125 #pragma extern_model save
14126 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14127         const __align (LONGWORD) int spare[8] = {0};
14128
14129 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14130 #if __DECC_VER >= 60560002
14131 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14132 #else
14133 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14134 #endif
14135 #endif /* __DECC */
14136
14137 const long vms_cc_features = (const long)set_features;
14138
14139 /*
14140 ** Force a reference to LIB$INITIALIZE to ensure it
14141 ** exists in the image.
14142 */
14143 #define lib$initialize LIB$INITIALIZE
14144 int lib$initialize(void);
14145 #ifdef __DECC
14146 #pragma extern_model strict_refdef
14147 #endif
14148     int lib_init_ref = (int) lib$initialize;
14149
14150 #ifdef __DECC
14151 #pragma extern_model restore
14152 #pragma standard
14153 #endif
14154
14155 /*  End of vms.c */