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 /* Older versions of ssdef.h don't have these */
  89 #ifndef SS$_INVFILFOROP
  90 #  define SS$_INVFILFOROP 3930
  91 #endif
  92 #ifndef SS$_NOSUCHOBJECT
  93 #  define SS$_NOSUCHOBJECT 2696
  94 #endif
  95
  96 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
  97 #define PERLIO_NOT_STDIO 0
  98
  99 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 100  * code below needs to get to the underlying CRTL routines. */
 101 #define DONT_MASK_RTL_CALLS
 102 #include "EXTERN.h"
 103 #include "perl.h"
 104 #include "XSUB.h"
 105 /* Anticipating future expansion in lexical warnings . . . */
 106 #ifndef WARN_INTERNAL
 107 #  define WARN_INTERNAL WARN_MISC
 108 #endif
 109
 110 #ifdef VMS_LONGNAME_SUPPORT
 111 #include <libfildef.h>
 112 #endif
 113
 114 #if !defined(__VAX) && __CRTL_VER >= 80200000
 115 #ifdef lstat
 116 #undef lstat
 117 #endif
 118 #else
 119 #ifdef lstat
 120 #undef lstat
 121 #endif
 122 #define lstat(_x, _y) stat(_x, _y)
 123 #endif
 124
 125 /* Routine to create a decterm for use with the Perl debugger */
 126 /* No headers, this information was found in the Programming Concepts Manual */
 127
 128 static int (*decw_term_port)
 129    (const struct dsc$descriptor_s * display,
 130     const struct dsc$descriptor_s * setup_file,
 131     const struct dsc$descriptor_s * customization,
 132     struct dsc$descriptor_s * result_device_name,
 133     unsigned short * result_device_name_length,
 134     void * controller,
 135     void * char_buffer,
 136     void * char_change_buffer) = 0;
 137
 138 /* gcc's header files don't #define direct access macros
 139  * corresponding to VAXC's variant structs */
 140 #ifdef __GNUC__
 141 #  define uic$v_format uic$r_uic_form.uic$v_format
 142 #  define uic$v_group uic$r_uic_form.uic$v_group
 143 #  define uic$v_member uic$r_uic_form.uic$v_member
 144 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 145 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 146 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 147 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 148 #endif
 149
 150 #if defined(NEED_AN_H_ERRNO)
 151 dEXT int h_errno;
 152 #endif
 153
 154 #if defined(__DECC) || defined(__DECCXX)
 155 #pragma member_alignment save
 156 #pragma nomember_alignment longword
 157 #pragma message save
 158 #pragma message disable misalgndmem
 159 #endif
 160 struct itmlst_3 {
 161   unsigned short int buflen;
 162   unsigned short int itmcode;
 163   void *bufadr;
 164   unsigned short int *retlen;
 165 };
 166
 167 struct filescan_itmlst_2 {
 168     unsigned short length;
 169     unsigned short itmcode;
 170     char * component;
 171 };
 172
 173 struct vs_str_st {
 174     unsigned short length;
 175     char str[VMS_MAXRSS];
 176     unsigned short pad; /* for longword struct alignment */
 177 };
 178
 179 #if defined(__DECC) || defined(__DECCXX)
 180 #pragma message restore
 181 #pragma member_alignment restore
 182 #endif
 183
 184 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 185 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 186 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 187 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 188 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 189 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 190 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 191 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 192 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 193 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 194 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 195 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 196
 197 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 198 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 199 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 200 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 201
 202 static char *  int_rmsexpand_vms(
 203     const char * filespec, char * outbuf, unsigned opts);
 204 static char * int_rmsexpand_tovms(
 205     const char * filespec, char * outbuf, unsigned opts);
 206 static char *int_tovmsspec
 207    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 208 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 209 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 210 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 211
 212 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 213 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 214
 215 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 216  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 217  * the Perl facility.
 218  */
 219 #define PERL_LNM_MAX_ITER 10
 220
 221   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 222 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 223 #define MAX_DCL_SYMBOL          (8192)
 224 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 225 #else
 226 #define MAX_DCL_SYMBOL          (1024)
 227 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 228 #endif
 229
 230 static char *__mystrtolower(char *str)
 231 {
 232   if (str) for (; *str; ++str) *str= tolower(*str);
 233   return str;
 234 }
 235
 236 static struct dsc$descriptor_s fildevdsc =
 237   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 238 static struct dsc$descriptor_s crtlenvdsc =
 239   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 240 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 241 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 242 static struct dsc$descriptor_s **env_tables = defenv;
 243 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 244
 245 /* True if we shouldn't treat barewords as logicals during directory */
 246 /* munching */
 247 static int no_translate_barewords;
 248
 249 /* DECC Features that may need to affect how Perl interprets
 250  * displays filename information
 251  */
 252 static int decc_disable_to_vms_logname_translation = 1;
 253 static int decc_disable_posix_root = 1;
 254 int decc_efs_case_preserve = 0;
 255 static int decc_efs_charset = 0;
 256 static int decc_efs_charset_index = -1;
 257 static int decc_filename_unix_no_version = 0;
 258 static int decc_filename_unix_only = 0;
 259 int decc_filename_unix_report = 0;
 260 int decc_posix_compliant_pathnames = 0;
 261 int decc_readdir_dropdotnotype = 0;
 262 static int vms_process_case_tolerant = 1;
 263 int vms_vtf7_filenames = 0;
 264 int gnv_unix_shell = 0;
 265 static int vms_unlink_all_versions = 0;
 266 static int vms_posix_exit = 0;
 267
 268 /* bug workarounds if needed */
 269 int decc_bug_devnull = 1;
 270 int decc_dir_barename = 0;
 271 int vms_bug_stat_filename = 0;
 272
 273 static int vms_debug_on_exception = 0;
 274 static int vms_debug_fileify = 0;
 275
 276 /* Simple logical name translation */
 277 static int simple_trnlnm
 278    (const char * logname,
 279     char * value,
 280     int value_len)
 281 {
 282     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 283     const unsigned long attr = LNM$M_CASE_BLIND;
 284     struct dsc$descriptor_s name_dsc;
 285     int status;
 286     unsigned short result;
 287     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 288                                 {0, 0, 0, 0}};
 289
 290     name_dsc.dsc$w_length = strlen(logname);
 291     name_dsc.dsc$a_pointer = (char *)logname;
 292     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 293     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 294
 295     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 296
 297     if ($VMS_STATUS_SUCCESS(status)) {
 298
 299          /* Null terminate and return the string */
 300         /*--------------------------------------*/
 301         value[result] = 0;
 302         return result;
 303     }
 304
 305     return 0;
 306 }
 307
 308
 309 /* Is this a UNIX file specification?
 310  *   No longer a simple check with EFS file specs
 311  *   For now, not a full check, but need to
 312  *   handle POSIX ^UP^ specifications
 313  *   Fixing to handle ^/ cases would require
 314  *   changes to many other conversion routines.
 315  */
 316
 317 static int is_unix_filespec(const char *path)
 318 {
 319 int ret_val;
 320 const char * pch1;
 321
 322     ret_val = 0;
 323     if (strncmp(path,"\"^UP^",5) != 0) {
 324         pch1 = strchr(path, '/');
 325         if (pch1 != NULL)
 326             ret_val = 1;
 327         else {
 328
 329             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 330             if (decc_filename_unix_report || decc_filename_unix_only) {
 331             if (strcmp(path,".") == 0)
 332                 ret_val = 1;
 333             }
 334         }
 335     }
 336     return ret_val;
 337 }
 338
 339 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 340  */
 341
 342 static void ucs2_to_vtf7
 343    (char *outspec,
 344     unsigned long ucs2_char,
 345     int * output_cnt)
 346 {
 347 unsigned char * ucs_ptr;
 348 int hex;
 349
 350     ucs_ptr = (unsigned char *)&ucs2_char;
 351
 352     outspec[0] = '^';
 353     outspec[1] = 'U';
 354     hex = (ucs_ptr[1] >> 4) & 0xf;
 355     if (hex < 0xA)
 356         outspec[2] = hex + '0';
 357     else
 358         outspec[2] = (hex - 9) + 'A';
 359     hex = ucs_ptr[1] & 0xF;
 360     if (hex < 0xA)
 361         outspec[3] = hex + '0';
 362     else {
 363         outspec[3] = (hex - 9) + 'A';
 364     }
 365     hex = (ucs_ptr[0] >> 4) & 0xf;
 366     if (hex < 0xA)
 367         outspec[4] = hex + '0';
 368     else
 369         outspec[4] = (hex - 9) + 'A';
 370     hex = ucs_ptr[1] & 0xF;
 371     if (hex < 0xA)
 372         outspec[5] = hex + '0';
 373     else {
 374         outspec[5] = (hex - 9) + 'A';
 375     }
 376     *output_cnt = 6;
 377 }
 378
 379
 380 /* This handles the conversion of a UNIX extended character set to a ^
 381  * escaped VMS character.
 382  * in a UNIX file specification.
 383  *
 384  * The output count variable contains the number of characters added
 385  * to the output string.
 386  *
 387  * The return value is the number of characters read from the input string
 388  */
 389 static int copy_expand_unix_filename_escape
 390   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 391 {
 392 int count;
 393 int utf8_flag;
 394
 395     utf8_flag = 0;
 396     if (utf8_fl)
 397       utf8_flag = *utf8_fl;
 398
 399     count = 0;
 400     *output_cnt = 0;
 401     if (*inspec >= 0x80) {
 402         if (utf8_fl && vms_vtf7_filenames) {
 403         unsigned long ucs_char;
 404
 405             ucs_char = 0;
 406
 407             if ((*inspec & 0xE0) == 0xC0) {
 408                 /* 2 byte Unicode */
 409                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 410                 if (ucs_char >= 0x80) {
 411                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 412                     return 2;
 413                 }
 414             } else if ((*inspec & 0xF0) == 0xE0) {
 415                 /* 3 byte Unicode */
 416                 ucs_char = ((inspec[0] & 0xF) << 12) +
 417                    ((inspec[1] & 0x3f) << 6) +
 418                    (inspec[2] & 0x3f);
 419                 if (ucs_char >= 0x800) {
 420                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 421                     return 3;
 422                 }
 423
 424 #if 0 /* I do not see longer sequences supported by OpenVMS */
 425       /* Maybe some one can fix this later */
 426             } else if ((*inspec & 0xF8) == 0xF0) {
 427                 /* 4 byte Unicode */
 428                 /* UCS-4 to UCS-2 */
 429             } else if ((*inspec & 0xFC) == 0xF8) {
 430                 /* 5 byte Unicode */
 431                 /* UCS-4 to UCS-2 */
 432             } else if ((*inspec & 0xFE) == 0xFC) {
 433                 /* 6 byte Unicode */
 434                 /* UCS-4 to UCS-2 */
 435 #endif
 436             }
 437         }
 438
 439         /* High bit set, but not a Unicode character! */
 440
 441         /* Non printing DECMCS or ISO Latin-1 character? */
 442         if ((unsigned char)*inspec <= 0x9F) {
 443             int hex;
 444             outspec[0] = '^';
 445             outspec++;
 446             hex = (*inspec >> 4) & 0xF;
 447             if (hex < 0xA)
 448                 outspec[1] = hex + '0';
 449             else {
 450                 outspec[1] = (hex - 9) + 'A';
 451             }
 452             hex = *inspec & 0xF;
 453             if (hex < 0xA)
 454                 outspec[2] = hex + '0';
 455             else {
 456                 outspec[2] = (hex - 9) + 'A';
 457             }
 458             *output_cnt = 3;
 459             return 1;
 460         } else if ((unsigned char)*inspec == 0xA0) {
 461             outspec[0] = '^';
 462             outspec[1] = 'A';
 463             outspec[2] = '0';
 464             *output_cnt = 3;
 465             return 1;
 466         } else if ((unsigned char)*inspec == 0xFF) {
 467             outspec[0] = '^';
 468             outspec[1] = 'F';
 469             outspec[2] = 'F';
 470             *output_cnt = 3;
 471             return 1;
 472         }
 473         *outspec = *inspec;
 474         *output_cnt = 1;
 475         return 1;
 476     }
 477
 478     /* Is this a macro that needs to be passed through?
 479      * Macros start with $( and an alpha character, followed
 480      * by a string of alpha numeric characters ending with a )
 481      * If this does not match, then encode it as ODS-5.
 482      */
 483     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 484     int tcnt;
 485
 486         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 487             tcnt = 3;
 488             outspec[0] = inspec[0];
 489             outspec[1] = inspec[1];
 490             outspec[2] = inspec[2];
 491
 492             while(isalnum(inspec[tcnt]) ||
 493                   (inspec[2] == '.') || (inspec[2] == '_')) {
 494                 outspec[tcnt] = inspec[tcnt];
 495                 tcnt++;
 496             }
 497             if (inspec[tcnt] == ')') {
 498                 outspec[tcnt] = inspec[tcnt];
 499                 tcnt++;
 500                 *output_cnt = tcnt;
 501                 return tcnt;
 502             }
 503         }
 504     }
 505
 506     switch (*inspec) {
 507     case 0x7f:
 508         outspec[0] = '^';
 509         outspec[1] = '7';
 510         outspec[2] = 'F';
 511         *output_cnt = 3;
 512         return 1;
 513         break;
 514     case '?':
 515         if (decc_efs_charset == 0)
 516           outspec[0] = '%';
 517         else
 518           outspec[0] = '?';
 519         *output_cnt = 1;
 520         return 1;
 521         break;
 522     case '.':
 523     case '~':
 524     case '!':
 525     case '#':
 526     case '&':
 527     case '\'':
 528     case '`':
 529     case '(':
 530     case ')':
 531     case '+':
 532     case '@':
 533     case '{':
 534     case '}':
 535     case ',':
 536     case ';':
 537     case '[':
 538     case ']':
 539     case '%':
 540     case '^':
 541     case '\\':
 542         /* Don't escape again if following character is
 543          * already something we escape.
 544          */
 545         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 546             *outspec = *inspec;
 547             *output_cnt = 1;
 548             return 1;
 549             break;
 550         }
 551         /* But otherwise fall through and escape it. */
 552     case '=':
 553         /* Assume that this is to be escaped */
 554         outspec[0] = '^';
 555         outspec[1] = *inspec;
 556         *output_cnt = 2;
 557         return 1;
 558         break;
 559     case ' ': /* space */
 560         /* Assume that this is to be escaped */
 561         outspec[0] = '^';
 562         outspec[1] = '_';
 563         *output_cnt = 2;
 564         return 1;
 565         break;
 566     default:
 567         *outspec = *inspec;
 568         *output_cnt = 1;
 569         return 1;
 570         break;
 571     }
 572     return 0;
 573 }
 574
 575
 576 /* This handles the expansion of a '^' prefix to the proper character
 577  * in a UNIX file specification.
 578  *
 579  * The output count variable contains the number of characters added
 580  * to the output string.
 581  *
 582  * The return value is the number of characters read from the input
 583  * string
 584  */
 585 static int copy_expand_vms_filename_escape
 586   (char *outspec, const char *inspec, int *output_cnt)
 587 {
 588 int count;
 589 int scnt;
 590
 591     count = 0;
 592     *output_cnt = 0;
 593     if (*inspec == '^') {
 594         inspec++;
 595         switch (*inspec) {
 596         /* Spaces and non-trailing dots should just be passed through,
 597          * but eat the escape character.
 598          */
 599         case '.':
 600             *outspec = *inspec;
 601             count += 2;
 602             (*output_cnt)++;
 603             break;
 604         case '_': /* space */
 605             *outspec = ' ';
 606             count += 2;
 607             (*output_cnt)++;
 608             break;
 609         case '^':
 610             /* Hmm.  Better leave the escape escaped. */
 611             outspec[0] = '^';
 612             outspec[1] = '^';
 613             count += 2;
 614             (*output_cnt) += 2;
 615             break;
 616         case 'U': /* Unicode - FIX-ME this is wrong. */
 617             inspec++;
 618             count++;
 619             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 620             if (scnt == 4) {
 621                 unsigned int c1, c2;
 622                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 623                 outspec[0] = c1 & 0xff;
 624                 outspec[1] = c2 & 0xff;
 625                 if (scnt > 1) {
 626                     (*output_cnt) += 2;
 627                     count += 4;
 628                 }
 629             }
 630             else {
 631                 /* Error - do best we can to continue */
 632                 *outspec = 'U';
 633                 outspec++;
 634                 (*output_cnt++);
 635                 *outspec = *inspec;
 636                 count++;
 637                 (*output_cnt++);
 638             }
 639             break;
 640         default:
 641             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 642             if (scnt == 2) {
 643                 /* Hex encoded */
 644                 unsigned int c1;
 645                 scnt = sscanf(inspec, "%2x", &c1);
 646                 outspec[0] = c1 & 0xff;
 647                 if (scnt > 0) {
 648                     (*output_cnt++);
 649                     count += 2;
 650                 }
 651             }
 652             else {
 653                 *outspec = *inspec;
 654                 count++;
 655                 (*output_cnt++);
 656             }
 657         }
 658     }
 659     else {
 660         *outspec = *inspec;
 661         count++;
 662         (*output_cnt)++;
 663     }
 664     return count;
 665 }
 666
 667 /* vms_split_path - Verify that the input file specification is a
 668  * VMS format file specification, and provide pointers to the components of
 669  * it.  With EFS format filenames, this is virtually the only way to
 670  * parse a VMS path specification into components.
 671  *
 672  * If the sum of the components do not add up to the length of the
 673  * string, then the passed file specification is probably a UNIX style
 674  * path.
 675  */
 676 static int vms_split_path
 677    (const char * path,
 678     char * * volume,
 679     int * vol_len,
 680     char * * root,
 681     int * root_len,
 682     char * * dir,
 683     int * dir_len,
 684     char * * name,
 685     int * name_len,
 686     char * * ext,
 687     int * ext_len,
 688     char * * version,
 689     int * ver_len)
 690 {
 691 struct dsc$descriptor path_desc;
 692 int status;
 693 unsigned long flags;
 694 int ret_stat;
 695 struct filescan_itmlst_2 item_list[9];
 696 const int filespec = 0;
 697 const int nodespec = 1;
 698 const int devspec = 2;
 699 const int rootspec = 3;
 700 const int dirspec = 4;
 701 const int namespec = 5;
 702 const int typespec = 6;
 703 const int verspec = 7;
 704
 705     /* Assume the worst for an easy exit */
 706     ret_stat = -1;
 707     *volume = NULL;
 708     *vol_len = 0;
 709     *root = NULL;
 710     *root_len = 0;
 711     *dir = NULL;
 712     *name = NULL;
 713     *name_len = 0;
 714     *ext = NULL;
 715     *ext_len = 0;
 716     *version = NULL;
 717     *ver_len = 0;
 718
 719     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 720     path_desc.dsc$w_length = strlen(path);
 721     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 722     path_desc.dsc$b_class = DSC$K_CLASS_S;
 723
 724     /* Get the total length, if it is shorter than the string passed
 725      * then this was probably not a VMS formatted file specification
 726      */
 727     item_list[filespec].itmcode = FSCN$_FILESPEC;
 728     item_list[filespec].length = 0;
 729     item_list[filespec].component = NULL;
 730
 731     /* If the node is present, then it gets considered as part of the
 732      * volume name to hopefully make things simple.
 733      */
 734     item_list[nodespec].itmcode = FSCN$_NODE;
 735     item_list[nodespec].length = 0;
 736     item_list[nodespec].component = NULL;
 737
 738     item_list[devspec].itmcode = FSCN$_DEVICE;
 739     item_list[devspec].length = 0;
 740     item_list[devspec].component = NULL;
 741
 742     /* root is a special case,  adding it to either the directory or
 743      * the device components will probably complicate things for the
 744      * callers of this routine, so leave it separate.
 745      */
 746     item_list[rootspec].itmcode = FSCN$_ROOT;
 747     item_list[rootspec].length = 0;
 748     item_list[rootspec].component = NULL;
 749
 750     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 751     item_list[dirspec].length = 0;
 752     item_list[dirspec].component = NULL;
 753
 754     item_list[namespec].itmcode = FSCN$_NAME;
 755     item_list[namespec].length = 0;
 756     item_list[namespec].component = NULL;
 757
 758     item_list[typespec].itmcode = FSCN$_TYPE;
 759     item_list[typespec].length = 0;
 760     item_list[typespec].component = NULL;
 761
 762     item_list[verspec].itmcode = FSCN$_VERSION;
 763     item_list[verspec].length = 0;
 764     item_list[verspec].component = NULL;
 765
 766     item_list[8].itmcode = 0;
 767     item_list[8].length = 0;
 768     item_list[8].component = NULL;
 769
 770     status = sys$filescan
 771        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 772         &flags, NULL, NULL);
 773     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 774
 775     /* If we parsed it successfully these two lengths should be the same */
 776     if (path_desc.dsc$w_length != item_list[filespec].length)
 777         return ret_stat;
 778
 779     /* If we got here, then it is a VMS file specification */
 780     ret_stat = 0;
 781
 782     /* set the volume name */
 783     if (item_list[nodespec].length > 0) {
 784         *volume = item_list[nodespec].component;
 785         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 786     }
 787     else {
 788         *volume = item_list[devspec].component;
 789         *vol_len = item_list[devspec].length;
 790     }
 791
 792     *root = item_list[rootspec].component;
 793     *root_len = item_list[rootspec].length;
 794
 795     *dir = item_list[dirspec].component;
 796     *dir_len = item_list[dirspec].length;
 797
 798     /* Now fun with versions and EFS file specifications
 799      * The parser can not tell the difference when a "." is a version
 800      * delimiter or a part of the file specification.
 801      */
 802     if ((decc_efs_charset) &&
 803         (item_list[verspec].length > 0) &&
 804         (item_list[verspec].component[0] == '.')) {
 805         *name = item_list[namespec].component;
 806         *name_len = item_list[namespec].length + item_list[typespec].length;
 807         *ext = item_list[verspec].component;
 808         *ext_len = item_list[verspec].length;
 809         *version = NULL;
 810         *ver_len = 0;
 811     }
 812     else {
 813         *name = item_list[namespec].component;
 814         *name_len = item_list[namespec].length;
 815         *ext = item_list[typespec].component;
 816         *ext_len = item_list[typespec].length;
 817         *version = item_list[verspec].component;
 818         *ver_len = item_list[verspec].length;
 819     }
 820     return ret_stat;
 821 }
 822
 823 /* Routine to determine if the file specification ends with .dir */
 824 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 825
 826     /* e_len must be 4, and version must be <= 2 characters */
 827     if (e_len != 4 || vs_len > 2)
 828         return 0;
 829
 830     /* If a version number is present, it needs to be one */
 831     if ((vs_len == 2) && (vs_spec[1] != '1'))
 832         return 0;
 833
 834     /* Look for the DIR on the extension */
 835     if (vms_process_case_tolerant) {
 836         if ((toupper(e_spec[1]) == 'D') &&
 837             (toupper(e_spec[2]) == 'I') &&
 838             (toupper(e_spec[3]) == 'R')) {
 839             return 1;
 840         }
 841     } else {
 842         /* Directory extensions are supposed to be in upper case only */
 843         /* I would not be surprised if this rule can not be enforced */
 844         /* if and when someone fully debugs the case sensitive mode */
 845         if ((e_spec[1] == 'D') &&
 846             (e_spec[2] == 'I') &&
 847             (e_spec[3] == 'R')) {
 848             return 1;
 849         }
 850     }
 851     return 0;
 852 }
 853
 854
 855 /* my_maxidx
 856  * Routine to retrieve the maximum equivalence index for an input
 857  * logical name.  Some calls to this routine have no knowledge if
 858  * the variable is a logical or not.  So on error we return a max
 859  * index of zero.
 860  */
 861 /*{{{int my_maxidx(const char *lnm) */
 862 static int
 863 my_maxidx(const char *lnm)
 864 {
 865     int status;
 866     int midx;
 867     int attr = LNM$M_CASE_BLIND;
 868     struct dsc$descriptor lnmdsc;
 869     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 870                                 {0, 0, 0, 0}};
 871
 872     lnmdsc.dsc$w_length = strlen(lnm);
 873     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 874     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 875     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 876
 877     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 878     if ((status & 1) == 0)
 879        midx = 0;
 880
 881     return (midx);
 882 }
 883 /*}}}*/
 884
 885 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 886 int
 887 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 888   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 889 {
 890     const char *cp1;
 891     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 892     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 893     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 894     int midx;
 895     unsigned char acmode;
 896     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 897                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 898     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 899                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 900                                  {0, 0, 0, 0}};
 901     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 902 #if defined(PERL_IMPLICIT_CONTEXT)
 903     pTHX = NULL;
 904     if (PL_curinterp) {
 905       aTHX = PERL_GET_INTERP;
 906     } else {
 907       aTHX = NULL;
 908     }
 909 #endif
 910
 911     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 912       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 913     }
 914     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 915       *cp2 = _toupper(*cp1);
 916       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 917         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 918         return 0;
 919       }
 920     }
 921     lnmdsc.dsc$w_length = cp1 - lnm;
 922     lnmdsc.dsc$a_pointer = uplnm;
 923     uplnm[lnmdsc.dsc$w_length] = '\0';
 924     secure = flags & PERL__TRNENV_SECURE;
 925     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 926     if (!tabvec || !*tabvec) tabvec = env_tables;
 927
 928     for (curtab = 0; tabvec[curtab]; curtab++) {
 929       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 930         if (!ivenv && !secure) {
 931           char *eq;
 932           int i;
 933           if (!environ) {
 934             ivenv = 1;
 935 #if defined(PERL_IMPLICIT_CONTEXT)
 936             if (aTHX == NULL) {
 937                 fprintf(stderr,
 938                     "Can't read CRTL environ\n");
 939             } else
 940 #endif
 941                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 942             continue;
 943           }
 944           retsts = SS$_NOLOGNAM;
 945           for (i = 0; environ[i]; i++) {
 946             if ((eq = strchr(environ[i],'=')) &&
 947                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 948                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 949               eq++;
 950               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 951               if (!eqvlen) continue;
 952               retsts = SS$_NORMAL;
 953               break;
 954             }
 955           }
 956           if (retsts != SS$_NOLOGNAM) break;
 957         }
 958       }
 959       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 960                !str$case_blind_compare(&tmpdsc,&clisym)) {
 961         if (!ivsym && !secure) {
 962           unsigned short int deflen = LNM$C_NAMLENGTH;
 963           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 964           /* dynamic dsc to accommodate possible long value */
 965           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 966           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 967           if (retsts & 1) {
 968             if (eqvlen > MAX_DCL_SYMBOL) {
 969               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 970               eqvlen = MAX_DCL_SYMBOL;
 971               /* Special hack--we might be called before the interpreter's */
 972               /* fully initialized, in which case either thr or PL_curcop */
 973               /* might be bogus. We have to check, since ckWARN needs them */
 974               /* both to be valid if running threaded */
 975 #if defined(PERL_IMPLICIT_CONTEXT)
 976               if (aTHX == NULL) {
 977                   fprintf(stderr,
 978                      "Value of CLI symbol \"%s\" too long",lnm);
 979               } else
 980 #endif
 981                 if (ckWARN(WARN_MISC)) {
 982                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 983                 }
 984             }
 985             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 986           }
 987           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
 988           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 989           if (retsts == LIB$_NOSUCHSYM) continue;
 990           break;
 991         }
 992       }
 993       else if (!ivlnm) {
 994         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 995           midx = my_maxidx(lnm);
 996           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 997             lnmlst[1].bufadr = cp2;
 998             eqvlen = 0;
 999             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1000             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1001             if (retsts == SS$_NOLOGNAM) break;
1002             /* PPFs have a prefix */
1003             if (
1004 #if INTSIZE == 4
1005                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1006 #endif
1007                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1008                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1009                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1010                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1011                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1012               memmove(eqv,eqv+4,eqvlen-4);
1013               eqvlen -= 4;
1014             }
1015             cp2 += eqvlen;
1016             *cp2 = '\0';
1017           }
1018           if ((retsts == SS$_IVLOGNAM) ||
1019               (retsts == SS$_NOLOGNAM)) { continue; }
1020         }
1021         else {
1022           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1023           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1024           if (retsts == SS$_NOLOGNAM) continue;
1025           eqv[eqvlen] = '\0';
1026         }
1027         eqvlen = strlen(eqv);
1028         break;
1029       }
1030     }
1031     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1032     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1033              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1034              retsts == SS$_NOLOGNAM) {
1035       set_errno(EINVAL);  set_vaxc_errno(retsts);
1036     }
1037     else _ckvmssts_noperl(retsts);
1038     return 0;
1039 }  /* end of vmstrnenv */
1040 /*}}}*/
1041
1042 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1043 /* Define as a function so we can access statics. */
1044 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1045 {
1046     int flags = 0;
1047
1048 #if defined(PERL_IMPLICIT_CONTEXT)
1049     if (aTHX != NULL)
1050 #endif
1051 #ifdef SECURE_INTERNAL_GETENV
1052         flags = (PL_curinterp ? TAINTING_get : will_taint) ?
1053                  PERL__TRNENV_SECURE : 0;
1054 #endif
1055
1056     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1057 }
1058 /*}}}*/
1059
1060 /* my_getenv
1061  * Note: Uses Perl temp to store result so char * can be returned to
1062  * caller; this pointer will be invalidated at next Perl statement
1063  * transition.
1064  * We define this as a function rather than a macro in terms of my_getenv_len()
1065  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1066  * allocate SVs).
1067  */
1068 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1069 char *
1070 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1071 {
1072     const char *cp1;
1073     static char *__my_getenv_eqv = NULL;
1074     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1075     unsigned long int idx = 0;
1076     int success, secure, saverr, savvmserr;
1077     int midx, flags;
1078     SV *tmpsv;
1079
1080     midx = my_maxidx(lnm) + 1;
1081
1082     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1083       /* Set up a temporary buffer for the return value; Perl will
1084        * clean it up at the next statement transition */
1085       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1086       if (!tmpsv) return NULL;
1087       eqv = SvPVX(tmpsv);
1088     }
1089     else {
1090       /* Assume no interpreter ==> single thread */
1091       if (__my_getenv_eqv != NULL) {
1092         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1093       }
1094       else {
1095         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1096       }
1097       eqv = __my_getenv_eqv;
1098     }
1099
1100     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1101     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1102       int len;
1103       getcwd(eqv,LNM$C_NAMLENGTH);
1104
1105       len = strlen(eqv);
1106
1107       /* Get rid of "000000/ in rooted filespecs */
1108       if (len > 7) {
1109         char * zeros;
1110         zeros = strstr(eqv, "/000000/");
1111         if (zeros != NULL) {
1112           int mlen;
1113           mlen = len - (zeros - eqv) - 7;
1114           memmove(zeros, &zeros[7], mlen);
1115           len = len - 7;
1116           eqv[len] = '\0';
1117         }
1118       }
1119       return eqv;
1120     }
1121     else {
1122       /* Impose security constraints only if tainting */
1123       if (sys) {
1124         /* Impose security constraints only if tainting */
1125         secure = PL_curinterp ? TAINTING_get : will_taint;
1126         saverr = errno;  savvmserr = vaxc$errno;
1127       }
1128       else {
1129         secure = 0;
1130       }
1131
1132       flags =
1133 #ifdef SECURE_INTERNAL_GETENV
1134               secure ? PERL__TRNENV_SECURE : 0
1135 #else
1136               0
1137 #endif
1138       ;
1139
1140       /* For the getenv interface we combine all the equivalence names
1141        * of a search list logical into one value to acquire a maximum
1142        * value length of 255*128 (assuming %ENV is using logicals).
1143        */
1144       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1145
1146       /* If the name contains a semicolon-delimited index, parse it
1147        * off and make sure we only retrieve the equivalence name for
1148        * that index.  */
1149       if ((cp2 = strchr(lnm,';')) != NULL) {
1150         my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1151         idx = strtoul(cp2+1,NULL,0);
1152         lnm = uplnm;
1153         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1154       }
1155
1156       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1157
1158       /* Discard NOLOGNAM on internal calls since we're often looking
1159        * for an optional name, and this "error" often shows up as the
1160        * (bogus) exit status for a die() call later on.  */
1161       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1162       return success ? eqv : NULL;
1163     }
1164
1165 }  /* end of my_getenv() */
1166 /*}}}*/
1167
1168
1169 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1170 char *
1171 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1172 {
1173     const char *cp1;
1174     char *buf, *cp2;
1175     unsigned long idx = 0;
1176     int midx, flags;
1177     static char *__my_getenv_len_eqv = NULL;
1178     int secure, saverr, savvmserr;
1179     SV *tmpsv;
1180
1181     midx = my_maxidx(lnm) + 1;
1182
1183     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1184       /* Set up a temporary buffer for the return value; Perl will
1185        * clean it up at the next statement transition */
1186       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1187       if (!tmpsv) return NULL;
1188       buf = SvPVX(tmpsv);
1189     }
1190     else {
1191       /* Assume no interpreter ==> single thread */
1192       if (__my_getenv_len_eqv != NULL) {
1193         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1194       }
1195       else {
1196         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1197       }
1198       buf = __my_getenv_len_eqv;
1199     }
1200
1201     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1202     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1203     char * zeros;
1204
1205       getcwd(buf,LNM$C_NAMLENGTH);
1206       *len = strlen(buf);
1207
1208       /* Get rid of "000000/ in rooted filespecs */
1209       if (*len > 7) {
1210       zeros = strstr(buf, "/000000/");
1211       if (zeros != NULL) {
1212         int mlen;
1213         mlen = *len - (zeros - buf) - 7;
1214         memmove(zeros, &zeros[7], mlen);
1215         *len = *len - 7;
1216         buf[*len] = '\0';
1217         }
1218       }
1219       return buf;
1220     }
1221     else {
1222       if (sys) {
1223         /* Impose security constraints only if tainting */
1224         secure = PL_curinterp ? TAINTING_get : will_taint;
1225         saverr = errno;  savvmserr = vaxc$errno;
1226       }
1227       else {
1228         secure = 0;
1229       }
1230
1231       flags =
1232 #ifdef SECURE_INTERNAL_GETENV
1233               secure ? PERL__TRNENV_SECURE : 0
1234 #else
1235               0
1236 #endif
1237       ;
1238
1239       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1240
1241       if ((cp2 = strchr(lnm,';')) != NULL) {
1242         my_strlcpy(buf, lnm, cp2 - lnm + 1);
1243         idx = strtoul(cp2+1,NULL,0);
1244         lnm = buf;
1245         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1246       }
1247
1248       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1249
1250       /* Get rid of "000000/ in rooted filespecs */
1251       if (*len > 7) {
1252       char * zeros;
1253         zeros = strstr(buf, "/000000/");
1254         if (zeros != NULL) {
1255           int mlen;
1256           mlen = *len - (zeros - buf) - 7;
1257           memmove(zeros, &zeros[7], mlen);
1258           *len = *len - 7;
1259           buf[*len] = '\0';
1260         }
1261       }
1262
1263       /* Discard NOLOGNAM on internal calls since we're often looking
1264        * for an optional name, and this "error" often shows up as the
1265        * (bogus) exit status for a die() call later on.  */
1266       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1267       return *len ? buf : NULL;
1268     }
1269
1270 }  /* end of my_getenv_len() */
1271 /*}}}*/
1272
1273 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1274
1275 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1276
1277 /*{{{ void prime_env_iter() */
1278 void
1279 prime_env_iter(void)
1280 /* Fill the %ENV associative array with all logical names we can
1281  * find, in preparation for iterating over it.
1282  */
1283 {
1284   static int primed = 0;
1285   HV *seenhv = NULL, *envhv;
1286   SV *sv = NULL;
1287   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1288   unsigned short int chan;
1289 #ifndef CLI$M_TRUSTED
1290 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1291 #endif
1292   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1293   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1294   long int i;
1295   bool have_sym = FALSE, have_lnm = FALSE;
1296   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1297   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1298   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1299   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1300   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1301 #if defined(PERL_IMPLICIT_CONTEXT)
1302   pTHX;
1303 #endif
1304 #if defined(USE_ITHREADS)
1305   static perl_mutex primenv_mutex;
1306   MUTEX_INIT(&primenv_mutex);
1307 #endif
1308
1309 #if defined(PERL_IMPLICIT_CONTEXT)
1310     /* We jump through these hoops because we can be called at */
1311     /* platform-specific initialization time, which is before anything is */
1312     /* set up--we can't even do a plain dTHX since that relies on the */
1313     /* interpreter structure to be initialized */
1314     if (PL_curinterp) {
1315       aTHX = PERL_GET_INTERP;
1316     } else {
1317       /* we never get here because the NULL pointer will cause the */
1318       /* several of the routines called by this routine to access violate */
1319
1320       /* This routine is only called by hv.c/hv_iterinit which has a */
1321       /* context, so the real fix may be to pass it through instead of */
1322       /* the hoops above */
1323       aTHX = NULL;
1324     }
1325 #endif
1326
1327   if (primed || !PL_envgv) return;
1328   MUTEX_LOCK(&primenv_mutex);
1329   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1330   envhv = GvHVn(PL_envgv);
1331   /* Perform a dummy fetch as an lval to insure that the hash table is
1332    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1333   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1334
1335   for (i = 0; env_tables[i]; i++) {
1336      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1337          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1338      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1339   }
1340   if (have_sym || have_lnm) {
1341     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1342     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1343     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1344     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1345   }
1346
1347   for (i--; i >= 0; i--) {
1348     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1349       char *start;
1350       int j;
1351       for (j = 0; environ[j]; j++) {
1352         if (!(start = strchr(environ[j],'='))) {
1353           if (ckWARN(WARN_INTERNAL))
1354             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1355         }
1356         else {
1357           start++;
1358           sv = newSVpv(start,0);
1359           SvTAINTED_on(sv);
1360           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1361         }
1362       }
1363       continue;
1364     }
1365     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1366              !str$case_blind_compare(&tmpdsc,&clisym)) {
1367       my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1368       cmddsc.dsc$w_length = 20;
1369       if (env_tables[i]->dsc$w_length == 12 &&
1370           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1371           !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local  *", sizeof(cmd)-12);
1372       flags = defflags | CLI$M_NOLOGNAM;
1373     }
1374     else {
1375       my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1376       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1377         my_strlcat(cmd," /Table=", sizeof(cmd));
1378         cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, env_tables[i]->dsc$w_length + 1);
1379       }
1380       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1381       flags = defflags | CLI$M_NOCLISYM;
1382     }
1383
1384     /* Create a new subprocess to execute each command, to exclude the
1385      * remote possibility that someone could subvert a mbx or file used
1386      * to write multiple commands to a single subprocess.
1387      */
1388     do {
1389       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1390                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1391       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1392       defflags &= ~CLI$M_TRUSTED;
1393     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1394     _ckvmssts(retsts);
1395     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1396     if (seenhv) SvREFCNT_dec(seenhv);
1397     seenhv = newHV();
1398     while (1) {
1399       char *cp1, *cp2, *key;
1400       unsigned long int sts, iosb[2], retlen, keylen;
1401       U32 hash;
1402
1403       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1404       if (sts & 1) sts = iosb[0] & 0xffff;
1405       if (sts == SS$_ENDOFFILE) {
1406         int wakect = 0;
1407         while (substs == 0) { sys$hiber(); wakect++;}
1408         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1409         _ckvmssts(substs);
1410         break;
1411       }
1412       _ckvmssts(sts);
1413       retlen = iosb[0] >> 16;
1414       if (!retlen) continue;  /* blank line */
1415       buf[retlen] = '\0';
1416       if (iosb[1] != subpid) {
1417         if (iosb[1]) {
1418           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1419         }
1420         continue;
1421       }
1422       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1423         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1424
1425       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1426       if (*cp1 == '(' || /* Logical name table name */
1427           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1428       if (*cp1 == '"') cp1++;
1429       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1430       key = cp1;  keylen = cp2 - cp1;
1431       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1432       while (*cp2 && *cp2 != '=') cp2++;
1433       while (*cp2 && *cp2 == '=') cp2++;
1434       while (*cp2 && *cp2 == ' ') cp2++;
1435       if (*cp2 == '"') {  /* String translation; may embed "" */
1436         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1437         cp2++;  cp1--; /* Skip "" surrounding translation */
1438       }
1439       else {  /* Numeric translation */
1440         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1441         cp1--;  /* stop on last non-space char */
1442       }
1443       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1444         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1445         continue;
1446       }
1447       PERL_HASH(hash,key,keylen);
1448
1449       if (cp1 == cp2 && *cp2 == '.') {
1450         /* A single dot usually means an unprintable character, such as a null
1451          * to indicate a zero-length value.  Get the actual value to make sure.
1452          */
1453         char lnm[LNM$C_NAMLENGTH+1];
1454         char eqv[MAX_DCL_SYMBOL+1];
1455         int trnlen;
1456         strncpy(lnm, key, keylen);
1457         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1458         sv = newSVpvn(eqv, strlen(eqv));
1459       }
1460       else {
1461         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1462       }
1463
1464       SvTAINTED_on(sv);
1465       hv_store(envhv,key,keylen,sv,hash);
1466       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1467     }
1468     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1469       /* get the PPFs for this process, not the subprocess */
1470       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1471       char eqv[LNM$C_NAMLENGTH+1];
1472       int trnlen, i;
1473       for (i = 0; ppfs[i]; i++) {
1474         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1475         sv = newSVpv(eqv,trnlen);
1476         SvTAINTED_on(sv);
1477         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1478       }
1479     }
1480   }
1481   primed = 1;
1482   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1483   if (buf) Safefree(buf);
1484   if (seenhv) SvREFCNT_dec(seenhv);
1485   MUTEX_UNLOCK(&primenv_mutex);
1486   return;
1487
1488 }  /* end of prime_env_iter */
1489 /*}}}*/
1490
1491
1492 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1493 /* Define or delete an element in the same "environment" as
1494  * vmstrnenv().  If an element is to be deleted, it's removed from
1495  * the first place it's found.  If it's to be set, it's set in the
1496  * place designated by the first element of the table vector.
1497  * Like setenv() returns 0 for success, non-zero on error.
1498  */
1499 int
1500 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1501 {
1502     const char *cp1;
1503     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1504     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1505     int nseg = 0, j;
1506     unsigned long int retsts, usermode = PSL$C_USER;
1507     struct itmlst_3 *ile, *ilist;
1508     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1509                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1510                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1511     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1512     $DESCRIPTOR(local,"_LOCAL");
1513
1514     if (!lnm) {
1515         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1516         return SS$_IVLOGNAM;
1517     }
1518
1519     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1520       *cp2 = _toupper(*cp1);
1521       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1522         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1523         return SS$_IVLOGNAM;
1524       }
1525     }
1526     lnmdsc.dsc$w_length = cp1 - lnm;
1527     if (!tabvec || !*tabvec) tabvec = env_tables;
1528
1529     if (!eqv) {  /* we're deleting n element */
1530       for (curtab = 0; tabvec[curtab]; curtab++) {
1531         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1532         int i;
1533           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1534             if ((cp1 = strchr(environ[i],'=')) &&
1535                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1536                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1537 #ifdef HAS_SETENV
1538               return setenv(lnm,"",1) ? vaxc$errno : 0;
1539             }
1540           }
1541           ivenv = 1; retsts = SS$_NOLOGNAM;
1542 #else
1543               if (ckWARN(WARN_INTERNAL))
1544                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1545               ivenv = 1; retsts = SS$_NOSUCHPGM;
1546               break;
1547             }
1548           }
1549 #endif
1550         }
1551         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1552                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1553           unsigned int symtype;
1554           if (tabvec[curtab]->dsc$w_length == 12 &&
1555               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1556               !str$case_blind_compare(&tmpdsc,&local))
1557             symtype = LIB$K_CLI_LOCAL_SYM;
1558           else symtype = LIB$K_CLI_GLOBAL_SYM;
1559           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1560           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1561           if (retsts == LIB$_NOSUCHSYM) continue;
1562           break;
1563         }
1564         else if (!ivlnm) {
1565           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1566           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1567           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1568           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1569           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1570         }
1571       }
1572     }
1573     else {  /* we're defining a value */
1574       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1575 #ifdef HAS_SETENV
1576         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1577 #else
1578         if (ckWARN(WARN_INTERNAL))
1579           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1580         retsts = SS$_NOSUCHPGM;
1581 #endif
1582       }
1583       else {
1584         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1585         eqvdsc.dsc$w_length  = strlen(eqv);
1586         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1587             !str$case_blind_compare(&tmpdsc,&clisym)) {
1588           unsigned int symtype;
1589           if (tabvec[0]->dsc$w_length == 12 &&
1590               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1591                !str$case_blind_compare(&tmpdsc,&local))
1592             symtype = LIB$K_CLI_LOCAL_SYM;
1593           else symtype = LIB$K_CLI_GLOBAL_SYM;
1594           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1595         }
1596         else {
1597           if (!*eqv) eqvdsc.dsc$w_length = 1;
1598           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1599
1600             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1601             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1602               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1603                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1604               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1605               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1606             }
1607
1608             Newx(ilist,nseg+1,struct itmlst_3);
1609             ile = ilist;
1610             if (!ile) {
1611               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1612               return SS$_INSFMEM;
1613             }
1614             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1615
1616             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1617               ile->itmcode = LNM$_STRING;
1618               ile->bufadr = c;
1619               if ((j+1) == nseg) {
1620                 ile->buflen = strlen(c);
1621                 /* in case we are truncating one that's too long */
1622                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1623               }
1624               else {
1625                 ile->buflen = LNM$C_NAMLENGTH;
1626               }
1627             }
1628
1629             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1630             Safefree (ilist);
1631           }
1632           else {
1633             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1634           }
1635         }
1636       }
1637     }
1638     if (!(retsts & 1)) {
1639       switch (retsts) {
1640         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1641         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1642           set_errno(EVMSERR); break;
1643         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1644         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1645           set_errno(EINVAL); break;
1646         case SS$_NOPRIV:
1647           set_errno(EACCES); break;
1648         default:
1649           _ckvmssts(retsts);
1650           set_errno(EVMSERR);
1651        }
1652        set_vaxc_errno(retsts);
1653        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1654     }
1655     else {
1656       /* We reset error values on success because Perl does an hv_fetch()
1657        * before each hv_store(), and if the thing we're setting didn't
1658        * previously exist, we've got a leftover error message.  (Of course,
1659        * this fails in the face of
1660        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1661        * in that the error reported in $! isn't spurious,
1662        * but it's right more often than not.)
1663        */
1664       set_errno(0); set_vaxc_errno(retsts);
1665       return 0;
1666     }
1667
1668 }  /* end of vmssetenv() */
1669 /*}}}*/
1670
1671 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1672 /* This has to be a function since there's a prototype for it in proto.h */
1673 void
1674 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1675 {
1676     if (lnm && *lnm) {
1677       int len = strlen(lnm);
1678       if  (len == 7) {
1679         char uplnm[8];
1680         int i;
1681         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1682         if (!strcmp(uplnm,"DEFAULT")) {
1683           if (eqv && *eqv) my_chdir(eqv);
1684           return;
1685         }
1686     }
1687   }
1688   (void) vmssetenv(lnm,eqv,NULL);
1689 }
1690 /*}}}*/
1691
1692 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1693 /*  vmssetuserlnm
1694  *  sets a user-mode logical in the process logical name table
1695  *  used for redirection of sys$error
1696  */
1697 void
1698 Perl_vmssetuserlnm(const char *name, const char *eqv)
1699 {
1700     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1701     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1702     unsigned long int iss, attr = LNM$M_CONFINE;
1703     unsigned char acmode = PSL$C_USER;
1704     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1705                                  {0, 0, 0, 0}};
1706     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1707     d_name.dsc$w_length = strlen(name);
1708
1709     lnmlst[0].buflen = strlen(eqv);
1710     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1711
1712     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1713     if (!(iss&1)) lib$signal(iss);
1714 }
1715 /*}}}*/
1716
1717
1718 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1719 /* my_crypt - VMS password hashing
1720  * my_crypt() provides an interface compatible with the Unix crypt()
1721  * C library function, and uses sys$hash_password() to perform VMS
1722  * password hashing.  The quadword hashed password value is returned
1723  * as a NUL-terminated 8 character string.  my_crypt() does not change
1724  * the case of its string arguments; in order to match the behavior
1725  * of LOGINOUT et al., alphabetic characters in both arguments must
1726  *  be upcased by the caller.
1727  *
1728  * - fix me to call ACM services when available
1729  */
1730 char *
1731 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1732 {
1733 #   ifndef UAI$C_PREFERRED_ALGORITHM
1734 #     define UAI$C_PREFERRED_ALGORITHM 127
1735 #   endif
1736     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1737     unsigned short int salt = 0;
1738     unsigned long int sts;
1739     struct const_dsc {
1740         unsigned short int dsc$w_length;
1741         unsigned char      dsc$b_type;
1742         unsigned char      dsc$b_class;
1743         const char *       dsc$a_pointer;
1744     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1745        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1746     struct itmlst_3 uailst[3] = {
1747         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1748         { sizeof salt, UAI$_SALT,    &salt, 0},
1749         { 0,           0,            NULL,  NULL}};
1750     static char hash[9];
1751
1752     usrdsc.dsc$w_length = strlen(usrname);
1753     usrdsc.dsc$a_pointer = usrname;
1754     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1755       switch (sts) {
1756         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1757           set_errno(EACCES);
1758           break;
1759         case RMS$_RNF:
1760           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1761           break;
1762         default:
1763           set_errno(EVMSERR);
1764       }
1765       set_vaxc_errno(sts);
1766       if (sts != RMS$_RNF) return NULL;
1767     }
1768
1769     txtdsc.dsc$w_length = strlen(textpasswd);
1770     txtdsc.dsc$a_pointer = textpasswd;
1771     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1772       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1773     }
1774
1775     return (char *) hash;
1776
1777 }  /* end of my_crypt() */
1778 /*}}}*/
1779
1780
1781 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1782 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1783 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1784
1785 /* fixup barenames that are directories for internal use.
1786  * There have been problems with the consistent handling of UNIX
1787  * style directory names when routines are presented with a name that
1788  * has no directory delimiters at all.  So this routine will eventually
1789  * fix the issue.
1790  */
1791 static char * fixup_bare_dirnames(const char * name)
1792 {
1793   if (decc_disable_to_vms_logname_translation) {
1794 /* fix me */
1795   }
1796   return NULL;
1797 }
1798
1799 /* 8.3, remove() is now broken on symbolic links */
1800 static int rms_erase(const char * vmsname);
1801
1802
1803 /* mp_do_kill_file
1804  * A little hack to get around a bug in some implementation of remove()
1805  * that do not know how to delete a directory
1806  *
1807  * Delete any file to which user has control access, regardless of whether
1808  * delete access is explicitly allowed.
1809  * Limitations: User must have write access to parent directory.
1810  *              Does not block signals or ASTs; if interrupted in midstream
1811  *              may leave file with an altered ACL.
1812  * HANDLE WITH CARE!
1813  */
1814 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1815 static int
1816 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1817 {
1818     char *vmsname;
1819     char *rslt;
1820     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1821     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1822     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1823     struct myacedef {
1824       unsigned char myace$b_length;
1825       unsigned char myace$b_type;
1826       unsigned short int myace$w_flags;
1827       unsigned long int myace$l_access;
1828       unsigned long int myace$l_ident;
1829     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1830                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1831       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1832      struct itmlst_3
1833        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1834                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1835        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1836        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1837        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1838        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1839
1840     /* Expand the input spec using RMS, since the CRTL remove() and
1841      * system services won't do this by themselves, so we may miss
1842      * a file "hiding" behind a logical name or search list. */
1843     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1844     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1845
1846     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1847     if (rslt == NULL) {
1848         PerlMem_free(vmsname);
1849         return -1;
1850       }
1851
1852     /* Erase the file */
1853     rmsts = rms_erase(vmsname);
1854
1855     /* Did it succeed */
1856     if ($VMS_STATUS_SUCCESS(rmsts)) {
1857         PerlMem_free(vmsname);
1858         return 0;
1859       }
1860
1861     /* If not, can changing protections help? */
1862     if (rmsts != RMS$_PRV) {
1863       set_vaxc_errno(rmsts);
1864       PerlMem_free(vmsname);
1865       return -1;
1866     }
1867
1868     /* No, so we get our own UIC to use as a rights identifier,
1869      * and the insert an ACE at the head of the ACL which allows us
1870      * to delete the file.
1871      */
1872     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1873     fildsc.dsc$w_length = strlen(vmsname);
1874     fildsc.dsc$a_pointer = vmsname;
1875     cxt = 0;
1876     newace.myace$l_ident = oldace.myace$l_ident;
1877     rmsts = -1;
1878     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1879       switch (aclsts) {
1880         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1881           set_errno(ENOENT); break;
1882         case RMS$_DIR:
1883           set_errno(ENOTDIR); break;
1884         case RMS$_DEV:
1885           set_errno(ENODEV); break;
1886         case RMS$_SYN: case SS$_INVFILFOROP:
1887           set_errno(EINVAL); break;
1888         case RMS$_PRV:
1889           set_errno(EACCES); break;
1890         default:
1891           _ckvmssts_noperl(aclsts);
1892       }
1893       set_vaxc_errno(aclsts);
1894       PerlMem_free(vmsname);
1895       return -1;
1896     }
1897     /* Grab any existing ACEs with this identifier in case we fail */
1898     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1899     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1900                     || fndsts == SS$_NOMOREACE ) {
1901       /* Add the new ACE . . . */
1902       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1903         goto yourroom;
1904
1905       rmsts = rms_erase(vmsname);
1906       if ($VMS_STATUS_SUCCESS(rmsts)) {
1907         rmsts = 0;
1908         }
1909         else {
1910         rmsts = -1;
1911         /* We blew it - dir with files in it, no write priv for
1912          * parent directory, etc.  Put things back the way they were. */
1913         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1914           goto yourroom;
1915         if (fndsts & 1) {
1916           addlst[0].bufadr = &oldace;
1917           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1918             goto yourroom;
1919         }
1920       }
1921     }
1922
1923     yourroom:
1924     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1925     /* We just deleted it, so of course it's not there.  Some versions of
1926      * VMS seem to return success on the unlock operation anyhow (after all
1927      * the unlock is successful), but others don't.
1928      */
1929     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1930     if (aclsts & 1) aclsts = fndsts;
1931     if (!(aclsts & 1)) {
1932       set_errno(EVMSERR);
1933       set_vaxc_errno(aclsts);
1934     }
1935
1936     PerlMem_free(vmsname);
1937     return rmsts;
1938
1939 }  /* end of kill_file() */
1940 /*}}}*/
1941
1942
1943 /*{{{int do_rmdir(char *name)*/
1944 int
1945 Perl_do_rmdir(pTHX_ const char *name)
1946 {
1947     char * dirfile;
1948     int retval;
1949     Stat_t st;
1950
1951     /* lstat returns a VMS fileified specification of the name */
1952     /* that is looked up, and also lets verifies that this is a directory */
1953
1954     retval = flex_lstat(name, &st);
1955     if (retval != 0) {
1956         char * ret_spec;
1957
1958         /* Due to a historical feature, flex_stat/lstat can not see some */
1959         /* Unix format file names that the rest of the CRTL can see */
1960         /* Fixing that feature will cause some perl tests to fail */
1961         /* So try this one more time. */
1962
1963         retval = lstat(name, &st.crtl_stat);
1964         if (retval != 0)
1965             return -1;
1966
1967         /* force it to a file spec for the kill file to work. */
1968         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1969         if (ret_spec == NULL) {
1970             errno = EIO;
1971             return -1;
1972         }
1973     }
1974
1975     if (!S_ISDIR(st.st_mode)) {
1976         errno = ENOTDIR;
1977         retval = -1;
1978     }
1979     else {
1980         dirfile = st.st_devnam;
1981
1982         /* It may be possible for flex_stat to find a file and vmsify() to */
1983         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
1984         /* with that case, so fail it */
1985         if (dirfile[0] == 0) {
1986             errno = EIO;
1987             return -1;
1988         }
1989
1990         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1991     }
1992
1993     return retval;
1994
1995 }  /* end of do_rmdir */
1996 /*}}}*/
1997
1998 /* kill_file
1999  * Delete any file to which user has control access, regardless of whether
2000  * delete access is explicitly allowed.
2001  * Limitations: User must have write access to parent directory.
2002  *              Does not block signals or ASTs; if interrupted in midstream
2003  *              may leave file with an altered ACL.
2004  * HANDLE WITH CARE!
2005  */
2006 /*{{{int kill_file(char *name)*/
2007 int
2008 Perl_kill_file(pTHX_ const char *name)
2009 {
2010     char * vmsfile;
2011     Stat_t st;
2012     int rmsts;
2013
2014     /* Convert the filename to VMS format and see if it is a directory */
2015     /* flex_lstat returns a vmsified file specification */
2016     rmsts = flex_lstat(name, &st);
2017     if (rmsts != 0) {
2018
2019         /* Due to a historical feature, flex_stat/lstat can not see some */
2020         /* Unix format file names that the rest of the CRTL can see when */
2021         /* ODS-2 file specifications are in use. */
2022         /* Fixing that feature will cause some perl tests to fail */
2023         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2024         st.st_mode = 0;
2025         vmsfile = (char *) name; /* cast ok */
2026
2027     } else {
2028         vmsfile = st.st_devnam;
2029         if (vmsfile[0] == 0) {
2030             /* It may be possible for flex_stat to find a file and vmsify() */
2031             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2032             /* deal with that case, so fail it */
2033             errno = EIO;
2034             return -1;
2035         }
2036     }
2037
2038     /* Remove() is allowed to delete directories, according to the X/Open
2039      * specifications.
2040      * This may need special handling to work with the ACL hacks.
2041      */
2042     if (S_ISDIR(st.st_mode)) {
2043         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2044         return rmsts;
2045     }
2046
2047     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2048
2049     /* Need to delete all versions ? */
2050     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2051         int i = 0;
2052
2053         /* Just use lstat() here as do not need st_dev */
2054         /* and we know that the file is in VMS format or that */
2055         /* because of a historical bug, flex_stat can not see the file */
2056         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2057             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2058             if (rmsts != 0)
2059                 break;
2060             i++;
2061
2062             /* Make sure that we do not loop forever */
2063             if (i > 32767) {
2064                 errno = EIO;
2065                 rmsts = -1;
2066                 break;
2067             }
2068         }
2069     }
2070
2071     return rmsts;
2072
2073 }  /* end of kill_file() */
2074 /*}}}*/
2075
2076
2077 /*{{{int my_mkdir(char *,Mode_t)*/
2078 int
2079 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2080 {
2081   STRLEN dirlen = strlen(dir);
2082
2083   /* zero length string sometimes gives ACCVIO */
2084   if (dirlen == 0) return -1;
2085
2086   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2087    * null file name/type.  However, it's commonplace under Unix,
2088    * so we'll allow it for a gain in portability.
2089    */
2090   if (dir[dirlen-1] == '/') {
2091     char *newdir = savepvn(dir,dirlen-1);
2092     int ret = mkdir(newdir,mode);
2093     Safefree(newdir);
2094     return ret;
2095   }
2096   else return mkdir(dir,mode);
2097 }  /* end of my_mkdir */
2098 /*}}}*/
2099
2100 /*{{{int my_chdir(char *)*/
2101 int
2102 Perl_my_chdir(pTHX_ const char *dir)
2103 {
2104   STRLEN dirlen = strlen(dir);
2105
2106   /* zero length string sometimes gives ACCVIO */
2107   if (dirlen == 0) return -1;
2108   const char *dir1;
2109
2110   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2111    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2112    * so that existing scripts do not need to be changed.
2113    */
2114   dir1 = dir;
2115   while ((dirlen > 0) && (*dir1 == ' ')) {
2116     dir1++;
2117     dirlen--;
2118   }
2119
2120   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2121    * that implies
2122    * null file name/type.  However, it's commonplace under Unix,
2123    * so we'll allow it for a gain in portability.
2124    *
2125    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2126    */
2127   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2128       char *newdir;
2129       int ret;
2130       newdir = (char *)PerlMem_malloc(dirlen);
2131       if (newdir ==NULL)
2132           _ckvmssts_noperl(SS$_INSFMEM);
2133       memcpy(newdir, dir1, dirlen-1);
2134       newdir[dirlen-1] = '\0';
2135       ret = chdir(newdir);
2136       PerlMem_free(newdir);
2137       return ret;
2138   }
2139   else return chdir(dir1);
2140 }  /* end of my_chdir */
2141 /*}}}*/
2142
2143
2144 /*{{{int my_chmod(char *, mode_t)*/
2145 int
2146 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2147 {
2148   Stat_t st;
2149   int ret = -1;
2150   char * changefile;
2151   STRLEN speclen = strlen(file_spec);
2152
2153   /* zero length string sometimes gives ACCVIO */
2154   if (speclen == 0) return -1;
2155
2156   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2157    * that implies null file name/type.  However, it's commonplace under Unix,
2158    * so we'll allow it for a gain in portability.
2159    *
2160    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2161    * in VMS file.dir notation.
2162    */
2163   changefile = (char *) file_spec; /* cast ok */
2164   ret = flex_lstat(file_spec, &st);
2165   if (ret != 0) {
2166
2167         /* Due to a historical feature, flex_stat/lstat can not see some */
2168         /* Unix format file names that the rest of the CRTL can see when */
2169         /* ODS-2 file specifications are in use. */
2170         /* Fixing that feature will cause some perl tests to fail */
2171         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2172         st.st_mode = 0;
2173
2174   } else {
2175       /* It may be possible to get here with nothing in st_devname */
2176       /* chmod still may work though */
2177       if (st.st_devnam[0] != 0) {
2178           changefile = st.st_devnam;
2179       }
2180   }
2181   ret = chmod(changefile, mode);
2182   return ret;
2183 }  /* end of my_chmod */
2184 /*}}}*/
2185
2186
2187 /*{{{FILE *my_tmpfile()*/
2188 FILE *
2189 my_tmpfile(void)
2190 {
2191   FILE *fp;
2192   char *cp;
2193
2194   if ((fp = tmpfile())) return fp;
2195
2196   cp = (char *)PerlMem_malloc(L_tmpnam+24);
2197   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2198
2199   if (decc_filename_unix_only == 0)
2200     strcpy(cp,"Sys$Scratch:");
2201   else
2202     strcpy(cp,"/tmp/");
2203   tmpnam(cp+strlen(cp));
2204   strcat(cp,".Perltmp");
2205   fp = fopen(cp,"w+","fop=dlt");
2206   PerlMem_free(cp);
2207   return fp;
2208 }
2209 /*}}}*/
2210
2211
2212 /*
2213  * The C RTL's sigaction fails to check for invalid signal numbers so we
2214  * help it out a bit.  The docs are correct, but the actual routine doesn't
2215  * do what the docs say it will.
2216  */
2217 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2218 int
2219 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2220                    struct sigaction* oact)
2221 {
2222   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2223         SETERRNO(EINVAL, SS$_INVARG);
2224         return -1;
2225   }
2226   return sigaction(sig, act, oact);
2227 }
2228 /*}}}*/
2229
2230 #ifdef KILL_BY_SIGPRC
2231 #include <errnodef.h>
2232
2233 /* We implement our own kill() using the undocumented system service
2234    sys$sigprc for one of two reasons:
2235
2236    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2237    target process to do a sys$exit, which usually can't be handled
2238    gracefully...certainly not by Perl and the %SIG{} mechanism.
2239
2240    2.) If the kill() in the CRTL can't be called from a signal
2241    handler without disappearing into the ether, i.e., the signal
2242    it purportedly sends is never trapped. Still true as of VMS 7.3.
2243
2244    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2245    in the target process rather than calling sys$exit.
2246
2247    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2248    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2249    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2250    with condition codes C$_SIG0+nsig*8, catching the exception on the
2251    target process and resignaling with appropriate arguments.
2252
2253    But we don't have that VMS 7.0+ exception handler, so if you
2254    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2255
2256    Also note that SIGTERM is listed in the docs as being "unimplemented",
2257    yet always seems to be signaled with a VMS condition code of 4 (and
2258    correctly handled for that code).  So we hardwire it in.
2259
2260    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2261    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2262    than signalling with an unrecognized (and unhandled by CRTL) code.
2263 */
2264
2265 #define _MY_SIG_MAX 28
2266
2267 static unsigned int
2268 Perl_sig_to_vmscondition_int(int sig)
2269 {
2270     static unsigned int sig_code[_MY_SIG_MAX+1] =
2271     {
2272         0,                  /*  0 ZERO     */
2273         SS$_HANGUP,         /*  1 SIGHUP   */
2274         SS$_CONTROLC,       /*  2 SIGINT   */
2275         SS$_CONTROLY,       /*  3 SIGQUIT  */
2276         SS$_RADRMOD,        /*  4 SIGILL   */
2277         SS$_BREAK,          /*  5 SIGTRAP  */
2278         SS$_OPCCUS,         /*  6 SIGABRT  */
2279         SS$_COMPAT,         /*  7 SIGEMT   */
2280 #ifdef __VAX
2281         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2282 #else
2283         SS$_HPARITH,        /*  8 SIGFPE AXP */
2284 #endif
2285         SS$_ABORT,          /*  9 SIGKILL  */
2286         SS$_ACCVIO,         /* 10 SIGBUS   */
2287         SS$_ACCVIO,         /* 11 SIGSEGV  */
2288         SS$_BADPARAM,       /* 12 SIGSYS   */
2289         SS$_NOMBX,          /* 13 SIGPIPE  */
2290         SS$_ASTFLT,         /* 14 SIGALRM  */
2291         4,                  /* 15 SIGTERM  */
2292         0,                  /* 16 SIGUSR1  */
2293         0,                  /* 17 SIGUSR2  */
2294         0,                  /* 18 */
2295         0,                  /* 19 */
2296         0,                  /* 20 SIGCHLD  */
2297         0,                  /* 21 SIGCONT  */
2298         0,                  /* 22 SIGSTOP  */
2299         0,                  /* 23 SIGTSTP  */
2300         0,                  /* 24 SIGTTIN  */
2301         0,                  /* 25 SIGTTOU  */
2302         0,                  /* 26 */
2303         0,                  /* 27 */
2304         0                   /* 28 SIGWINCH  */
2305     };
2306
2307     static int initted = 0;
2308     if (!initted) {
2309         initted = 1;
2310         sig_code[16] = C$_SIGUSR1;
2311         sig_code[17] = C$_SIGUSR2;
2312         sig_code[20] = C$_SIGCHLD;
2313 #if __CRTL_VER >= 70300000
2314         sig_code[28] = C$_SIGWINCH;
2315 #endif
2316     }
2317
2318     if (sig < _SIG_MIN) return 0;
2319     if (sig > _MY_SIG_MAX) return 0;
2320     return sig_code[sig];
2321 }
2322
2323 unsigned int
2324 Perl_sig_to_vmscondition(int sig)
2325 {
2326 #ifdef SS$_DEBUG
2327     if (vms_debug_on_exception != 0)
2328         lib$signal(SS$_DEBUG);
2329 #endif
2330     return Perl_sig_to_vmscondition_int(sig);
2331 }
2332
2333
2334 #define sys$sigprc SYS$SIGPRC
2335 #ifdef __cplusplus
2336 extern "C" {
2337 #endif
2338 int sys$sigprc(unsigned int *pidadr,
2339                struct dsc$descriptor_s *prcname,
2340                unsigned int code);
2341 #ifdef __cplusplus
2342 }
2343 #endif
2344
2345 int
2346 Perl_my_kill(int pid, int sig)
2347 {
2348     int iss;
2349     unsigned int code;
2350
2351      /* sig 0 means validate the PID */
2352     /*------------------------------*/
2353     if (sig == 0) {
2354         const unsigned long int jpicode = JPI$_PID;
2355         pid_t ret_pid;
2356         int status;
2357         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2358         if ($VMS_STATUS_SUCCESS(status))
2359            return 0;
2360         switch (status) {
2361         case SS$_NOSUCHNODE:
2362         case SS$_UNREACHABLE:
2363         case SS$_NONEXPR:
2364            errno = ESRCH;
2365            break;
2366         case SS$_NOPRIV:
2367            errno = EPERM;
2368            break;
2369         default:
2370            errno = EVMSERR;
2371         }
2372         vaxc$errno=status;
2373         return -1;
2374     }
2375
2376     code = Perl_sig_to_vmscondition_int(sig);
2377
2378     if (!code) {
2379         SETERRNO(EINVAL, SS$_BADPARAM);
2380         return -1;
2381     }
2382
2383     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2384      * signals are to be sent to multiple processes.
2385      *  pid = 0 - all processes in group except ones that the system exempts
2386      *  pid = -1 - all processes except ones that the system exempts
2387      *  pid = -n - all processes in group (abs(n)) except ...
2388      * For now, just report as not supported.
2389      */
2390
2391     if (pid <= 0) {
2392         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2393         return -1;
2394     }
2395
2396     iss = sys$sigprc((unsigned int *)&pid,0,code);
2397     if (iss&1) return 0;
2398
2399     switch (iss) {
2400       case SS$_NOPRIV:
2401         set_errno(EPERM);  break;
2402       case SS$_NONEXPR:
2403       case SS$_NOSUCHNODE:
2404       case SS$_UNREACHABLE:
2405         set_errno(ESRCH);  break;
2406       case SS$_INSFMEM:
2407         set_errno(ENOMEM); break;
2408       default:
2409         _ckvmssts_noperl(iss);
2410         set_errno(EVMSERR);
2411     }
2412     set_vaxc_errno(iss);
2413
2414     return -1;
2415 }
2416 #endif
2417
2418 /* Routine to convert a VMS status code to a UNIX status code.
2419 ** More tricky than it appears because of conflicting conventions with
2420 ** existing code.
2421 **
2422 ** VMS status codes are a bit mask, with the least significant bit set for
2423 ** success.
2424 **
2425 ** Special UNIX status of EVMSERR indicates that no translation is currently
2426 ** available, and programs should check the VMS status code.
2427 **
2428 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2429 ** decoding.
2430 */
2431
2432 #ifndef C_FACILITY_NO
2433 #define C_FACILITY_NO 0x350000
2434 #endif
2435 #ifndef DCL_IVVERB
2436 #define DCL_IVVERB 0x38090
2437 #endif
2438
2439 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2440 {
2441 int facility;
2442 int fac_sp;
2443 int msg_no;
2444 int msg_status;
2445 int unix_status;
2446
2447   /* Assume the best or the worst */
2448   if (vms_status & STS$M_SUCCESS)
2449     unix_status = 0;
2450   else
2451     unix_status = EVMSERR;
2452
2453   msg_status = vms_status & ~STS$M_CONTROL;
2454
2455   facility = vms_status & STS$M_FAC_NO;
2456   fac_sp = vms_status & STS$M_FAC_SP;
2457   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2458
2459   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2460     switch(msg_no) {
2461     case SS$_NORMAL:
2462         unix_status = 0;
2463         break;
2464     case SS$_ACCVIO:
2465         unix_status = EFAULT;
2466         break;
2467     case SS$_DEVOFFLINE:
2468         unix_status = EBUSY;
2469         break;
2470     case SS$_CLEARED:
2471         unix_status = ENOTCONN;
2472         break;
2473     case SS$_IVCHAN:
2474     case SS$_IVLOGNAM:
2475     case SS$_BADPARAM:
2476     case SS$_IVLOGTAB:
2477     case SS$_NOLOGNAM:
2478     case SS$_NOLOGTAB:
2479     case SS$_INVFILFOROP:
2480     case SS$_INVARG:
2481     case SS$_NOSUCHID:
2482     case SS$_IVIDENT:
2483         unix_status = EINVAL;
2484         break;
2485     case SS$_UNSUPPORTED:
2486         unix_status = ENOTSUP;
2487         break;
2488     case SS$_FILACCERR:
2489     case SS$_NOGRPPRV:
2490     case SS$_NOSYSPRV:
2491         unix_status = EACCES;
2492         break;
2493     case SS$_DEVICEFULL:
2494         unix_status = ENOSPC;
2495         break;
2496     case SS$_NOSUCHDEV:
2497         unix_status = ENODEV;
2498         break;
2499     case SS$_NOSUCHFILE:
2500     case SS$_NOSUCHOBJECT:
2501         unix_status = ENOENT;
2502         break;
2503     case SS$_ABORT:                                 /* Fatal case */
2504     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2505     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2506         unix_status = EINTR;
2507         break;
2508     case SS$_BUFFEROVF:
2509         unix_status = E2BIG;
2510         break;
2511     case SS$_INSFMEM:
2512         unix_status = ENOMEM;
2513         break;
2514     case SS$_NOPRIV:
2515         unix_status = EPERM;
2516         break;
2517     case SS$_NOSUCHNODE:
2518     case SS$_UNREACHABLE:
2519         unix_status = ESRCH;
2520         break;
2521     case SS$_NONEXPR:
2522         unix_status = ECHILD;
2523         break;
2524     default:
2525         if ((facility == 0) && (msg_no < 8)) {
2526           /* These are not real VMS status codes so assume that they are
2527           ** already UNIX status codes
2528           */
2529           unix_status = msg_no;
2530           break;
2531         }
2532     }
2533   }
2534   else {
2535     /* Translate a POSIX exit code to a UNIX exit code */
2536     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2537         unix_status = (msg_no & 0x07F8) >> 3;
2538     }
2539     else {
2540
2541          /* Documented traditional behavior for handling VMS child exits */
2542         /*--------------------------------------------------------------*/
2543         if (child_flag != 0) {
2544
2545              /* Success / Informational return 0 */
2546             /*----------------------------------*/
2547             if (msg_no & STS$K_SUCCESS)
2548                 return 0;
2549
2550              /* Warning returns 1 */
2551             /*-------------------*/
2552             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2553                 return 1;
2554
2555              /* Everything else pass through the severity bits */
2556             /*------------------------------------------------*/
2557             return (msg_no & STS$M_SEVERITY);
2558         }
2559
2560          /* Normal VMS status to ERRNO mapping attempt */
2561         /*--------------------------------------------*/
2562         switch(msg_status) {
2563         /* case RMS$_EOF: */ /* End of File */
2564         case RMS$_FNF:  /* File Not Found */
2565         case RMS$_DNF:  /* Dir Not Found */
2566                 unix_status = ENOENT;
2567                 break;
2568         case RMS$_RNF:  /* Record Not Found */
2569                 unix_status = ESRCH;
2570                 break;
2571         case RMS$_DIR:
2572                 unix_status = ENOTDIR;
2573                 break;
2574         case RMS$_DEV:
2575                 unix_status = ENODEV;
2576                 break;
2577         case RMS$_IFI:
2578         case RMS$_FAC:
2579         case RMS$_ISI:
2580                 unix_status = EBADF;
2581                 break;
2582         case RMS$_FEX:
2583                 unix_status = EEXIST;
2584                 break;
2585         case RMS$_SYN:
2586         case RMS$_FNM:
2587         case LIB$_INVSTRDES:
2588         case LIB$_INVARG:
2589         case LIB$_NOSUCHSYM:
2590         case LIB$_INVSYMNAM:
2591         case DCL_IVVERB:
2592                 unix_status = EINVAL;
2593                 break;
2594         case CLI$_BUFOVF:
2595         case RMS$_RTB:
2596         case CLI$_TKNOVF:
2597         case CLI$_RSLOVF:
2598                 unix_status = E2BIG;
2599                 break;
2600         case RMS$_PRV:  /* No privilege */
2601         case RMS$_ACC:  /* ACP file access failed */
2602         case RMS$_WLK:  /* Device write locked */
2603                 unix_status = EACCES;
2604                 break;
2605         case RMS$_MKD:  /* Failed to mark for delete */
2606                 unix_status = EPERM;
2607                 break;
2608         /* case RMS$_NMF: */  /* No more files */
2609         }
2610     }
2611   }
2612
2613   return unix_status;
2614 }
2615
2616 /* Try to guess at what VMS error status should go with a UNIX errno
2617  * value.  This is hard to do as there could be many possible VMS
2618  * error statuses that caused the errno value to be set.
2619  */
2620
2621 int Perl_unix_status_to_vms(int unix_status)
2622 {
2623 int test_unix_status;
2624
2625      /* Trivial cases first */
2626     /*---------------------*/
2627     if (unix_status == EVMSERR)
2628         return vaxc$errno;
2629
2630      /* Is vaxc$errno sane? */
2631     /*---------------------*/
2632     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2633     if (test_unix_status == unix_status)
2634         return vaxc$errno;
2635
2636      /* If way out of range, must be VMS code already */
2637     /*-----------------------------------------------*/
2638     if (unix_status > EVMSERR)
2639         return unix_status;
2640
2641      /* If out of range, punt */
2642     /*-----------------------*/
2643     if (unix_status > __ERRNO_MAX)
2644         return SS$_ABORT;
2645
2646
2647      /* Ok, now we have to do it the hard way. */
2648     /*----------------------------------------*/
2649     switch(unix_status) {
2650     case 0:     return SS$_NORMAL;
2651     case EPERM: return SS$_NOPRIV;
2652     case ENOENT: return SS$_NOSUCHOBJECT;
2653     case ESRCH: return SS$_UNREACHABLE;
2654     case EINTR: return SS$_ABORT;
2655     /* case EIO: */
2656     /* case ENXIO:  */
2657     case E2BIG: return SS$_BUFFEROVF;
2658     /* case ENOEXEC */
2659     case EBADF: return RMS$_IFI;
2660     case ECHILD: return SS$_NONEXPR;
2661     /* case EAGAIN */
2662     case ENOMEM: return SS$_INSFMEM;
2663     case EACCES: return SS$_FILACCERR;
2664     case EFAULT: return SS$_ACCVIO;
2665     /* case ENOTBLK */
2666     case EBUSY: return SS$_DEVOFFLINE;
2667     case EEXIST: return RMS$_FEX;
2668     /* case EXDEV */
2669     case ENODEV: return SS$_NOSUCHDEV;
2670     case ENOTDIR: return RMS$_DIR;
2671     /* case EISDIR */
2672     case EINVAL: return SS$_INVARG;
2673     /* case ENFILE */
2674     /* case EMFILE */
2675     /* case ENOTTY */
2676     /* case ETXTBSY */
2677     /* case EFBIG */
2678     case ENOSPC: return SS$_DEVICEFULL;
2679     case ESPIPE: return LIB$_INVARG;
2680     /* case EROFS: */
2681     /* case EMLINK: */
2682     /* case EPIPE: */
2683     /* case EDOM */
2684     case ERANGE: return LIB$_INVARG;
2685     /* case EWOULDBLOCK */
2686     /* case EINPROGRESS */
2687     /* case EALREADY */
2688     /* case ENOTSOCK */
2689     /* case EDESTADDRREQ */
2690     /* case EMSGSIZE */
2691     /* case EPROTOTYPE */
2692     /* case ENOPROTOOPT */
2693     /* case EPROTONOSUPPORT */
2694     /* case ESOCKTNOSUPPORT */
2695     /* case EOPNOTSUPP */
2696     /* case EPFNOSUPPORT */
2697     /* case EAFNOSUPPORT */
2698     /* case EADDRINUSE */
2699     /* case EADDRNOTAVAIL */
2700     /* case ENETDOWN */
2701     /* case ENETUNREACH */
2702     /* case ENETRESET */
2703     /* case ECONNABORTED */
2704     /* case ECONNRESET */
2705     /* case ENOBUFS */
2706     /* case EISCONN */
2707     case ENOTCONN: return SS$_CLEARED;
2708     /* case ESHUTDOWN */
2709     /* case ETOOMANYREFS */
2710     /* case ETIMEDOUT */
2711     /* case ECONNREFUSED */
2712     /* case ELOOP */
2713     /* case ENAMETOOLONG */
2714     /* case EHOSTDOWN */
2715     /* case EHOSTUNREACH */
2716     /* case ENOTEMPTY */
2717     /* case EPROCLIM */
2718     /* case EUSERS  */
2719     /* case EDQUOT  */
2720     /* case ENOMSG  */
2721     /* case EIDRM */
2722     /* case EALIGN */
2723     /* case ESTALE */
2724     /* case EREMOTE */
2725     /* case ENOLCK */
2726     /* case ENOSYS */
2727     /* case EFTYPE */
2728     /* case ECANCELED */
2729     /* case EFAIL */
2730     /* case EINPROG */
2731     case ENOTSUP:
2732         return SS$_UNSUPPORTED;
2733     /* case EDEADLK */
2734     /* case ENWAIT */
2735     /* case EILSEQ */
2736     /* case EBADCAT */
2737     /* case EBADMSG */
2738     /* case EABANDONED */
2739     default:
2740         return SS$_ABORT; /* punt */
2741     }
2742 }
2743
2744
2745 /* default piping mailbox size */
2746 #ifdef __VAX
2747 #  define PERL_BUFSIZ        512
2748 #else
2749 #  define PERL_BUFSIZ        8192
2750 #endif
2751
2752
2753 static void
2754 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2755 {
2756   unsigned long int mbxbufsiz;
2757   static unsigned long int syssize = 0;
2758   unsigned long int dviitm = DVI$_DEVNAM;
2759   char csize[LNM$C_NAMLENGTH+1];
2760   int sts;
2761
2762   if (!syssize) {
2763     unsigned long syiitm = SYI$_MAXBUF;
2764     /*
2765      * Get the SYSGEN parameter MAXBUF
2766      *
2767      * If the logical 'PERL_MBX_SIZE' is defined
2768      * use the value of the logical instead of PERL_BUFSIZ, but
2769      * keep the size between 128 and MAXBUF.
2770      *
2771      */
2772     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2773   }
2774
2775   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2776       mbxbufsiz = atoi(csize);
2777   } else {
2778       mbxbufsiz = PERL_BUFSIZ;
2779   }
2780   if (mbxbufsiz < 128) mbxbufsiz = 128;
2781   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2782
2783   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2784
2785   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2786   _ckvmssts_noperl(sts);
2787   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2788
2789 }  /* end of create_mbx() */
2790
2791
2792 /*{{{  my_popen and my_pclose*/
2793
2794 typedef struct _iosb           IOSB;
2795 typedef struct _iosb*         pIOSB;
2796 typedef struct _pipe           Pipe;
2797 typedef struct _pipe*         pPipe;
2798 typedef struct pipe_details    Info;
2799 typedef struct pipe_details*  pInfo;
2800 typedef struct _srqp            RQE;
2801 typedef struct _srqp*          pRQE;
2802 typedef struct _tochildbuf      CBuf;
2803 typedef struct _tochildbuf*    pCBuf;
2804
2805 struct _iosb {
2806     unsigned short status;
2807     unsigned short count;
2808     unsigned long  dvispec;
2809 };
2810
2811 #pragma member_alignment save
2812 #pragma nomember_alignment quadword
2813 struct _srqp {          /* VMS self-relative queue entry */
2814     unsigned long qptr[2];
2815 };
2816 #pragma member_alignment restore
2817 static RQE  RQE_ZERO = {0,0};
2818
2819 struct _tochildbuf {
2820     RQE             q;
2821     int             eof;
2822     unsigned short  size;
2823     char            *buf;
2824 };
2825
2826 struct _pipe {
2827     RQE            free;
2828     RQE            wait;
2829     int            fd_out;
2830     unsigned short chan_in;
2831     unsigned short chan_out;
2832     char          *buf;
2833     unsigned int   bufsize;
2834     IOSB           iosb;
2835     IOSB           iosb2;
2836     int           *pipe_done;
2837     int            retry;
2838     int            type;
2839     int            shut_on_empty;
2840     int            need_wake;
2841     pPipe         *home;
2842     pInfo          info;
2843     pCBuf          curr;
2844     pCBuf          curr2;
2845 #if defined(PERL_IMPLICIT_CONTEXT)
2846     void            *thx;           /* Either a thread or an interpreter */
2847                                     /* pointer, depending on how we're built */
2848 #endif
2849 };
2850
2851
2852 struct pipe_details
2853 {
2854     pInfo           next;
2855     PerlIO *fp;  /* file pointer to pipe mailbox */
2856     int useFILE; /* using stdio, not perlio */
2857     int pid;   /* PID of subprocess */
2858     int mode;  /* == 'r' if pipe open for reading */
2859     int done;  /* subprocess has completed */
2860     int waiting; /* waiting for completion/closure */
2861     int             closing;        /* my_pclose is closing this pipe */
2862     unsigned long   completion;     /* termination status of subprocess */
2863     pPipe           in;             /* pipe in to sub */
2864     pPipe           out;            /* pipe out of sub */
2865     pPipe           err;            /* pipe of sub's sys$error */
2866     int             in_done;        /* true when in pipe finished */
2867     int             out_done;
2868     int             err_done;
2869     unsigned short  xchan;          /* channel to debug xterm */
2870     unsigned short  xchan_valid;    /* channel is assigned */
2871 };
2872
2873 struct exit_control_block
2874 {
2875     struct exit_control_block *flink;
2876     unsigned long int (*exit_routine)(void);
2877     unsigned long int arg_count;
2878     unsigned long int *status_address;
2879     unsigned long int exit_status;
2880 };
2881
2882 typedef struct _closed_pipes    Xpipe;
2883 typedef struct _closed_pipes*  pXpipe;
2884
2885 struct _closed_pipes {
2886     int             pid;            /* PID of subprocess */
2887     unsigned long   completion;     /* termination status of subprocess */
2888 };
2889 #define NKEEPCLOSED 50
2890 static Xpipe closed_list[NKEEPCLOSED];
2891 static int   closed_index = 0;
2892 static int   closed_num = 0;
2893
2894 #define RETRY_DELAY     "0 ::0.20"
2895 #define MAX_RETRY              50
2896
2897 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2898 static unsigned long mypid;
2899 static unsigned long delaytime[2];
2900
2901 static pInfo open_pipes = NULL;
2902 static $DESCRIPTOR(nl_desc, "NL:");
2903
2904 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2905
2906
2907
2908 static unsigned long int
2909 pipe_exit_routine(void)
2910 {
2911     pInfo info;
2912     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2913     int sts, did_stuff, j;
2914
2915    /*
2916     * Flush any pending i/o, but since we are in process run-down, be
2917     * careful about referencing PerlIO structures that may already have
2918     * been deallocated.  We may not even have an interpreter anymore.
2919     */
2920     info = open_pipes;
2921     while (info) {
2922         if (info->fp) {
2923 #if defined(PERL_IMPLICIT_CONTEXT)
2924            /* We need to use the Perl context of the thread that created */
2925            /* the pipe. */
2926            pTHX;
2927            if (info->err)
2928                aTHX = info->err->thx;
2929            else if (info->out)
2930                aTHX = info->out->thx;
2931            else if (info->in)
2932                aTHX = info->in->thx;
2933 #endif
2934            if (!info->useFILE
2935 #if defined(USE_ITHREADS)
2936              && my_perl
2937 #endif
2938 #ifdef USE_PERLIO
2939              && PL_perlio_fd_refcnt
2940 #endif
2941               )
2942                PerlIO_flush(info->fp);
2943            else
2944                fflush((FILE *)info->fp);
2945         }
2946         info = info->next;
2947     }
2948
2949     /*
2950      next we try sending an EOF...ignore if doesn't work, make sure we
2951      don't hang
2952     */
2953     did_stuff = 0;
2954     info = open_pipes;
2955
2956     while (info) {
2957       _ckvmssts_noperl(sys$setast(0));
2958       if (info->in && !info->in->shut_on_empty) {
2959         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2960                                  0, 0, 0, 0, 0, 0));
2961         info->waiting = 1;
2962         did_stuff = 1;
2963       }
2964       _ckvmssts_noperl(sys$setast(1));
2965       info = info->next;
2966     }
2967
2968     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2969
2970     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2971         int nwait = 0;
2972
2973         info = open_pipes;
2974         while (info) {
2975           _ckvmssts_noperl(sys$setast(0));
2976           if (info->waiting && info->done)
2977                 info->waiting = 0;
2978           nwait += info->waiting;
2979           _ckvmssts_noperl(sys$setast(1));
2980           info = info->next;
2981         }
2982         if (!nwait) break;
2983         sleep(1);
2984     }
2985
2986     did_stuff = 0;
2987     info = open_pipes;
2988     while (info) {
2989       _ckvmssts_noperl(sys$setast(0));
2990       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2991         sts = sys$forcex(&info->pid,0,&abort);
2992         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2993         did_stuff = 1;
2994       }
2995       _ckvmssts_noperl(sys$setast(1));
2996       info = info->next;
2997     }
2998
2999     /* again, wait for effect */
3000
3001     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3002         int nwait = 0;
3003
3004         info = open_pipes;
3005         while (info) {
3006           _ckvmssts_noperl(sys$setast(0));
3007           if (info->waiting && info->done)
3008                 info->waiting = 0;
3009           nwait += info->waiting;
3010           _ckvmssts_noperl(sys$setast(1));
3011           info = info->next;
3012         }
3013         if (!nwait) break;
3014         sleep(1);
3015     }
3016
3017     info = open_pipes;
3018     while (info) {
3019       _ckvmssts_noperl(sys$setast(0));
3020       if (!info->done) {  /* We tried to be nice . . . */
3021         sts = sys$delprc(&info->pid,0);
3022         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3023         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3024       }
3025       _ckvmssts_noperl(sys$setast(1));
3026       info = info->next;
3027     }
3028
3029     while(open_pipes) {
3030
3031 #if defined(PERL_IMPLICIT_CONTEXT)
3032       /* We need to use the Perl context of the thread that created */
3033       /* the pipe. */
3034       pTHX;
3035       if (open_pipes->err)
3036           aTHX = open_pipes->err->thx;
3037       else if (open_pipes->out)
3038           aTHX = open_pipes->out->thx;
3039       else if (open_pipes->in)
3040           aTHX = open_pipes->in->thx;
3041 #endif
3042       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3043       else if (!(sts & 1)) retsts = sts;
3044     }
3045     return retsts;
3046 }
3047
3048 static struct exit_control_block pipe_exitblock =
3049        {(struct exit_control_block *) 0,
3050         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3051
3052 static void pipe_mbxtofd_ast(pPipe p);
3053 static void pipe_tochild1_ast(pPipe p);
3054 static void pipe_tochild2_ast(pPipe p);
3055
3056 static void
3057 popen_completion_ast(pInfo info)
3058 {
3059   pInfo i = open_pipes;
3060   int iss;
3061
3062   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3063   closed_list[closed_index].pid = info->pid;
3064   closed_list[closed_index].completion = info->completion;
3065   closed_index++;
3066   if (closed_index == NKEEPCLOSED)
3067     closed_index = 0;
3068   closed_num++;
3069
3070   while (i) {
3071     if (i == info) break;
3072     i = i->next;
3073   }
3074   if (!i) return;       /* unlinked, probably freed too */
3075
3076   info->done = TRUE;
3077
3078 /*
3079     Writing to subprocess ...
3080             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3081
3082             chan_out may be waiting for "done" flag, or hung waiting
3083             for i/o completion to child...cancel the i/o.  This will
3084             put it into "snarf mode" (done but no EOF yet) that discards
3085             input.
3086
3087     Output from subprocess (stdout, stderr) needs to be flushed and
3088     shut down.   We try sending an EOF, but if the mbx is full the pipe
3089     routine should still catch the "shut_on_empty" flag, telling it to
3090     use immediate-style reads so that "mbx empty" -> EOF.
3091
3092
3093 */
3094   if (info->in && !info->in_done) {               /* only for mode=w */
3095         if (info->in->shut_on_empty && info->in->need_wake) {
3096             info->in->need_wake = FALSE;
3097             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3098         } else {
3099             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3100         }
3101   }
3102
3103   if (info->out && !info->out_done) {             /* were we also piping output? */
3104       info->out->shut_on_empty = TRUE;
3105       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3106       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3107       _ckvmssts_noperl(iss);
3108   }
3109
3110   if (info->err && !info->err_done) {        /* we were piping stderr */
3111         info->err->shut_on_empty = TRUE;
3112         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3113         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3114         _ckvmssts_noperl(iss);
3115   }
3116   _ckvmssts_noperl(sys$setef(pipe_ef));
3117
3118 }
3119
3120 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3121 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3122 static void pipe_infromchild_ast(pPipe p);
3123
3124 /*
3125     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3126     inside an AST routine without worrying about reentrancy and which Perl
3127     memory allocator is being used.
3128
3129     We read data and queue up the buffers, then spit them out one at a
3130     time to the output mailbox when the output mailbox is ready for one.
3131
3132 */
3133 #define INITIAL_TOCHILDQUEUE  2
3134
3135 static pPipe
3136 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3137 {
3138     pPipe p;
3139     pCBuf b;
3140     char mbx1[64], mbx2[64];
3141     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3142                                       DSC$K_CLASS_S, mbx1},
3143                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3144                                       DSC$K_CLASS_S, mbx2};
3145     unsigned int dviitm = DVI$_DEVBUFSIZ;
3146     int j, n;
3147
3148     n = sizeof(Pipe);
3149     _ckvmssts_noperl(lib$get_vm(&n, &p));
3150
3151     create_mbx(&p->chan_in , &d_mbx1);
3152     create_mbx(&p->chan_out, &d_mbx2);
3153     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3154
3155     p->buf           = 0;
3156     p->shut_on_empty = FALSE;
3157     p->need_wake     = FALSE;
3158     p->type          = 0;
3159     p->retry         = 0;
3160     p->iosb.status   = SS$_NORMAL;
3161     p->iosb2.status  = SS$_NORMAL;
3162     p->free          = RQE_ZERO;
3163     p->wait          = RQE_ZERO;
3164     p->curr          = 0;
3165     p->curr2         = 0;
3166     p->info          = 0;
3167 #ifdef PERL_IMPLICIT_CONTEXT
3168     p->thx           = aTHX;
3169 #endif
3170
3171     n = sizeof(CBuf) + p->bufsize;
3172
3173     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3174         _ckvmssts_noperl(lib$get_vm(&n, &b));
3175         b->buf = (char *) b + sizeof(CBuf);
3176         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3177     }
3178
3179     pipe_tochild2_ast(p);
3180     pipe_tochild1_ast(p);
3181     strcpy(wmbx, mbx1);
3182     strcpy(rmbx, mbx2);
3183     return p;
3184 }
3185
3186 /*  reads the MBX Perl is writing, and queues */
3187
3188 static void
3189 pipe_tochild1_ast(pPipe p)
3190 {
3191     pCBuf b = p->curr;
3192     int iss = p->iosb.status;
3193     int eof = (iss == SS$_ENDOFFILE);
3194     int sts;
3195 #ifdef PERL_IMPLICIT_CONTEXT
3196     pTHX = p->thx;
3197 #endif
3198
3199     if (p->retry) {
3200         if (eof) {
3201             p->shut_on_empty = TRUE;
3202             b->eof     = TRUE;
3203             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3204         } else  {
3205             _ckvmssts_noperl(iss);
3206         }
3207
3208         b->eof  = eof;
3209         b->size = p->iosb.count;
3210         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3211         if (p->need_wake) {
3212             p->need_wake = FALSE;
3213             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3214         }
3215     } else {
3216         p->retry = 1;   /* initial call */
3217     }
3218
3219     if (eof) {                  /* flush the free queue, return when done */
3220         int n = sizeof(CBuf) + p->bufsize;
3221         while (1) {
3222             iss = lib$remqti(&p->free, &b);
3223             if (iss == LIB$_QUEWASEMP) return;
3224             _ckvmssts_noperl(iss);
3225             _ckvmssts_noperl(lib$free_vm(&n, &b));
3226         }
3227     }
3228
3229     iss = lib$remqti(&p->free, &b);
3230     if (iss == LIB$_QUEWASEMP) {
3231         int n = sizeof(CBuf) + p->bufsize;
3232         _ckvmssts_noperl(lib$get_vm(&n, &b));
3233         b->buf = (char *) b + sizeof(CBuf);
3234     } else {
3235        _ckvmssts_noperl(iss);
3236     }
3237
3238     p->curr = b;
3239     iss = sys$qio(0,p->chan_in,
3240              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3241              &p->iosb,
3242              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3243     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3244     _ckvmssts_noperl(iss);
3245 }
3246
3247
3248 /* writes queued buffers to output, waits for each to complete before
3249    doing the next */
3250
3251 static void
3252 pipe_tochild2_ast(pPipe p)
3253 {
3254     pCBuf b = p->curr2;
3255     int iss = p->iosb2.status;
3256     int n = sizeof(CBuf) + p->bufsize;
3257     int done = (p->info && p->info->done) ||
3258               iss == SS$_CANCEL || iss == SS$_ABORT;
3259 #if defined(PERL_IMPLICIT_CONTEXT)
3260     pTHX = p->thx;
3261 #endif
3262
3263     do {
3264         if (p->type) {         /* type=1 has old buffer, dispose */
3265             if (p->shut_on_empty) {
3266                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3267             } else {
3268                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3269             }
3270             p->type = 0;
3271         }
3272
3273         iss = lib$remqti(&p->wait, &b);
3274         if (iss == LIB$_QUEWASEMP) {
3275             if (p->shut_on_empty) {
3276                 if (done) {
3277                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3278                     *p->pipe_done = TRUE;
3279                     _ckvmssts_noperl(sys$setef(pipe_ef));
3280                 } else {
3281                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3282                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3283                 }
3284                 return;
3285             }
3286             p->need_wake = TRUE;
3287             return;
3288         }
3289         _ckvmssts_noperl(iss);
3290         p->type = 1;
3291     } while (done);
3292
3293
3294     p->curr2 = b;
3295     if (b->eof) {
3296         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3297             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3298     } else {
3299         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3300             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3301     }
3302
3303     return;
3304
3305 }
3306
3307
3308 static pPipe
3309 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3310 {
3311     pPipe p;
3312     char mbx1[64], mbx2[64];
3313     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3314                                       DSC$K_CLASS_S, mbx1},
3315                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3316                                       DSC$K_CLASS_S, mbx2};
3317     unsigned int dviitm = DVI$_DEVBUFSIZ;
3318
3319     int n = sizeof(Pipe);
3320     _ckvmssts_noperl(lib$get_vm(&n, &p));
3321     create_mbx(&p->chan_in , &d_mbx1);
3322     create_mbx(&p->chan_out, &d_mbx2);
3323
3324     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3325     n = p->bufsize * sizeof(char);
3326     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3327     p->shut_on_empty = FALSE;
3328     p->info   = 0;
3329     p->type   = 0;
3330     p->iosb.status = SS$_NORMAL;
3331 #if defined(PERL_IMPLICIT_CONTEXT)
3332     p->thx = aTHX;
3333 #endif
3334     pipe_infromchild_ast(p);
3335
3336     strcpy(wmbx, mbx1);
3337     strcpy(rmbx, mbx2);
3338     return p;
3339 }
3340
3341 static void
3342 pipe_infromchild_ast(pPipe p)
3343 {
3344     int iss = p->iosb.status;
3345     int eof = (iss == SS$_ENDOFFILE);
3346     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3347     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3348 #if defined(PERL_IMPLICIT_CONTEXT)
3349     pTHX = p->thx;
3350 #endif
3351
3352     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3353         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3354         p->chan_out = 0;
3355     }
3356
3357     /* read completed:
3358             input shutdown if EOF from self (done or shut_on_empty)
3359             output shutdown if closing flag set (my_pclose)
3360             send data/eof from child or eof from self
3361             otherwise, re-read (snarf of data from child)
3362     */
3363
3364     if (p->type == 1) {
3365         p->type = 0;
3366         if (myeof && p->chan_in) {                  /* input shutdown */
3367             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3368             p->chan_in = 0;
3369         }
3370
3371         if (p->chan_out) {
3372             if (myeof || kideof) {      /* pass EOF to parent */
3373                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3374                                          pipe_infromchild_ast, p,
3375                                          0, 0, 0, 0, 0, 0));
3376                 return;
3377             } else if (eof) {       /* eat EOF --- fall through to read*/
3378
3379             } else {                /* transmit data */
3380                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3381                                          pipe_infromchild_ast,p,
3382                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3383                 return;
3384             }
3385         }
3386     }
3387
3388     /*  everything shut? flag as done */
3389
3390     if (!p->chan_in && !p->chan_out) {
3391         *p->pipe_done = TRUE;
3392         _ckvmssts_noperl(sys$setef(pipe_ef));
3393         return;
3394     }
3395
3396     /* write completed (or read, if snarfing from child)
3397             if still have input active,
3398                queue read...immediate mode if shut_on_empty so we get EOF if empty
3399             otherwise,
3400                check if Perl reading, generate EOFs as needed
3401     */
3402
3403     if (p->type == 0) {
3404         p->type = 1;
3405         if (p->chan_in) {
3406             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3407                           pipe_infromchild_ast,p,
3408                           p->buf, p->bufsize, 0, 0, 0, 0);
3409             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3410             _ckvmssts_noperl(iss);
3411         } else {           /* send EOFs for extra reads */
3412             p->iosb.status = SS$_ENDOFFILE;
3413             p->iosb.dvispec = 0;
3414             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3415                                      0, 0, 0,
3416                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3417         }
3418     }
3419 }
3420
3421 static pPipe
3422 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3423 {
3424     pPipe p;
3425     char mbx[64];
3426     unsigned long dviitm = DVI$_DEVBUFSIZ;
3427     struct stat s;
3428     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3429                                       DSC$K_CLASS_S, mbx};
3430     int n = sizeof(Pipe);
3431
3432     /* things like terminals and mbx's don't need this filter */
3433     if (fd && fstat(fd,&s) == 0) {
3434         unsigned long devchar;
3435         char device[65];
3436         unsigned short dev_len;
3437         struct dsc$descriptor_s d_dev;
3438         char * cptr;
3439         struct item_list_3 items[3];
3440         int status;
3441         unsigned short dvi_iosb[4];
3442
3443         cptr = getname(fd, out, 1);
3444         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3445         d_dev.dsc$a_pointer = out;
3446         d_dev.dsc$w_length = strlen(out);
3447         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3448         d_dev.dsc$b_class = DSC$K_CLASS_S;
3449
3450         items[0].len = 4;
3451         items[0].code = DVI$_DEVCHAR;
3452         items[0].bufadr = &devchar;
3453         items[0].retadr = NULL;
3454         items[1].len = 64;
3455         items[1].code = DVI$_FULLDEVNAM;
3456         items[1].bufadr = device;
3457         items[1].retadr = &dev_len;
3458         items[2].len = 0;
3459         items[2].code = 0;
3460
3461         status = sys$getdviw
3462                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3463         _ckvmssts_noperl(status);
3464         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3465             device[dev_len] = 0;
3466
3467             if (!(devchar & DEV$M_DIR)) {
3468                 strcpy(out, device);
3469                 return 0;
3470             }
3471         }
3472     }
3473
3474     _ckvmssts_noperl(lib$get_vm(&n, &p));
3475     p->fd_out = dup(fd);
3476     create_mbx(&p->chan_in, &d_mbx);
3477     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3478     n = (p->bufsize+1) * sizeof(char);
3479     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3480     p->shut_on_empty = FALSE;
3481     p->retry = 0;
3482     p->info  = 0;
3483     strcpy(out, mbx);
3484
3485     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3486                              pipe_mbxtofd_ast, p,
3487                              p->buf, p->bufsize, 0, 0, 0, 0));
3488
3489     return p;
3490 }
3491
3492 static void
3493 pipe_mbxtofd_ast(pPipe p)
3494 {
3495     int iss = p->iosb.status;
3496     int done = p->info->done;
3497     int iss2;
3498     int eof = (iss == SS$_ENDOFFILE);
3499     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3500     int err = !(iss&1) && !eof;
3501 #if defined(PERL_IMPLICIT_CONTEXT)
3502     pTHX = p->thx;
3503 #endif
3504
3505     if (done && myeof) {               /* end piping */
3506         close(p->fd_out);
3507         sys$dassgn(p->chan_in);
3508         *p->pipe_done = TRUE;
3509         _ckvmssts_noperl(sys$setef(pipe_ef));
3510         return;
3511     }
3512
3513     if (!err && !eof) {             /* good data to send to file */
3514         p->buf[p->iosb.count] = '\n';
3515         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3516         if (iss2 < 0) {
3517             p->retry++;
3518             if (p->retry < MAX_RETRY) {
3519                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3520                 return;
3521             }
3522         }
3523         p->retry = 0;
3524     } else if (err) {
3525         _ckvmssts_noperl(iss);
3526     }
3527
3528
3529     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3530           pipe_mbxtofd_ast, p,
3531           p->buf, p->bufsize, 0, 0, 0, 0);
3532     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3533     _ckvmssts_noperl(iss);
3534 }
3535
3536
3537 typedef struct _pipeloc     PLOC;
3538 typedef struct _pipeloc*   pPLOC;
3539
3540 struct _pipeloc {
3541     pPLOC   next;
3542     char    dir[NAM$C_MAXRSS+1];
3543 };
3544 static pPLOC  head_PLOC = 0;
3545
3546 void
3547 free_pipelocs(pTHX_ void *head)
3548 {
3549     pPLOC p, pnext;
3550     pPLOC *pHead = (pPLOC *)head;
3551
3552     p = *pHead;
3553     while (p) {
3554         pnext = p->next;
3555         PerlMem_free(p);
3556         p = pnext;
3557     }
3558     *pHead = 0;
3559 }
3560
3561 static void
3562 store_pipelocs(pTHX)
3563 {
3564     int    i;
3565     pPLOC  p;
3566     AV    *av = 0;
3567     SV    *dirsv;
3568     char  *dir, *x;
3569     char  *unixdir;
3570     char  temp[NAM$C_MAXRSS+1];
3571     STRLEN n_a;
3572
3573     if (head_PLOC)
3574         free_pipelocs(aTHX_ &head_PLOC);
3575
3576 /*  the . directory from @INC comes last */
3577
3578     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3579     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3580     p->next = head_PLOC;
3581     head_PLOC = p;
3582     strcpy(p->dir,"./");
3583
3584 /*  get the directory from $^X */
3585
3586     unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3587     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3588
3589 #ifdef PERL_IMPLICIT_CONTEXT
3590     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3591 #else
3592     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3593 #endif
3594         my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3595         x = strrchr(temp,']');
3596         if (x == NULL) {
3597         x = strrchr(temp,'>');
3598           if (x == NULL) {
3599             /* It could be a UNIX path */
3600             x = strrchr(temp,'/');
3601           }
3602         }
3603         if (x)
3604           x[1] = '\0';
3605         else {
3606           /* Got a bare name, so use default directory */
3607           temp[0] = '.';
3608           temp[1] = '\0';
3609         }
3610
3611         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3612             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3613             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3614             p->next = head_PLOC;
3615             head_PLOC = p;
3616             my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3617         }
3618     }
3619
3620 /*  reverse order of @INC entries, skip "." since entered above */
3621
3622 #ifdef PERL_IMPLICIT_CONTEXT
3623     if (aTHX)
3624 #endif
3625     if (PL_incgv) av = GvAVn(PL_incgv);
3626
3627     for (i = 0; av && i <= AvFILL(av); i++) {
3628         dirsv = *av_fetch(av,i,TRUE);
3629
3630         if (SvROK(dirsv)) continue;
3631         dir = SvPVx(dirsv,n_a);
3632         if (strcmp(dir,".") == 0) continue;
3633         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3634             continue;
3635
3636         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3637         p->next = head_PLOC;
3638         head_PLOC = p;
3639         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3640     }
3641
3642 /* most likely spot (ARCHLIB) put first in the list */
3643
3644 #ifdef ARCHLIB_EXP
3645     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3646         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3647         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3648         p->next = head_PLOC;
3649         head_PLOC = p;
3650         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3651     }
3652 #endif
3653     PerlMem_free(unixdir);
3654 }
3655
3656 static I32
3657 Perl_cando_by_name_int
3658    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3659 #if !defined(PERL_IMPLICIT_CONTEXT)
3660 #define cando_by_name_int               Perl_cando_by_name_int
3661 #else
3662 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3663 #endif
3664
3665 static char *
3666 find_vmspipe(pTHX)
3667 {
3668     static int   vmspipe_file_status = 0;
3669     static char  vmspipe_file[NAM$C_MAXRSS+1];
3670
3671     /* already found? Check and use ... need read+execute permission */
3672
3673     if (vmspipe_file_status == 1) {
3674         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3675          && cando_by_name_int
3676            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3677             return vmspipe_file;
3678         }
3679         vmspipe_file_status = 0;
3680     }
3681
3682     /* scan through stored @INC, $^X */
3683
3684     if (vmspipe_file_status == 0) {
3685         char file[NAM$C_MAXRSS+1];
3686         pPLOC  p = head_PLOC;
3687
3688         while (p) {
3689             char * exp_res;
3690             int dirlen;
3691             dirlen = my_strlcpy(file, p->dir, sizeof(file));
3692             my_strlcat(file, "vmspipe.com", sizeof(file));
3693             p = p->next;
3694
3695             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3696             if (!exp_res) continue;
3697
3698             if (cando_by_name_int
3699                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3700              && cando_by_name_int
3701                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3702                 vmspipe_file_status = 1;
3703                 return vmspipe_file;
3704             }
3705         }
3706         vmspipe_file_status = -1;   /* failed, use tempfiles */
3707     }
3708
3709     return 0;
3710 }
3711
3712 static FILE *
3713 vmspipe_tempfile(pTHX)
3714 {
3715     char file[NAM$C_MAXRSS+1];
3716     FILE *fp;
3717     static int index = 0;
3718     Stat_t s0, s1;
3719     int cmp_result;
3720
3721     /* create a tempfile */
3722
3723     /* we can't go from   W, shr=get to  R, shr=get without
3724        an intermediate vulnerable state, so don't bother trying...
3725
3726        and lib$spawn doesn't shr=put, so have to close the write
3727
3728        So... match up the creation date/time and the FID to
3729        make sure we're dealing with the same file
3730
3731     */
3732
3733     index++;
3734     if (!decc_filename_unix_only) {
3735       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3736       fp = fopen(file,"w");
3737       if (!fp) {
3738         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3739         fp = fopen(file,"w");
3740         if (!fp) {
3741             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3742             fp = fopen(file,"w");
3743         }
3744       }
3745      }
3746      else {
3747       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3748       fp = fopen(file,"w");
3749       if (!fp) {
3750         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3751         fp = fopen(file,"w");
3752         if (!fp) {
3753           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3754           fp = fopen(file,"w");
3755         }
3756       }
3757     }
3758     if (!fp) return 0;  /* we're hosed */
3759
3760     fprintf(fp,"$! 'f$verify(0)'\n");
3761     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3762     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3763     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3764     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3765     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3766     fprintf(fp,"$ perl_del    = \"delete\"\n");
3767     fprintf(fp,"$ pif         = \"if\"\n");
3768     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3769     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3770     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3771     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3772     fprintf(fp,"$!  --- build command line to get max possible length\n");
3773     fprintf(fp,"$c=perl_popen_cmd0\n");
3774     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3775     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3776     fprintf(fp,"$x=perl_popen_cmd3\n");
3777     fprintf(fp,"$c=c+x\n");
3778     fprintf(fp,"$ perl_on\n");
3779     fprintf(fp,"$ 'c'\n");
3780     fprintf(fp,"$ perl_status = $STATUS\n");
3781     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3782     fprintf(fp,"$ perl_exit 'perl_status'\n");
3783     fsync(fileno(fp));
3784
3785     fgetname(fp, file, 1);
3786     fstat(fileno(fp), &s0.crtl_stat);
3787     fclose(fp);
3788
3789     if (decc_filename_unix_only)
3790         int_tounixspec(file, file, NULL);
3791     fp = fopen(file,"r","shr=get");
3792     if (!fp) return 0;
3793     fstat(fileno(fp), &s1.crtl_stat);
3794
3795     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3796     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3797         fclose(fp);
3798         return 0;
3799     }
3800
3801     return fp;
3802 }
3803
3804
3805 static int vms_is_syscommand_xterm(void)
3806 {
3807     const static struct dsc$descriptor_s syscommand_dsc =
3808       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3809
3810     const static struct dsc$descriptor_s decwdisplay_dsc =
3811       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3812
3813     struct item_list_3 items[2];
3814     unsigned short dvi_iosb[4];
3815     unsigned long devchar;
3816     unsigned long devclass;
3817     int status;
3818
3819     /* Very simple check to guess if sys$command is a decterm? */
3820     /* First see if the DECW$DISPLAY: device exists */
3821     items[0].len = 4;
3822     items[0].code = DVI$_DEVCHAR;
3823     items[0].bufadr = &devchar;
3824     items[0].retadr = NULL;
3825     items[1].len = 0;
3826     items[1].code = 0;
3827
3828     status = sys$getdviw
3829         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3830
3831     if ($VMS_STATUS_SUCCESS(status)) {
3832         status = dvi_iosb[0];
3833     }
3834
3835     if (!$VMS_STATUS_SUCCESS(status)) {
3836         SETERRNO(EVMSERR, status);
3837         return -1;
3838     }
3839
3840     /* If it does, then for now assume that we are on a workstation */
3841     /* Now verify that SYS$COMMAND is a terminal */
3842     /* for creating the debugger DECTerm */
3843
3844     items[0].len = 4;
3845     items[0].code = DVI$_DEVCLASS;
3846     items[0].bufadr = &devclass;
3847     items[0].retadr = NULL;
3848     items[1].len = 0;
3849     items[1].code = 0;
3850
3851     status = sys$getdviw
3852         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3853
3854     if ($VMS_STATUS_SUCCESS(status)) {
3855         status = dvi_iosb[0];
3856     }
3857
3858     if (!$VMS_STATUS_SUCCESS(status)) {
3859         SETERRNO(EVMSERR, status);
3860         return -1;
3861     }
3862     else {
3863         if (devclass == DC$_TERM) {
3864             return 0;
3865         }
3866     }
3867     return -1;
3868 }
3869
3870 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3871 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3872 {
3873     int status;
3874     int ret_stat;
3875     char * ret_char;
3876     char device_name[65];
3877     unsigned short device_name_len;
3878     struct dsc$descriptor_s customization_dsc;
3879     struct dsc$descriptor_s device_name_dsc;
3880     const char * cptr;
3881     char customization[200];
3882     char title[40];
3883     pInfo info = NULL;
3884     char mbx1[64];
3885     unsigned short p_chan;
3886     int n;
3887     unsigned short iosb[4];
3888     const char * cust_str =
3889         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3890     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3891                                           DSC$K_CLASS_S, mbx1};
3892
3893      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3894     /*---------------------------------------*/
3895     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3896
3897
3898     /* Make sure that this is from the Perl debugger */
3899     ret_char = strstr(cmd," xterm ");
3900     if (ret_char == NULL)
3901         return NULL;
3902     cptr = ret_char + 7;
3903     ret_char = strstr(cmd,"tty");
3904     if (ret_char == NULL)
3905         return NULL;
3906     ret_char = strstr(cmd,"sleep");
3907     if (ret_char == NULL)
3908         return NULL;
3909
3910     if (decw_term_port == 0) {
3911         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3912         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3913         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3914
3915        status = lib$find_image_symbol
3916                                (&filename1_dsc,
3917                                 &decw_term_port_dsc,
3918                                 (void *)&decw_term_port,
3919                                 NULL,
3920                                 0);
3921
3922         /* Try again with the other image name */
3923         if (!$VMS_STATUS_SUCCESS(status)) {
3924
3925            status = lib$find_image_symbol
3926                                (&filename2_dsc,
3927                                 &decw_term_port_dsc,
3928                                 (void *)&decw_term_port,
3929                                 NULL,
3930                                 0);
3931
3932         }
3933
3934     }
3935
3936
3937     /* No decw$term_port, give it up */
3938     if (!$VMS_STATUS_SUCCESS(status))
3939         return NULL;
3940
3941     /* Are we on a workstation? */
3942     /* to do: capture the rows / columns and pass their properties */
3943     ret_stat = vms_is_syscommand_xterm();
3944     if (ret_stat < 0)
3945         return NULL;
3946
3947     /* Make the title: */
3948     ret_char = strstr(cptr,"-title");
3949     if (ret_char != NULL) {
3950         while ((*cptr != 0) && (*cptr != '\"')) {
3951             cptr++;
3952         }
3953         if (*cptr == '\"')
3954             cptr++;
3955         n = 0;
3956         while ((*cptr != 0) && (*cptr != '\"')) {
3957             title[n] = *cptr;
3958             n++;
3959             if (n == 39) {
3960                 title[39] = 0;
3961                 break;
3962             }
3963             cptr++;
3964         }
3965         title[n] = 0;
3966     }
3967     else {
3968             /* Default title */
3969             strcpy(title,"Perl Debug DECTerm");
3970     }
3971     sprintf(customization, cust_str, title);
3972
3973     customization_dsc.dsc$a_pointer = customization;
3974     customization_dsc.dsc$w_length = strlen(customization);
3975     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3976     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3977
3978     device_name_dsc.dsc$a_pointer = device_name;
3979     device_name_dsc.dsc$w_length = sizeof device_name -1;
3980     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3981     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3982
3983     device_name_len = 0;
3984
3985     /* Try to create the window */
3986      status = (*decw_term_port)
3987        (NULL,
3988         NULL,
3989         &customization_dsc,
3990         &device_name_dsc,
3991         &device_name_len,
3992         NULL,
3993         NULL,
3994         NULL);
3995     if (!$VMS_STATUS_SUCCESS(status)) {
3996         SETERRNO(EVMSERR, status);
3997         return NULL;
3998     }
3999
4000     device_name[device_name_len] = '\0';
4001
4002     /* Need to set this up to look like a pipe for cleanup */
4003     n = sizeof(Info);
4004     status = lib$get_vm(&n, &info);
4005     if (!$VMS_STATUS_SUCCESS(status)) {
4006         SETERRNO(ENOMEM, status);
4007         return NULL;
4008     }
4009
4010     info->mode = *mode;
4011     info->done = FALSE;
4012     info->completion = 0;
4013     info->closing    = FALSE;
4014     info->in         = 0;
4015     info->out        = 0;
4016     info->err        = 0;
4017     info->fp         = NULL;
4018     info->useFILE    = 0;
4019     info->waiting    = 0;
4020     info->in_done    = TRUE;
4021     info->out_done   = TRUE;
4022     info->err_done   = TRUE;
4023
4024     /* Assign a channel on this so that it will persist, and not login */
4025     /* We stash this channel in the info structure for reference. */
4026     /* The created xterm self destructs when the last channel is removed */
4027     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4028     /* So leave this assigned. */
4029     device_name_dsc.dsc$w_length = device_name_len;
4030     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4031     if (!$VMS_STATUS_SUCCESS(status)) {
4032         SETERRNO(EVMSERR, status);
4033         return NULL;
4034     }
4035     info->xchan_valid = 1;
4036
4037     /* Now create a mailbox to be read by the application */
4038
4039     create_mbx(&p_chan, &d_mbx1);
4040
4041     /* write the name of the created terminal to the mailbox */
4042     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4043             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4044
4045     if (!$VMS_STATUS_SUCCESS(status)) {
4046         SETERRNO(EVMSERR, status);
4047         return NULL;
4048     }
4049
4050     info->fp  = PerlIO_open(mbx1, mode);
4051
4052     /* Done with this channel */
4053     sys$dassgn(p_chan);
4054
4055     /* If any errors, then clean up */
4056     if (!info->fp) {
4057         n = sizeof(Info);
4058         _ckvmssts_noperl(lib$free_vm(&n, &info));
4059         return NULL;
4060         }
4061
4062     /* All done */
4063     return info->fp;
4064 }
4065
4066 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4067
4068 static PerlIO *
4069 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4070 {
4071     static int handler_set_up = FALSE;
4072     PerlIO * ret_fp;
4073     unsigned long int sts, flags = CLI$M_NOWAIT;
4074     /* The use of a GLOBAL table (as was done previously) rendered
4075      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4076      * environment.  Hence we've switched to LOCAL symbol table.
4077      */
4078     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4079     int j, wait = 0, n;
4080     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4081     char *in, *out, *err, mbx[512];
4082     FILE *tpipe = 0;
4083     char tfilebuf[NAM$C_MAXRSS+1];
4084     pInfo info = NULL;
4085     char cmd_sym_name[20];
4086     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4087                                       DSC$K_CLASS_S, symbol};
4088     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4089                                       DSC$K_CLASS_S, 0};
4090     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4091                                       DSC$K_CLASS_S, cmd_sym_name};
4092     struct dsc$descriptor_s *vmscmd;
4093     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4094     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4095     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4096
4097     /* Check here for Xterm create request.  This means looking for
4098      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4099      *  is possible to create an xterm.
4100      */
4101     if (*in_mode == 'r') {
4102         PerlIO * xterm_fd;
4103
4104 #if defined(PERL_IMPLICIT_CONTEXT)
4105         /* Can not fork an xterm with a NULL context */
4106         /* This probably could never happen */
4107         xterm_fd = NULL;
4108         if (aTHX != NULL)
4109 #endif
4110         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4111         if (xterm_fd != NULL)
4112             return xterm_fd;
4113     }
4114
4115     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4116
4117     /* once-per-program initialization...
4118        note that the SETAST calls and the dual test of pipe_ef
4119        makes sure that only the FIRST thread through here does
4120        the initialization...all other threads wait until it's
4121        done.
4122
4123        Yeah, uglier than a pthread call, it's got all the stuff inline
4124        rather than in a separate routine.
4125     */
4126
4127     if (!pipe_ef) {
4128         _ckvmssts_noperl(sys$setast(0));
4129         if (!pipe_ef) {
4130             unsigned long int pidcode = JPI$_PID;
4131             $DESCRIPTOR(d_delay, RETRY_DELAY);
4132             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4133             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4134             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4135         }
4136         if (!handler_set_up) {
4137           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4138           handler_set_up = TRUE;
4139         }
4140         _ckvmssts_noperl(sys$setast(1));
4141     }
4142
4143     /* see if we can find a VMSPIPE.COM */
4144
4145     tfilebuf[0] = '@';
4146     vmspipe = find_vmspipe(aTHX);
4147     if (vmspipe) {
4148         vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4149     } else {        /* uh, oh...we're in tempfile hell */
4150         tpipe = vmspipe_tempfile(aTHX);
4151         if (!tpipe) {       /* a fish popular in Boston */
4152             if (ckWARN(WARN_PIPE)) {
4153                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4154             }
4155         return NULL;
4156         }
4157         fgetname(tpipe,tfilebuf+1,1);
4158         vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4159     }
4160     vmspipedsc.dsc$a_pointer = tfilebuf;
4161
4162     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4163     if (!(sts & 1)) {
4164       switch (sts) {
4165         case RMS$_FNF:  case RMS$_DNF:
4166           set_errno(ENOENT); break;
4167         case RMS$_DIR:
4168           set_errno(ENOTDIR); break;
4169         case RMS$_DEV:
4170           set_errno(ENODEV); break;
4171         case RMS$_PRV:
4172           set_errno(EACCES); break;
4173         case RMS$_SYN:
4174           set_errno(EINVAL); break;
4175         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4176           set_errno(E2BIG); break;
4177         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4178           _ckvmssts_noperl(sts); /* fall through */
4179         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4180           set_errno(EVMSERR);
4181       }
4182       set_vaxc_errno(sts);
4183       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4184         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4185       }
4186       *psts = sts;
4187       return NULL;
4188     }
4189     n = sizeof(Info);
4190     _ckvmssts_noperl(lib$get_vm(&n, &info));
4191
4192     my_strlcpy(mode, in_mode, sizeof(mode));
4193     info->mode = *mode;
4194     info->done = FALSE;
4195     info->completion = 0;
4196     info->closing    = FALSE;
4197     info->in         = 0;
4198     info->out        = 0;
4199     info->err        = 0;
4200     info->fp         = NULL;
4201     info->useFILE    = 0;
4202     info->waiting    = 0;
4203     info->in_done    = TRUE;
4204     info->out_done   = TRUE;
4205     info->err_done   = TRUE;
4206     info->xchan      = 0;
4207     info->xchan_valid = 0;
4208
4209     in = (char *)PerlMem_malloc(VMS_MAXRSS);
4210     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4211     out = (char *)PerlMem_malloc(VMS_MAXRSS);
4212     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4213     err = (char *)PerlMem_malloc(VMS_MAXRSS);
4214     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4215
4216     in[0] = out[0] = err[0] = '\0';
4217
4218     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4219         info->useFILE = 1;
4220         strcpy(p,p+1);
4221     }
4222     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4223         wait = 1;
4224         strcpy(p,p+1);
4225     }
4226
4227     if (*mode == 'r') {             /* piping from subroutine */
4228
4229         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4230         if (info->out) {
4231             info->out->pipe_done = &info->out_done;
4232             info->out_done = FALSE;
4233             info->out->info = info;
4234         }
4235         if (!info->useFILE) {
4236             info->fp  = PerlIO_open(mbx, mode);
4237         } else {
4238             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4239             vmssetuserlnm("SYS$INPUT", mbx);
4240         }
4241
4242         if (!info->fp && info->out) {
4243             sys$cancel(info->out->chan_out);
4244
4245             while (!info->out_done) {
4246                 int done;
4247                 _ckvmssts_noperl(sys$setast(0));
4248                 done = info->out_done;
4249                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4250                 _ckvmssts_noperl(sys$setast(1));
4251                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4252             }
4253
4254             if (info->out->buf) {
4255                 n = info->out->bufsize * sizeof(char);
4256                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4257             }
4258             n = sizeof(Pipe);
4259             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4260             n = sizeof(Info);
4261             _ckvmssts_noperl(lib$free_vm(&n, &info));
4262             *psts = RMS$_FNF;
4263             return NULL;
4264         }
4265
4266         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4267         if (info->err) {
4268             info->err->pipe_done = &info->err_done;
4269             info->err_done = FALSE;
4270             info->err->info = info;
4271         }
4272
4273     } else if (*mode == 'w') {      /* piping to subroutine */
4274
4275         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4276         if (info->out) {
4277             info->out->pipe_done = &info->out_done;
4278             info->out_done = FALSE;
4279             info->out->info = info;
4280         }
4281
4282         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4283         if (info->err) {
4284             info->err->pipe_done = &info->err_done;
4285             info->err_done = FALSE;
4286             info->err->info = info;
4287         }
4288
4289         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4290         if (!info->useFILE) {
4291             info->fp  = PerlIO_open(mbx, mode);
4292         } else {
4293             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4294             vmssetuserlnm("SYS$OUTPUT", mbx);
4295         }
4296
4297         if (info->in) {
4298             info->in->pipe_done = &info->in_done;
4299             info->in_done = FALSE;
4300             info->in->info = info;
4301         }
4302
4303         /* error cleanup */
4304         if (!info->fp && info->in) {
4305             info->done = TRUE;
4306             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4307                                       0, 0, 0, 0, 0, 0, 0, 0));
4308
4309             while (!info->in_done) {
4310                 int done;
4311                 _ckvmssts_noperl(sys$setast(0));
4312                 done = info->in_done;
4313                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4314                 _ckvmssts_noperl(sys$setast(1));
4315                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4316             }
4317
4318             if (info->in->buf) {
4319                 n = info->in->bufsize * sizeof(char);
4320                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4321             }
4322             n = sizeof(Pipe);
4323             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4324             n = sizeof(Info);
4325             _ckvmssts_noperl(lib$free_vm(&n, &info));
4326             *psts = RMS$_FNF;
4327             return NULL;
4328         }
4329
4330
4331     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4332         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4333         if (info->out) {
4334             info->out->pipe_done = &info->out_done;
4335             info->out_done = FALSE;
4336             info->out->info = info;
4337         }
4338
4339         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4340         if (info->err) {
4341             info->err->pipe_done = &info->err_done;
4342             info->err_done = FALSE;
4343             info->err->info = info;
4344         }
4345     }
4346
4347     d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4348     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4349
4350     d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4351     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4352
4353     d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4354     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4355
4356     /* Done with the names for the pipes */
4357     PerlMem_free(err);
4358     PerlMem_free(out);
4359     PerlMem_free(in);
4360
4361     p = vmscmd->dsc$a_pointer;
4362     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4363     if (*p == '$') p++;                         /* remove leading $ */
4364     while (*p == ' ' || *p == '\t') p++;
4365
4366     for (j = 0; j < 4; j++) {
4367         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4368         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4369
4370     d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4371     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4372
4373         if (strlen(p) > MAX_DCL_SYMBOL) {
4374             p += MAX_DCL_SYMBOL;
4375         } else {
4376             p += strlen(p);
4377         }
4378     }
4379     _ckvmssts_noperl(sys$setast(0));
4380     info->next=open_pipes;  /* prepend to list */
4381     open_pipes=info;
4382     _ckvmssts_noperl(sys$setast(1));
4383     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4384      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4385      * have SYS$COMMAND if we need it.
4386      */
4387     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4388                       0, &info->pid, &info->completion,
4389                       0, popen_completion_ast,info,0,0,0));
4390
4391     /* if we were using a tempfile, close it now */
4392
4393     if (tpipe) fclose(tpipe);
4394
4395     /* once the subprocess is spawned, it has copied the symbols and
4396        we can get rid of ours */
4397
4398     for (j = 0; j < 4; j++) {
4399         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4400         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4401     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4402     }
4403     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4404     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4405     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4406     vms_execfree(vmscmd);
4407
4408 #ifdef PERL_IMPLICIT_CONTEXT
4409     if (aTHX)
4410 #endif
4411     PL_forkprocess = info->pid;
4412
4413     ret_fp = info->fp;
4414     if (wait) {
4415          dSAVEDERRNO;
4416          int done = 0;
4417          while (!done) {
4418              _ckvmssts_noperl(sys$setast(0));
4419              done = info->done;
4420              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4421              _ckvmssts_noperl(sys$setast(1));
4422              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4423          }
4424         *psts = info->completion;
4425 /* Caller thinks it is open and tries to close it. */
4426 /* This causes some problems, as it changes the error status */
4427 /*        my_pclose(info->fp); */
4428
4429          /* If we did not have a file pointer open, then we have to */
4430          /* clean up here or eventually we will run out of something */
4431          SAVE_ERRNO;
4432          if (info->fp == NULL) {
4433              my_pclose_pinfo(aTHX_ info);
4434          }
4435          RESTORE_ERRNO;
4436
4437     } else {
4438         *psts = info->pid;
4439     }
4440     return ret_fp;
4441 }  /* end of safe_popen */
4442
4443
4444 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4445 PerlIO *
4446 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4447 {
4448     int sts;
4449     TAINT_ENV();
4450     TAINT_PROPER("popen");
4451     PERL_FLUSHALL_FOR_CHILD;
4452     return safe_popen(aTHX_ cmd,mode,&sts);
4453 }
4454
4455 /*}}}*/
4456
4457
4458 /* Routine to close and cleanup a pipe info structure */
4459
4460 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4461
4462     unsigned long int retsts;
4463     int done, n;
4464     pInfo next, last;
4465
4466     /* If we were writing to a subprocess, insure that someone reading from
4467      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4468      * produce an EOF record in the mailbox.
4469      *
4470      *  well, at least sometimes it *does*, so we have to watch out for
4471      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4472      */
4473      if (info->fp) {
4474         if (!info->useFILE
4475 #if defined(USE_ITHREADS)
4476           && my_perl
4477 #endif
4478 #ifdef USE_PERLIO
4479           && PL_perlio_fd_refcnt
4480 #endif
4481            )
4482             PerlIO_flush(info->fp);
4483         else
4484             fflush((FILE *)info->fp);
4485     }
4486
4487     _ckvmssts(sys$setast(0));
4488      info->closing = TRUE;
4489      done = info->done && info->in_done && info->out_done && info->err_done;
4490      /* hanging on write to Perl's input? cancel it */
4491      if (info->mode == 'r' && info->out && !info->out_done) {
4492         if (info->out->chan_out) {
4493             _ckvmssts(sys$cancel(info->out->chan_out));
4494             if (!info->out->chan_in) {   /* EOF generation, need AST */
4495                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4496             }
4497         }
4498      }
4499      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4500          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4501                            0, 0, 0, 0, 0, 0));
4502     _ckvmssts(sys$setast(1));
4503     if (info->fp) {
4504      if (!info->useFILE
4505 #if defined(USE_ITHREADS)
4506          && my_perl
4507 #endif
4508 #ifdef USE_PERLIO
4509          && PL_perlio_fd_refcnt
4510 #endif
4511         )
4512         PerlIO_close(info->fp);
4513      else
4514         fclose((FILE *)info->fp);
4515     }
4516      /*
4517         we have to wait until subprocess completes, but ALSO wait until all
4518         the i/o completes...otherwise we'll be freeing the "info" structure
4519         that the i/o ASTs could still be using...
4520      */
4521
4522      while (!done) {
4523          _ckvmssts(sys$setast(0));
4524          done = info->done && info->in_done && info->out_done && info->err_done;
4525          if (!done) _ckvmssts(sys$clref(pipe_ef));
4526          _ckvmssts(sys$setast(1));
4527          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4528      }
4529      retsts = info->completion;
4530
4531     /* remove from list of open pipes */
4532     _ckvmssts(sys$setast(0));
4533     last = NULL;
4534     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4535         if (next == info)
4536             break;
4537     }
4538
4539     if (last)
4540         last->next = info->next;
4541     else
4542         open_pipes = info->next;
4543     _ckvmssts(sys$setast(1));
4544
4545     /* free buffers and structures */
4546
4547     if (info->in) {
4548         if (info->in->buf) {
4549             n = info->in->bufsize * sizeof(char);
4550             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4551         }
4552         n = sizeof(Pipe);
4553         _ckvmssts(lib$free_vm(&n, &info->in));
4554     }
4555     if (info->out) {
4556         if (info->out->buf) {
4557             n = info->out->bufsize * sizeof(char);
4558             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4559         }
4560         n = sizeof(Pipe);
4561         _ckvmssts(lib$free_vm(&n, &info->out));
4562     }
4563     if (info->err) {
4564         if (info->err->buf) {
4565             n = info->err->bufsize * sizeof(char);
4566             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4567         }
4568         n = sizeof(Pipe);
4569         _ckvmssts(lib$free_vm(&n, &info->err));
4570     }
4571     n = sizeof(Info);
4572     _ckvmssts(lib$free_vm(&n, &info));
4573
4574     return retsts;
4575 }
4576
4577
4578 /*{{{  I32 my_pclose(PerlIO *fp)*/
4579 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4580 {
4581     pInfo info, last = NULL;
4582     I32 ret_status;
4583
4584     /* Fixme - need ast and mutex protection here */
4585     for (info = open_pipes; info != NULL; last = info, info = info->next)
4586         if (info->fp == fp) break;
4587
4588     if (info == NULL) {  /* no such pipe open */
4589       set_errno(ECHILD); /* quoth POSIX */
4590       set_vaxc_errno(SS$_NONEXPR);
4591       return -1;
4592     }
4593
4594     ret_status = my_pclose_pinfo(aTHX_ info);
4595
4596     return ret_status;
4597
4598 }  /* end of my_pclose() */
4599
4600 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4601   /* Roll our own prototype because we want this regardless of whether
4602    * _VMS_WAIT is defined.
4603    */
4604
4605 #ifdef __cplusplus
4606 extern "C" {
4607 #endif
4608   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4609 #ifdef __cplusplus
4610 }
4611 #endif
4612
4613 #endif
4614 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4615    created with popen(); otherwise partially emulate waitpid() unless
4616    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4617    Also check processes not considered by the CRTL waitpid().
4618  */
4619 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4620 Pid_t
4621 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4622 {
4623     pInfo info;
4624     int done;
4625     int sts;
4626     int j;
4627
4628     if (statusp) *statusp = 0;
4629
4630     for (info = open_pipes; info != NULL; info = info->next)
4631         if (info->pid == pid) break;
4632
4633     if (info != NULL) {  /* we know about this child */
4634       while (!info->done) {
4635           _ckvmssts(sys$setast(0));
4636           done = info->done;
4637           if (!done) _ckvmssts(sys$clref(pipe_ef));
4638           _ckvmssts(sys$setast(1));
4639           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4640       }
4641
4642       if (statusp) *statusp = info->completion;
4643       return pid;
4644     }
4645
4646     /* child that already terminated? */
4647
4648     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4649         if (closed_list[j].pid == pid) {
4650             if (statusp) *statusp = closed_list[j].completion;
4651             return pid;
4652         }
4653     }
4654
4655     /* fall through if this child is not one of our own pipe children */
4656
4657 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4658
4659       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4660        * in 7.2 did we get a version that fills in the VMS completion
4661        * status as Perl has always tried to do.
4662        */
4663
4664       sts = __vms_waitpid( pid, statusp, flags );
4665
4666       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4667          return sts;
4668
4669       /* If the real waitpid tells us the child does not exist, we
4670        * fall through here to implement waiting for a child that
4671        * was created by some means other than exec() (say, spawned
4672        * from DCL) or to wait for a process that is not a subprocess
4673        * of the current process.
4674        */
4675
4676 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4677
4678     {
4679       $DESCRIPTOR(intdsc,"0 00:00:01");
4680       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4681       unsigned long int pidcode = JPI$_PID, mypid;
4682       unsigned long int interval[2];
4683       unsigned int jpi_iosb[2];
4684       struct itmlst_3 jpilist[2] = {
4685           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4686           {                      0,         0,                 0, 0}
4687       };
4688
4689       if (pid <= 0) {
4690         /* Sorry folks, we don't presently implement rooting around for
4691            the first child we can find, and we definitely don't want to
4692            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4693          */
4694         set_errno(ENOTSUP);
4695         return -1;
4696       }
4697
4698       /* Get the owner of the child so I can warn if it's not mine. If the
4699        * process doesn't exist or I don't have the privs to look at it,
4700        * I can go home early.
4701        */
4702       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4703       if (sts & 1) sts = jpi_iosb[0];
4704       if (!(sts & 1)) {
4705         switch (sts) {
4706             case SS$_NONEXPR:
4707                 set_errno(ECHILD);
4708                 break;
4709             case SS$_NOPRIV:
4710                 set_errno(EACCES);
4711                 break;
4712             default:
4713                 _ckvmssts(sts);
4714         }
4715         set_vaxc_errno(sts);
4716         return -1;
4717       }
4718
4719       if (ckWARN(WARN_EXEC)) {
4720         /* remind folks they are asking for non-standard waitpid behavior */
4721         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4722         if (ownerpid != mypid)
4723           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4724                       "waitpid: process %x is not a child of process %x",
4725                       pid,mypid);
4726       }
4727
4728       /* simply check on it once a second until it's not there anymore. */
4729
4730       _ckvmssts(sys$bintim(&intdsc,interval));
4731       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4732             _ckvmssts(sys$schdwk(0,0,interval,0));
4733             _ckvmssts(sys$hiber());
4734       }
4735       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4736
4737       _ckvmssts(sts);
4738       return pid;
4739     }
4740 }  /* end of waitpid() */
4741 /*}}}*/
4742 /*}}}*/
4743 /*}}}*/
4744
4745 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4746 char *
4747 my_gconvert(double val, int ndig, int trail, char *buf)
4748 {
4749   static char __gcvtbuf[DBL_DIG+1];
4750   char *loc;
4751
4752   loc = buf ? buf : __gcvtbuf;
4753
4754   if (val) {
4755     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4756     return gcvt(val,ndig,loc);
4757   }
4758   else {
4759     loc[0] = '0'; loc[1] = '\0';
4760     return loc;
4761   }
4762
4763 }
4764 /*}}}*/
4765
4766 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4767 static int rms_free_search_context(struct FAB * fab)
4768 {
4769 struct NAM * nam;
4770
4771     nam = fab->fab$l_nam;
4772     nam->nam$b_nop |= NAM$M_SYNCHK;
4773     nam->nam$l_rlf = NULL;
4774     fab->fab$b_dns = 0;
4775     return sys$parse(fab, NULL, NULL);
4776 }
4777
4778 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4779 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4780 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4781 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4782 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4783 #define rms_nam_esll(nam) nam.nam$b_esl
4784 #define rms_nam_esl(nam) nam.nam$b_esl
4785 #define rms_nam_name(nam) nam.nam$l_name
4786 #define rms_nam_namel(nam) nam.nam$l_name
4787 #define rms_nam_type(nam) nam.nam$l_type
4788 #define rms_nam_typel(nam) nam.nam$l_type
4789 #define rms_nam_ver(nam) nam.nam$l_ver
4790 #define rms_nam_verl(nam) nam.nam$l_ver
4791 #define rms_nam_rsll(nam) nam.nam$b_rsl
4792 #define rms_nam_rsl(nam) nam.nam$b_rsl
4793 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4794 #define rms_set_fna(fab, nam, name, size) \
4795         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4796 #define rms_get_fna(fab, nam) fab.fab$l_fna
4797 #define rms_set_dna(fab, nam, name, size) \
4798         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4799 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4800 #define rms_set_esa(nam, name, size) \
4801         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4802 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4803         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4804 #define rms_set_rsa(nam, name, size) \
4805         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4806 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4807         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4808 #define rms_nam_name_type_l_size(nam) \
4809         (nam.nam$b_name + nam.nam$b_type)
4810 #else
4811 static int rms_free_search_context(struct FAB * fab)
4812 {
4813 struct NAML * nam;
4814
4815     nam = fab->fab$l_naml;
4816     nam->naml$b_nop |= NAM$M_SYNCHK;
4817     nam->naml$l_rlf = NULL;
4818     nam->naml$l_long_defname_size = 0;
4819
4820     fab->fab$b_dns = 0;
4821     return sys$parse(fab, NULL, NULL);
4822 }
4823
4824 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4825 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4826 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4827 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4828 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4829 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4830 #define rms_nam_esl(nam) nam.naml$b_esl
4831 #define rms_nam_name(nam) nam.naml$l_name
4832 #define rms_nam_namel(nam) nam.naml$l_long_name
4833 #define rms_nam_type(nam) nam.naml$l_type
4834 #define rms_nam_typel(nam) nam.naml$l_long_type
4835 #define rms_nam_ver(nam) nam.naml$l_ver
4836 #define rms_nam_verl(nam) nam.naml$l_long_ver
4837 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4838 #define rms_nam_rsl(nam) nam.naml$b_rsl
4839 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4840 #define rms_set_fna(fab, nam, name, size) \
4841         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4842         nam.naml$l_long_filename_size = size; \
4843         nam.naml$l_long_filename = name;}
4844 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4845 #define rms_set_dna(fab, nam, name, size) \
4846         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4847         nam.naml$l_long_defname_size = size; \
4848         nam.naml$l_long_defname = name; }
4849 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4850 #define rms_set_esa(nam, name, size) \
4851         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4852         nam.naml$l_long_expand_alloc = size; \
4853         nam.naml$l_long_expand = name; }
4854 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4855         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4856         nam.naml$l_long_expand = l_name; \
4857         nam.naml$l_long_expand_alloc = l_size; }
4858 #define rms_set_rsa(nam, name, size) \
4859         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4860         nam.naml$l_long_result = name; \
4861         nam.naml$l_long_result_alloc = size; }
4862 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4863         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4864         nam.naml$l_long_result = l_name; \
4865         nam.naml$l_long_result_alloc = l_size; }
4866 #define rms_nam_name_type_l_size(nam) \
4867         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4868 #endif
4869
4870
4871 /* rms_erase
4872  * The CRTL for 8.3 and later can create symbolic links in any mode,
4873  * however in 8.3 the unlink/remove/delete routines will only properly handle
4874  * them if one of the PCP modes is active.
4875  */
4876 static int rms_erase(const char * vmsname)
4877 {
4878   int status;
4879   struct FAB myfab = cc$rms_fab;
4880   rms_setup_nam(mynam);
4881
4882   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4883   rms_bind_fab_nam(myfab, mynam);
4884
4885 #ifdef NAML$M_OPEN_SPECIAL
4886   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4887 #endif
4888
4889   status = sys$erase(&myfab, 0, 0);
4890
4891   return status;
4892 }
4893
4894
4895 static int
4896 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4897                     const struct dsc$descriptor_s * vms_dst_dsc,
4898                     unsigned long flags)
4899 {
4900     /*  VMS and UNIX handle file permissions differently and the
4901      * the same ACL trick may be needed for renaming files,
4902      * especially if they are directories.
4903      */
4904
4905    /* todo: get kill_file and rename to share common code */
4906    /* I can not find online documentation for $change_acl
4907     * it appears to be replaced by $set_security some time ago */
4908
4909 const unsigned int access_mode = 0;
4910 $DESCRIPTOR(obj_file_dsc,"FILE");
4911 char *vmsname;
4912 char *rslt;
4913 unsigned long int jpicode = JPI$_UIC;
4914 int aclsts, fndsts, rnsts = -1;
4915 unsigned int ctx = 0;
4916 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4917 struct dsc$descriptor_s * clean_dsc;
4918
4919 struct myacedef {
4920     unsigned char myace$b_length;
4921     unsigned char myace$b_type;
4922     unsigned short int myace$w_flags;
4923     unsigned long int myace$l_access;
4924     unsigned long int myace$l_ident;
4925 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4926              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4927              0},
4928              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4929
4930 struct item_list_3
4931         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4932                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4933                       {0,0,0,0}},
4934         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4935         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4936                      {0,0,0,0}};
4937
4938
4939     /* Expand the input spec using RMS, since we do not want to put
4940      * ACLs on the target of a symbolic link */
4941     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
4942     if (vmsname == NULL)
4943         return SS$_INSFMEM;
4944
4945     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4946                         vmsname,
4947                         PERL_RMSEXPAND_M_SYMLINK);
4948     if (rslt == NULL) {
4949         PerlMem_free(vmsname);
4950         return SS$_INSFMEM;
4951     }
4952
4953     /* So we get our own UIC to use as a rights identifier,
4954      * and the insert an ACE at the head of the ACL which allows us
4955      * to delete the file.
4956      */
4957     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4958
4959     fildsc.dsc$w_length = strlen(vmsname);
4960     fildsc.dsc$a_pointer = vmsname;
4961     ctx = 0;
4962     newace.myace$l_ident = oldace.myace$l_ident;
4963     rnsts = SS$_ABORT;
4964
4965     /* Grab any existing ACEs with this identifier in case we fail */
4966     clean_dsc = &fildsc;
4967     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4968                                &fildsc,
4969                                NULL,
4970                                OSS$M_WLOCK,
4971                                findlst,
4972                                &ctx,
4973                                &access_mode);
4974
4975     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4976         /* Add the new ACE . . . */
4977
4978         /* if the sys$get_security succeeded, then ctx is valid, and the
4979          * object/file descriptors will be ignored.  But otherwise they
4980          * are needed
4981          */
4982         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4983                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4984         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4985             set_errno(EVMSERR);
4986             set_vaxc_errno(aclsts);
4987             PerlMem_free(vmsname);
4988             return aclsts;
4989         }
4990
4991         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4992                                 NULL, NULL,
4993                                 &flags,
4994                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4995
4996         if ($VMS_STATUS_SUCCESS(rnsts)) {
4997             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4998         }
4999
5000         /* Put things back the way they were. */
5001         ctx = 0;
5002         aclsts = sys$get_security(&obj_file_dsc,
5003                                   clean_dsc,
5004                                   NULL,
5005                                   OSS$M_WLOCK,
5006                                   findlst,
5007                                   &ctx,
5008                                   &access_mode);
5009
5010         if ($VMS_STATUS_SUCCESS(aclsts)) {
5011         int sec_flags;
5012
5013             sec_flags = 0;
5014             if (!$VMS_STATUS_SUCCESS(fndsts))
5015                 sec_flags = OSS$M_RELCTX;
5016
5017             /* Get rid of the new ACE */
5018             aclsts = sys$set_security(NULL, NULL, NULL,
5019                                   sec_flags, dellst, &ctx, &access_mode);
5020
5021             /* If there was an old ACE, put it back */
5022             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5023                 addlst[0].bufadr = &oldace;
5024                 aclsts = sys$set_security(NULL, NULL, NULL,
5025                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5026                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5027                     set_errno(EVMSERR);
5028                     set_vaxc_errno(aclsts);
5029                     rnsts = aclsts;
5030                 }
5031             } else {
5032             int aclsts2;
5033
5034                 /* Try to clear the lock on the ACL list */
5035                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5036                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5037
5038                 /* Rename errors are most important */
5039                 if (!$VMS_STATUS_SUCCESS(rnsts))
5040                     aclsts = rnsts;
5041                 set_errno(EVMSERR);
5042                 set_vaxc_errno(aclsts);
5043                 rnsts = aclsts;
5044             }
5045         }
5046         else {
5047             if (aclsts != SS$_ACLEMPTY)
5048                 rnsts = aclsts;
5049         }
5050     }
5051     else
5052         rnsts = fndsts;
5053
5054     PerlMem_free(vmsname);
5055     return rnsts;
5056 }
5057
5058
5059 /*{{{int rename(const char *, const char * */
5060 /* Not exactly what X/Open says to do, but doing it absolutely right
5061  * and efficiently would require a lot more work.  This should be close
5062  * enough to pass all but the most strict X/Open compliance test.
5063  */
5064 int
5065 Perl_rename(pTHX_ const char *src, const char * dst)
5066 {
5067 int retval;
5068 int pre_delete = 0;
5069 int src_sts;
5070 int dst_sts;
5071 Stat_t src_st;
5072 Stat_t dst_st;
5073
5074     /* Validate the source file */
5075     src_sts = flex_lstat(src, &src_st);
5076     if (src_sts != 0) {
5077
5078         /* No source file or other problem */
5079         return src_sts;
5080     }
5081     if (src_st.st_devnam[0] == 0)  {
5082         /* This may be possible so fail if it is seen. */
5083         errno = EIO;
5084         return -1;
5085     }
5086
5087     dst_sts = flex_lstat(dst, &dst_st);
5088     if (dst_sts == 0) {
5089
5090         if (dst_st.st_dev != src_st.st_dev) {
5091             /* Must be on the same device */
5092             errno = EXDEV;
5093             return -1;
5094         }
5095
5096         /* VMS_INO_T_COMPARE is true if the inodes are different
5097          * to match the output of memcmp
5098          */
5099
5100         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5101             /* That was easy, the files are the same! */
5102             return 0;
5103         }
5104
5105         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5106             /* If source is a directory, so must be dest */
5107                 errno = EISDIR;
5108                 return -1;
5109         }
5110
5111     }
5112
5113
5114     if ((dst_sts == 0) &&
5115         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5116
5117         /* We have issues here if vms_unlink_all_versions is set
5118          * If the destination exists, and is not a directory, then
5119          * we must delete in advance.
5120          *
5121          * If the src is a directory, then we must always pre-delete
5122          * the destination.
5123          *
5124          * If we successfully delete the dst in advance, and the rename fails
5125          * X/Open requires that errno be EIO.
5126          *
5127          */
5128
5129         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5130             int d_sts;
5131             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5132                                      S_ISDIR(dst_st.st_mode));
5133
5134            /* Need to delete all versions ? */
5135            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5136                 int i = 0;
5137
5138                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5139                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5140                     if (d_sts != 0)
5141                         break;
5142                     i++;
5143
5144                     /* Make sure that we do not loop forever */
5145                     if (i > 32767) {
5146                         errno = EIO;
5147                         d_sts = -1;
5148                         break;
5149                     }
5150                 }
5151            }
5152
5153             if (d_sts != 0)
5154                 return d_sts;
5155
5156             /* We killed the destination, so only errno now is EIO */
5157             pre_delete = 1;
5158         }
5159     }
5160
5161     /* Originally the idea was to call the CRTL rename() and only
5162      * try the lib$rename_file if it failed.
5163      * It turns out that there are too many variants in what the
5164      * the CRTL rename might do, so only use lib$rename_file
5165      */
5166     retval = -1;
5167
5168     {
5169         /* Is the source and dest both in VMS format */
5170         /* if the source is a directory, then need to fileify */
5171         /*  and dest must be a directory or non-existent. */
5172
5173         char * vms_dst;
5174         int sts;
5175         char * ret_str;
5176         unsigned long flags;
5177         struct dsc$descriptor_s old_file_dsc;
5178         struct dsc$descriptor_s new_file_dsc;
5179
5180         /* We need to modify the src and dst depending
5181          * on if one or more of them are directories.
5182          */
5183
5184         vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
5185         if (vms_dst == NULL)
5186             _ckvmssts_noperl(SS$_INSFMEM);
5187
5188         if (S_ISDIR(src_st.st_mode)) {
5189         char * ret_str;
5190         char * vms_dir_file;
5191
5192             vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
5193             if (vms_dir_file == NULL)
5194                 _ckvmssts_noperl(SS$_INSFMEM);
5195
5196             /* If the dest is a directory, we must remove it */
5197             if (dst_sts == 0) {
5198                 int d_sts;
5199                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5200                 if (d_sts != 0) {
5201                     PerlMem_free(vms_dst);
5202                     errno = EIO;
5203                     return d_sts;
5204                 }
5205
5206                 pre_delete = 1;
5207             }
5208
5209            /* The dest must be a VMS file specification */
5210            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5211            if (ret_str == NULL) {
5212                 PerlMem_free(vms_dst);
5213                 errno = EIO;
5214                 return -1;
5215            }
5216
5217             /* The source must be a file specification */
5218             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5219             if (ret_str == NULL) {
5220                 PerlMem_free(vms_dst);
5221                 PerlMem_free(vms_dir_file);
5222                 errno = EIO;
5223                 return -1;
5224             }
5225             PerlMem_free(vms_dst);
5226             vms_dst = vms_dir_file;
5227
5228         } else {
5229             /* File to file or file to new dir */
5230
5231             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5232                 /* VMS pathify a dir target */
5233                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5234                 if (ret_str == NULL) {
5235                     PerlMem_free(vms_dst);
5236                     errno = EIO;
5237                     return -1;
5238                 }
5239             } else {
5240                 char * v_spec, * r_spec, * d_spec, * n_spec;
5241                 char * e_spec, * vs_spec;
5242                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5243
5244                 /* fileify a target VMS file specification */
5245                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5246                 if (ret_str == NULL) {
5247                     PerlMem_free(vms_dst);
5248                     errno = EIO;
5249                     return -1;
5250                 }
5251
5252                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5253                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5254                              &e_len, &vs_spec, &vs_len);
5255                 if (sts == 0) {
5256                      if (e_len == 0) {
5257                          /* Get rid of the version */
5258                          if (vs_len != 0) {
5259                              *vs_spec = '\0';
5260                          }
5261                          /* Need to specify a '.' so that the extension */
5262                          /* is not inherited */
5263                          strcat(vms_dst,".");
5264                      }
5265                 }
5266             }
5267         }
5268
5269         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5270         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5271         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5272         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5273
5274         new_file_dsc.dsc$a_pointer = vms_dst;
5275         new_file_dsc.dsc$w_length = strlen(vms_dst);
5276         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5277         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5278
5279         flags = 0;
5280 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5281         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5282 #endif
5283
5284         sts = lib$rename_file(&old_file_dsc,
5285                               &new_file_dsc,
5286                               NULL, NULL,
5287                               &flags,
5288                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5289         if (!$VMS_STATUS_SUCCESS(sts)) {
5290
5291            /* We could have failed because VMS style permissions do not
5292             * permit renames that UNIX will allow.  Just like the hack
5293             * in for kill_file.
5294             */
5295            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5296         }
5297
5298         PerlMem_free(vms_dst);
5299         if (!$VMS_STATUS_SUCCESS(sts)) {
5300             errno = EIO;
5301             return -1;
5302         }
5303         retval = 0;
5304     }
5305
5306     if (vms_unlink_all_versions) {
5307         /* Now get rid of any previous versions of the source file that
5308          * might still exist
5309          */
5310         int i = 0;
5311         dSAVEDERRNO;
5312         SAVE_ERRNO;
5313         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5314                                    S_ISDIR(src_st.st_mode));
5315         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5316              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5317                                        S_ISDIR(src_st.st_mode));
5318              if (src_sts != 0)
5319                  break;
5320              i++;
5321
5322              /* Make sure that we do not loop forever */
5323              if (i > 32767) {
5324                  src_sts = -1;
5325                  break;
5326              }
5327         }
5328         RESTORE_ERRNO;
5329     }
5330
5331     /* We deleted the destination, so must force the error to be EIO */
5332     if ((retval != 0) && (pre_delete != 0))
5333         errno = EIO;
5334
5335     return retval;
5336 }
5337 /*}}}*/
5338
5339
5340 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5341 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5342  * to expand file specification.  Allows for a single default file
5343  * specification and a simple mask of options.  If outbuf is non-NULL,
5344  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5345  * the resultant file specification is placed.  If outbuf is NULL, the
5346  * resultant file specification is placed into a static buffer.
5347  * The third argument, if non-NULL, is taken to be a default file
5348  * specification string.  The fourth argument is unused at present.
5349  * rmesexpand() returns the address of the resultant string if
5350  * successful, and NULL on error.
5351  *
5352  * New functionality for previously unused opts value:
5353  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5354  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5355  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5356  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5357  */
5358 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5359
5360 static char *
5361 int_rmsexpand
5362    (const char *filespec,
5363     char *outbuf,
5364     const char *defspec,
5365     unsigned opts,
5366     int * fs_utf8,
5367     int * dfs_utf8)
5368 {
5369   char * ret_spec;
5370   const char * in_spec;
5371   char * spec_buf;
5372   const char * def_spec;
5373   char * vmsfspec, *vmsdefspec;
5374   char * esa;
5375   char * esal = NULL;
5376   char * outbufl;
5377   struct FAB myfab = cc$rms_fab;
5378   rms_setup_nam(mynam);
5379   STRLEN speclen;
5380   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5381   int sts;
5382
5383   /* temp hack until UTF8 is actually implemented */
5384   if (fs_utf8 != NULL)
5385     *fs_utf8 = 0;
5386
5387   if (!filespec || !*filespec) {
5388     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5389     return NULL;
5390   }
5391
5392   vmsfspec = NULL;
5393   vmsdefspec = NULL;
5394   outbufl = NULL;
5395
5396   in_spec = filespec;
5397   isunix = 0;
5398   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5399       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5400       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5401
5402       /* If this is a UNIX file spec, convert it to VMS */
5403       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5404                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5405                            &e_len, &vs_spec, &vs_len);
5406       if (sts != 0) {
5407           isunix = 1;
5408           char * ret_spec;
5409
5410           vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5411           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5412           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5413           if (ret_spec == NULL) {
5414               PerlMem_free(vmsfspec);
5415               return NULL;
5416           }
5417           in_spec = (const char *)vmsfspec;
5418
5419           /* Unless we are forcing to VMS format, a UNIX input means
5420            * UNIX output, and that requires long names to be used
5421            */
5422           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5423 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5424               opts |= PERL_RMSEXPAND_M_LONG;
5425 #else
5426               NOOP;
5427 #endif
5428           else
5429               isunix = 0;
5430       }
5431
5432   }
5433
5434   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5435   rms_bind_fab_nam(myfab, mynam);
5436
5437   /* Process the default file specification if present */
5438   def_spec = defspec;
5439   if (defspec && *defspec) {
5440     int t_isunix;
5441     t_isunix = is_unix_filespec(defspec);
5442     if (t_isunix) {
5443       vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5444       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5445       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5446
5447       if (ret_spec == NULL) {
5448           /* Clean up and bail */
5449           PerlMem_free(vmsdefspec);
5450           if (vmsfspec != NULL)
5451               PerlMem_free(vmsfspec);
5452               return NULL;
5453           }
5454           def_spec = (const char *)vmsdefspec;
5455       }
5456       rms_set_dna(myfab, mynam,
5457                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5458   }
5459
5460   /* Now we need the expansion buffers */
5461   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
5462   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5463 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5464   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
5465   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5466 #endif
5467   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5468
5469   /* If a NAML block is used RMS always writes to the long and short
5470    * addresses unless you suppress the short name.
5471    */
5472 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5473   outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
5474   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5475 #endif
5476    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5477
5478 #ifdef NAM$M_NO_SHORT_UPCASE
5479   if (decc_efs_case_preserve)
5480     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5481 #endif
5482
5483    /* We may not want to follow symbolic links */
5484 #ifdef NAML$M_OPEN_SPECIAL
5485   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5486     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5487 #endif
5488
5489   /* First attempt to parse as an existing file */
5490   retsts = sys$parse(&myfab,0,0);
5491   if (!(retsts & STS$K_SUCCESS)) {
5492
5493     /* Could not find the file, try as syntax only if error is not fatal */
5494     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5495     if (retsts == RMS$_DNF ||
5496         retsts == RMS$_DIR ||
5497         retsts == RMS$_DEV ||
5498         retsts == RMS$_PRV) {
5499       retsts = sys$parse(&myfab,0,0);
5500       if (retsts & STS$K_SUCCESS) goto int_expanded;
5501     }
5502
5503      /* Still could not parse the file specification */
5504     /*----------------------------------------------*/
5505     sts = rms_free_search_context(&myfab); /* Free search context */
5506     if (vmsdefspec != NULL)
5507         PerlMem_free(vmsdefspec);
5508     if (vmsfspec != NULL)
5509         PerlMem_free(vmsfspec);
5510     if (outbufl != NULL)
5511         PerlMem_free(outbufl);
5512     PerlMem_free(esa);
5513     if (esal != NULL)
5514         PerlMem_free(esal);
5515     set_vaxc_errno(retsts);
5516     if      (retsts == RMS$_PRV) set_errno(EACCES);
5517     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5518     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5519     else                         set_errno(EVMSERR);
5520     return NULL;
5521   }
5522   retsts = sys$search(&myfab,0,0);
5523   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
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                         set_errno(EVMSERR);
5537     return NULL;
5538   }
5539
5540   /* If the input filespec contained any lowercase characters,
5541    * downcase the result for compatibility with Unix-minded code. */
5542 int_expanded:
5543   if (!decc_efs_case_preserve) {
5544     char * tbuf;
5545     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5546       if (islower(*tbuf)) { haslower = 1; break; }
5547   }
5548
5549    /* Is a long or a short name expected */
5550   /*------------------------------------*/
5551   spec_buf = NULL;
5552 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5553   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5554     if (rms_nam_rsll(mynam)) {
5555         spec_buf = outbufl;
5556         speclen = rms_nam_rsll(mynam);
5557     }
5558     else {
5559         spec_buf = esal; /* Not esa */
5560         speclen = rms_nam_esll(mynam);
5561     }
5562   }
5563   else {
5564 #endif
5565     if (rms_nam_rsl(mynam)) {
5566         spec_buf = outbuf;
5567         speclen = rms_nam_rsl(mynam);
5568     }
5569     else {
5570         spec_buf = esa; /* Not esal */
5571         speclen = rms_nam_esl(mynam);
5572     }
5573 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5574   }
5575 #endif
5576   spec_buf[speclen] = '\0';
5577
5578   /* Trim off null fields added by $PARSE
5579    * If type > 1 char, must have been specified in original or default spec
5580    * (not true for version; $SEARCH may have added version of existing file).
5581    */
5582   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5583   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5584     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5585              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5586   }
5587   else {
5588     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5589              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5590   }
5591   if (trimver || trimtype) {
5592     if (defspec && *defspec) {
5593       char *defesal = NULL;
5594       char *defesa = NULL;
5595       defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5596       if (defesa != NULL) {
5597         struct FAB deffab = cc$rms_fab;
5598 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5599         defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5600         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5601 #endif
5602         rms_setup_nam(defnam);
5603
5604         rms_bind_fab_nam(deffab, defnam);
5605
5606         /* Cast ok */
5607         rms_set_fna
5608             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5609
5610         /* RMS needs the esa/esal as a work area if wildcards are involved */
5611         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5612
5613         rms_clear_nam_nop(defnam);
5614         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5615 #ifdef NAM$M_NO_SHORT_UPCASE
5616         if (decc_efs_case_preserve)
5617           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5618 #endif
5619 #ifdef NAML$M_OPEN_SPECIAL
5620         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5621           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5622 #endif
5623         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5624           if (trimver) {
5625              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5626           }
5627           if (trimtype) {
5628             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5629           }
5630         }
5631         if (defesal != NULL)
5632             PerlMem_free(defesal);
5633         PerlMem_free(defesa);
5634       } else {
5635           _ckvmssts_noperl(SS$_INSFMEM);
5636       }
5637     }
5638     if (trimver) {
5639       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5640         if (*(rms_nam_verl(mynam)) != '\"')
5641           speclen = rms_nam_verl(mynam) - spec_buf;
5642       }
5643       else {
5644         if (*(rms_nam_ver(mynam)) != '\"')
5645           speclen = rms_nam_ver(mynam) - spec_buf;
5646       }
5647     }
5648     if (trimtype) {
5649       /* If we didn't already trim version, copy down */
5650       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5651         if (speclen > rms_nam_verl(mynam) - spec_buf)
5652           memmove
5653            (rms_nam_typel(mynam),
5654             rms_nam_verl(mynam),
5655             speclen - (rms_nam_verl(mynam) - spec_buf));
5656           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5657       }
5658       else {
5659         if (speclen > rms_nam_ver(mynam) - spec_buf)
5660           memmove
5661            (rms_nam_type(mynam),
5662             rms_nam_ver(mynam),
5663             speclen - (rms_nam_ver(mynam) - spec_buf));
5664           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5665       }
5666     }
5667   }
5668
5669    /* Done with these copies of the input files */
5670   /*-------------------------------------------*/
5671   if (vmsfspec != NULL)
5672         PerlMem_free(vmsfspec);
5673   if (vmsdefspec != NULL)
5674         PerlMem_free(vmsdefspec);
5675
5676   /* If we just had a directory spec on input, $PARSE "helpfully"
5677    * adds an empty name and type for us */
5678 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5679   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5680     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5681         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5682         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5683       speclen = rms_nam_namel(mynam) - spec_buf;
5684   }
5685   else
5686 #endif
5687   {
5688     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5689         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5690         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5691       speclen = rms_nam_name(mynam) - spec_buf;
5692   }
5693
5694   /* Posix format specifications must have matching quotes */
5695   if (speclen < (VMS_MAXRSS - 1)) {
5696     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5697       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5698         spec_buf[speclen] = '\"';
5699         speclen++;
5700       }
5701     }
5702   }
5703   spec_buf[speclen] = '\0';
5704   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5705
5706   /* Have we been working with an expanded, but not resultant, spec? */
5707   /* Also, convert back to Unix syntax if necessary. */
5708   {
5709   int rsl;
5710
5711 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5712     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5713       rsl = rms_nam_rsll(mynam);
5714     } else
5715 #endif
5716     {
5717       rsl = rms_nam_rsl(mynam);
5718     }
5719     if (!rsl) {
5720       /* rsl is not present, it means that spec_buf is either */
5721       /* esa or esal, and needs to be copied to outbuf */
5722       /* convert to Unix if desired */
5723       if (isunix) {
5724         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5725       } else {
5726         /* VMS file specs are not in UTF-8 */
5727         if (fs_utf8 != NULL)
5728             *fs_utf8 = 0;
5729         my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5730         ret_spec = outbuf;
5731       }
5732     }
5733     else {
5734       /* Now spec_buf is either outbuf or outbufl */
5735       /* We need the result into outbuf */
5736       if (isunix) {
5737            /* If we need this in UNIX, then we need another buffer */
5738            /* to keep things in order */
5739            char * src;
5740            char * new_src = NULL;
5741            if (spec_buf == outbuf) {
5742                new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
5743                my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5744            } else {
5745                src = spec_buf;
5746            }
5747            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5748            if (new_src) {
5749                PerlMem_free(new_src);
5750            }
5751       } else {
5752            /* VMS file specs are not in UTF-8 */
5753            if (fs_utf8 != NULL)
5754                *fs_utf8 = 0;
5755
5756            /* Copy the buffer if needed */
5757            if (outbuf != spec_buf)
5758                my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5759            ret_spec = outbuf;
5760       }
5761     }
5762   }
5763
5764   /* Need to clean up the search context */
5765   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5766   sts = rms_free_search_context(&myfab); /* Free search context */
5767
5768   /* Clean up the extra buffers */
5769   if (esal != NULL)
5770       PerlMem_free(esal);
5771   PerlMem_free(esa);
5772   if (outbufl != NULL)
5773      PerlMem_free(outbufl);
5774
5775   /* Return the result */
5776   return ret_spec;
5777 }
5778
5779 /* Common simple case - Expand an already VMS spec */
5780 static char *
5781 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5782     opts |= PERL_RMSEXPAND_M_VMS_IN;
5783     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5784 }
5785
5786 /* Common simple case - Expand to a VMS spec */
5787 static char *
5788 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5789     opts |= PERL_RMSEXPAND_M_VMS;
5790     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5791 }
5792
5793
5794 /* Entry point used by perl routines */
5795 static char *
5796 mp_do_rmsexpand
5797    (pTHX_ const char *filespec,
5798     char *outbuf,
5799     int ts,
5800     const char *defspec,
5801     unsigned opts,
5802     int * fs_utf8,
5803     int * dfs_utf8)
5804 {
5805     static char __rmsexpand_retbuf[VMS_MAXRSS];
5806     char * expanded, *ret_spec, *ret_buf;
5807
5808     expanded = NULL;
5809     ret_buf = outbuf;
5810     if (ret_buf == NULL) {
5811         if (ts) {
5812             Newx(expanded, VMS_MAXRSS, char);
5813             if (expanded == NULL)
5814                 _ckvmssts(SS$_INSFMEM);
5815             ret_buf = expanded;
5816         } else {
5817             ret_buf = __rmsexpand_retbuf;
5818         }
5819     }
5820
5821
5822     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5823                              opts, fs_utf8,  dfs_utf8);
5824
5825     if (ret_spec == NULL) {
5826        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5827        if (expanded)
5828            Safefree(expanded);
5829     }
5830
5831     return ret_spec;
5832 }
5833 /*}}}*/
5834 /* External entry points */
5835 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5836 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5837 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5838 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5839 char *Perl_rmsexpand_utf8
5840   (pTHX_ const char *spec, char *buf, const char *def,
5841    unsigned opt, int * fs_utf8, int * dfs_utf8)
5842 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5843 char *Perl_rmsexpand_utf8_ts
5844   (pTHX_ const char *spec, char *buf, const char *def,
5845    unsigned opt, int * fs_utf8, int * dfs_utf8)
5846 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5847
5848
5849 /*
5850 ** The following routines are provided to make life easier when
5851 ** converting among VMS-style and Unix-style directory specifications.
5852 ** All will take input specifications in either VMS or Unix syntax. On
5853 ** failure, all return NULL.  If successful, the routines listed below
5854 ** return a pointer to a buffer containing the appropriately
5855 ** reformatted spec (and, therefore, subsequent calls to that routine
5856 ** will clobber the result), while the routines of the same names with
5857 ** a _ts suffix appended will return a pointer to a mallocd string
5858 ** containing the appropriately reformatted spec.
5859 ** In all cases, only explicit syntax is altered; no check is made that
5860 ** the resulting string is valid or that the directory in question
5861 ** actually exists.
5862 **
5863 **   fileify_dirspec() - convert a directory spec into the name of the
5864 **     directory file (i.e. what you can stat() to see if it's a dir).
5865 **     The style (VMS or Unix) of the result is the same as the style
5866 **     of the parameter passed in.
5867 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5868 **     what you prepend to a filename to indicate what directory it's in).
5869 **     The style (VMS or Unix) of the result is the same as the style
5870 **     of the parameter passed in.
5871 **   tounixpath() - convert a directory spec into a Unix-style path.
5872 **   tovmspath() - convert a directory spec into a VMS-style path.
5873 **   tounixspec() - convert any file spec into a Unix-style file spec.
5874 **   tovmsspec() - convert any file spec into a VMS-style spec.
5875 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5876 **
5877 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5878 ** Permission is given to distribute this code as part of the Perl
5879 ** standard distribution under the terms of the GNU General Public
5880 ** License or the Perl Artistic License.  Copies of each may be
5881 ** found in the Perl standard distribution.
5882  */
5883
5884 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5885 static char *
5886 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5887 {
5888     unsigned long int dirlen, retlen, hasfilename = 0;
5889     char *cp1, *cp2, *lastdir;
5890     char *trndir, *vmsdir;
5891     unsigned short int trnlnm_iter_count;
5892     int sts;
5893     if (utf8_fl != NULL)
5894         *utf8_fl = 0;
5895
5896     if (!dir || !*dir) {
5897       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5898     }
5899     dirlen = strlen(dir);
5900     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5901     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5902       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5903         dir = "/sys$disk";
5904         dirlen = 9;
5905       }
5906       else
5907         dirlen = 1;
5908     }
5909     if (dirlen > (VMS_MAXRSS - 1)) {
5910       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5911       return NULL;
5912     }
5913     trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5914     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5915     if (!strpbrk(dir+1,"/]>:")  &&
5916         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5917       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5918       trnlnm_iter_count = 0;
5919       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
5920         trnlnm_iter_count++;
5921         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5922       }
5923       dirlen = strlen(trndir);
5924     }
5925     else {
5926       memcpy(trndir, dir, dirlen);
5927       trndir[dirlen] = '\0';
5928     }
5929
5930     /* At this point we are done with *dir and use *trndir which is a
5931      * copy that can be modified.  *dir must not be modified.
5932      */
5933
5934     /* If we were handed a rooted logical name or spec, treat it like a
5935      * simple directory, so that
5936      *    $ Define myroot dev:[dir.]
5937      *    ... do_fileify_dirspec("myroot",buf,1) ...
5938      * does something useful.
5939      */
5940     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5941       trndir[--dirlen] = '\0';
5942       trndir[dirlen-1] = ']';
5943     }
5944     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5945       trndir[--dirlen] = '\0';
5946       trndir[dirlen-1] = '>';
5947     }
5948
5949     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5950       /* If we've got an explicit filename, we can just shuffle the string. */
5951       if (*(cp1+1)) hasfilename = 1;
5952       /* Similarly, we can just back up a level if we've got multiple levels
5953          of explicit directories in a VMS spec which ends with directories. */
5954       else {
5955         for (cp2 = cp1; cp2 > trndir; cp2--) {
5956           if (*cp2 == '.') {
5957             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5958 /* fix-me, can not scan EFS file specs backward like this */
5959               *cp2 = *cp1; *cp1 = '\0';
5960               hasfilename = 1;
5961               break;
5962             }
5963           }
5964           if (*cp2 == '[' || *cp2 == '<') break;
5965         }
5966       }
5967     }
5968
5969     vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5970     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5971     cp1 = strpbrk(trndir,"]:>");
5972     if (hasfilename || !cp1) { /* filename present or not VMS */
5973
5974       if (trndir[0] == '.') {
5975         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5976           PerlMem_free(trndir);
5977           PerlMem_free(vmsdir);
5978           return int_fileify_dirspec("[]", buf, NULL);
5979         }
5980         else if (trndir[1] == '.' &&
5981                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5982           PerlMem_free(trndir);
5983           PerlMem_free(vmsdir);
5984           return int_fileify_dirspec("[-]", buf, NULL);
5985         }
5986       }
5987       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5988         dirlen -= 1;                 /* to last element */
5989         lastdir = strrchr(trndir,'/');
5990       }
5991       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5992         /* If we have "/." or "/..", VMSify it and let the VMS code
5993          * below expand it, rather than repeating the code to handle
5994          * relative components of a filespec here */
5995         do {
5996           if (*(cp1+2) == '.') cp1++;
5997           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5998             char * ret_chr;
5999             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6000                 PerlMem_free(trndir);
6001                 PerlMem_free(vmsdir);
6002                 return NULL;
6003             }
6004             if (strchr(vmsdir,'/') != NULL) {
6005               /* If int_tovmsspec() returned it, it must have VMS syntax
6006                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6007                * the time to check this here only so we avoid a recursion
6008                * loop; otherwise, gigo.
6009                */
6010               PerlMem_free(trndir);
6011               PerlMem_free(vmsdir);
6012               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6013               return NULL;
6014             }
6015             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6016                 PerlMem_free(trndir);
6017                 PerlMem_free(vmsdir);
6018                 return NULL;
6019             }
6020             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6021             PerlMem_free(trndir);
6022             PerlMem_free(vmsdir);
6023             return ret_chr;
6024           }
6025           cp1++;
6026         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6027         lastdir = strrchr(trndir,'/');
6028       }
6029       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6030         char * ret_chr;
6031         /* Ditto for specs that end in an MFD -- let the VMS code
6032          * figure out whether it's a real device or a rooted logical. */
6033
6034         /* This should not happen any more.  Allowing the fake /000000
6035          * in a UNIX pathname causes all sorts of problems when trying
6036          * to run in UNIX emulation.  So the VMS to UNIX conversions
6037          * now remove the fake /000000 directories.
6038          */
6039
6040         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6041         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6042             PerlMem_free(trndir);
6043             PerlMem_free(vmsdir);
6044             return NULL;
6045         }
6046         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6047             PerlMem_free(trndir);
6048             PerlMem_free(vmsdir);
6049             return NULL;
6050         }
6051         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6052         PerlMem_free(trndir);
6053         PerlMem_free(vmsdir);
6054         return ret_chr;
6055       }
6056       else {
6057
6058         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6059              !(lastdir = cp1 = strrchr(trndir,']')) &&
6060              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6061
6062         cp2 = strrchr(cp1,'.');
6063         if (cp2) {
6064             int e_len, vs_len = 0;
6065             int is_dir = 0;
6066             char * cp3;
6067             cp3 = strchr(cp2,';');
6068             e_len = strlen(cp2);
6069             if (cp3) {
6070                 vs_len = strlen(cp3);
6071                 e_len = e_len - vs_len;
6072             }
6073             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6074             if (!is_dir) {
6075                 if (!decc_efs_charset) {
6076                     /* If this is not EFS, then not a directory */
6077                     PerlMem_free(trndir);
6078                     PerlMem_free(vmsdir);
6079                     set_errno(ENOTDIR);
6080                     set_vaxc_errno(RMS$_DIR);
6081                     return NULL;
6082                 }
6083             } else {
6084                 /* Ok, here we have an issue, technically if a .dir shows */
6085                 /* from inside a directory, then we should treat it as */
6086                 /* xxx^.dir.dir.  But we do not have that context at this */
6087                 /* point unless this is totally restructured, so we remove */
6088                 /* The .dir for now, and fix this better later */
6089                 dirlen = cp2 - trndir;
6090             }
6091             if (decc_efs_charset && !strchr(trndir,'/')) {
6092                 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6093                 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6094
6095                 for (; cp4 > cp1; cp4--) {
6096                     if (*cp4 == '.') {
6097                         if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6098                             memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6099                             *cp4 = '^';
6100                             dirlen++;
6101                         }
6102                     }
6103                 }
6104             }
6105         }
6106
6107       }
6108
6109       retlen = dirlen + 6;
6110       memcpy(buf, trndir, dirlen);
6111       buf[dirlen] = '\0';
6112
6113       /* We've picked up everything up to the directory file name.
6114          Now just add the type and version, and we're set. */
6115       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6116           strcat(buf,".dir;1");
6117       else
6118           strcat(buf,".DIR;1");
6119       PerlMem_free(trndir);
6120       PerlMem_free(vmsdir);
6121       return buf;
6122     }
6123     else {  /* VMS-style directory spec */
6124
6125       char *esa, *esal, term, *cp;
6126       char *my_esa;
6127       int my_esa_len;
6128       unsigned long int cmplen, haslower = 0;
6129       struct FAB dirfab = cc$rms_fab;
6130       rms_setup_nam(savnam);
6131       rms_setup_nam(dirnam);
6132
6133       esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
6134       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6135       esal = NULL;
6136 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6137       esal = (char *)PerlMem_malloc(VMS_MAXRSS);
6138       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6139 #endif
6140       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6141       rms_bind_fab_nam(dirfab, dirnam);
6142       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6143       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6144 #ifdef NAM$M_NO_SHORT_UPCASE
6145       if (decc_efs_case_preserve)
6146         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6147 #endif
6148
6149       for (cp = trndir; *cp; cp++)
6150         if (islower(*cp)) { haslower = 1; break; }
6151       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6152         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6153             (dirfab.fab$l_sts == RMS$_DNF) ||
6154             (dirfab.fab$l_sts == RMS$_PRV)) {
6155             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6156             sts = sys$parse(&dirfab);
6157         }
6158         if (!sts) {
6159           PerlMem_free(esa);
6160           if (esal != NULL)
6161               PerlMem_free(esal);
6162           PerlMem_free(trndir);
6163           PerlMem_free(vmsdir);
6164           set_errno(EVMSERR);
6165           set_vaxc_errno(dirfab.fab$l_sts);
6166           return NULL;
6167         }
6168       }
6169       else {
6170         savnam = dirnam;
6171         /* Does the file really exist? */
6172         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6173           /* Yes; fake the fnb bits so we'll check type below */
6174           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6175         }
6176         else { /* No; just work with potential name */
6177           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6178           else {
6179             int fab_sts;
6180             fab_sts = dirfab.fab$l_sts;
6181             sts = rms_free_search_context(&dirfab);
6182             PerlMem_free(esa);
6183             if (esal != NULL)
6184                 PerlMem_free(esal);
6185             PerlMem_free(trndir);
6186             PerlMem_free(vmsdir);
6187             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6188             return NULL;
6189           }
6190         }
6191       }
6192
6193       /* Make sure we are using the right buffer */
6194 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6195       if (esal != NULL) {
6196         my_esa = esal;
6197         my_esa_len = rms_nam_esll(dirnam);
6198       } else {
6199 #endif
6200         my_esa = esa;
6201         my_esa_len = rms_nam_esl(dirnam);
6202 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6203       }
6204 #endif
6205       my_esa[my_esa_len] = '\0';
6206       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6207         cp1 = strchr(my_esa,']');
6208         if (!cp1) cp1 = strchr(my_esa,'>');
6209         if (cp1) {  /* Should always be true */
6210           my_esa_len -= cp1 - my_esa - 1;
6211           memmove(my_esa, cp1 + 1, my_esa_len);
6212         }
6213       }
6214       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6215         /* Yep; check version while we're at it, if it's there. */
6216         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6217         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6218           /* Something other than .DIR[;1].  Bzzt. */
6219           sts = rms_free_search_context(&dirfab);
6220           PerlMem_free(esa);
6221           if (esal != NULL)
6222              PerlMem_free(esal);
6223           PerlMem_free(trndir);
6224           PerlMem_free(vmsdir);
6225           set_errno(ENOTDIR);
6226           set_vaxc_errno(RMS$_DIR);
6227           return NULL;
6228         }
6229       }
6230
6231       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6232         /* They provided at least the name; we added the type, if necessary, */
6233         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6234         sts = rms_free_search_context(&dirfab);
6235         PerlMem_free(trndir);
6236         PerlMem_free(esa);
6237         if (esal != NULL)
6238             PerlMem_free(esal);
6239         PerlMem_free(vmsdir);
6240         return buf;
6241       }
6242       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6243         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6244         *cp1 = '\0';
6245         my_esa_len -= 9;
6246       }
6247       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6248       if (cp1 == NULL) { /* should never happen */
6249         sts = rms_free_search_context(&dirfab);
6250         PerlMem_free(trndir);
6251         PerlMem_free(esa);
6252         if (esal != NULL)
6253             PerlMem_free(esal);
6254         PerlMem_free(vmsdir);
6255         return NULL;
6256       }
6257       term = *cp1;
6258       *cp1 = '\0';
6259       retlen = strlen(my_esa);
6260       cp1 = strrchr(my_esa,'.');
6261       /* ODS-5 directory specifications can have extra "." in them. */
6262       /* Fix-me, can not scan EFS file specifications backwards */
6263       while (cp1 != NULL) {
6264         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6265           break;
6266         else {
6267            cp1--;
6268            while ((cp1 > my_esa) && (*cp1 != '.'))
6269              cp1--;
6270         }
6271         if (cp1 == my_esa)
6272           cp1 = NULL;
6273       }
6274
6275       if ((cp1) != NULL) {
6276         /* There's more than one directory in the path.  Just roll back. */
6277         *cp1 = term;
6278         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6279       }
6280       else {
6281         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6282           /* Go back and expand rooted logical name */
6283           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6284 #ifdef NAM$M_NO_SHORT_UPCASE
6285           if (decc_efs_case_preserve)
6286             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6287 #endif
6288           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6289             sts = rms_free_search_context(&dirfab);
6290             PerlMem_free(esa);
6291             if (esal != NULL)
6292                 PerlMem_free(esal);
6293             PerlMem_free(trndir);
6294             PerlMem_free(vmsdir);
6295             set_errno(EVMSERR);
6296             set_vaxc_errno(dirfab.fab$l_sts);
6297             return NULL;
6298           }
6299
6300           /* This changes the length of the string of course */
6301           if (esal != NULL) {
6302               my_esa_len = rms_nam_esll(dirnam);
6303           } else {
6304               my_esa_len = rms_nam_esl(dirnam);
6305           }
6306
6307           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6308           cp1 = strstr(my_esa,"][");
6309           if (!cp1) cp1 = strstr(my_esa,"]<");
6310           dirlen = cp1 - my_esa;
6311           memcpy(buf, my_esa, dirlen);
6312           if (!strncmp(cp1+2,"000000]",7)) {
6313             buf[dirlen-1] = '\0';
6314             /* fix-me Not full ODS-5, just extra dots in directories for now */
6315             cp1 = buf + dirlen - 1;
6316             while (cp1 > buf)
6317             {
6318               if (*cp1 == '[')
6319                 break;
6320               if (*cp1 == '.') {
6321                 if (*(cp1-1) != '^')
6322                   break;
6323               }
6324               cp1--;
6325             }
6326             if (*cp1 == '.') *cp1 = ']';
6327             else {
6328               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6329               memmove(cp1+1,"000000]",7);
6330             }
6331           }
6332           else {
6333             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6334             buf[retlen] = '\0';
6335             /* Convert last '.' to ']' */
6336             cp1 = buf+retlen-1;
6337             while (*cp != '[') {
6338               cp1--;
6339               if (*cp1 == '.') {
6340                 /* Do not trip on extra dots in ODS-5 directories */
6341                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6342                 break;
6343               }
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         }
6352         else {  /* This is a top-level dir.  Add the MFD to the path. */
6353           cp1 = my_esa;
6354           cp2 = buf;
6355           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6356           strcpy(cp2,":[000000]");
6357           cp1 += 2;
6358           strcpy(cp2+9,cp1);
6359         }
6360       }
6361       sts = rms_free_search_context(&dirfab);
6362       /* We've set up the string up through the filename.  Add the
6363          type and version, and we're done. */
6364       strcat(buf,".DIR;1");
6365
6366       /* $PARSE may have upcased filespec, so convert output to lower
6367        * case if input contained any lowercase characters. */
6368       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6369       PerlMem_free(trndir);
6370       PerlMem_free(esa);
6371       if (esal != NULL)
6372         PerlMem_free(esal);
6373       PerlMem_free(vmsdir);
6374       return buf;
6375     }
6376 }  /* end of int_fileify_dirspec() */
6377
6378
6379 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6380 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6381 {
6382     static char __fileify_retbuf[VMS_MAXRSS];
6383     char * fileified, *ret_spec, *ret_buf;
6384
6385     fileified = NULL;
6386     ret_buf = buf;
6387     if (ret_buf == NULL) {
6388         if (ts) {
6389             Newx(fileified, VMS_MAXRSS, char);
6390             if (fileified == NULL)
6391                 _ckvmssts(SS$_INSFMEM);
6392             ret_buf = fileified;
6393         } else {
6394             ret_buf = __fileify_retbuf;
6395         }
6396     }
6397
6398     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6399
6400     if (ret_spec == NULL) {
6401        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6402        if (fileified)
6403            Safefree(fileified);
6404     }
6405
6406     return ret_spec;
6407 }  /* end of do_fileify_dirspec() */
6408 /*}}}*/
6409
6410 /* External entry points */
6411 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6412 { return do_fileify_dirspec(dir,buf,0,NULL); }
6413 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6414 { return do_fileify_dirspec(dir,buf,1,NULL); }
6415 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6416 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6417 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6418 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6419
6420 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6421     char * v_spec, int v_len, char * r_spec, int r_len,
6422     char * d_spec, int d_len, char * n_spec, int n_len,
6423     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6424
6425     /* VMS specification - Try to do this the simple way */
6426     if ((v_len + r_len > 0) || (d_len > 0)) {
6427         int is_dir;
6428
6429         /* No name or extension component, already a directory */
6430         if ((n_len + e_len + vs_len) == 0) {
6431             strcpy(buf, dir);
6432             return buf;
6433         }
6434
6435         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6436         /* This results from catfile() being used instead of catdir() */
6437         /* So even though it should not work, we need to allow it */
6438
6439         /* If this is .DIR;1 then do a simple conversion */
6440         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6441         if (is_dir || (e_len == 0) && (d_len > 0)) {
6442              int len;
6443              len = v_len + r_len + d_len - 1;
6444              char dclose = d_spec[d_len - 1];
6445              memcpy(buf, dir, len);
6446              buf[len] = '.';
6447              len++;
6448              memcpy(&buf[len], n_spec, n_len);
6449              len += n_len;
6450              buf[len] = dclose;
6451              buf[len + 1] = '\0';
6452              return buf;
6453         }
6454
6455 #ifdef HAS_SYMLINK
6456         else if (d_len > 0) {
6457             /* In the olden days, a directory needed to have a .DIR */
6458             /* extension to be a valid directory, but now it could  */
6459             /* be a symbolic link */
6460             int len;
6461             len = v_len + r_len + d_len - 1;
6462             char dclose = d_spec[d_len - 1];
6463             memcpy(buf, dir, len);
6464             buf[len] = '.';
6465             len++;
6466             memcpy(&buf[len], n_spec, n_len);
6467             len += n_len;
6468             if (e_len > 0) {
6469                 if (decc_efs_charset) {
6470                     if (e_len == 4
6471                         && (toupper(e_spec[1]) == 'D')
6472                         && (toupper(e_spec[2]) == 'I')
6473                         && (toupper(e_spec[3]) == 'R')) {
6474
6475                         /* Corner case: directory spec with invalid version.
6476                          * Valid would have followed is_dir path above.
6477                          */
6478                         SETERRNO(ENOTDIR, RMS$_DIR);
6479                         return NULL;
6480                     }
6481                     else {
6482                         buf[len] = '^';
6483                         len++;
6484                         memcpy(&buf[len], e_spec, e_len);
6485                         len += e_len;
6486                     }
6487                 }
6488                 else {
6489                     SETERRNO(ENOTDIR, RMS$_DIR);
6490                     return NULL;
6491                 }
6492             }
6493             buf[len] = dclose;
6494             buf[len + 1] = '\0';
6495             return buf;
6496         }
6497 #else
6498         else {
6499             set_vaxc_errno(RMS$_DIR);
6500             set_errno(ENOTDIR);
6501             return NULL;
6502         }
6503 #endif
6504     }
6505     set_vaxc_errno(RMS$_DIR);
6506     set_errno(ENOTDIR);
6507     return NULL;
6508 }
6509
6510
6511 /* Internal routine to make sure or convert a directory to be in a */
6512 /* path specification.  No utf8 flag because it is not changed or used */
6513 static char *int_pathify_dirspec(const char *dir, char *buf)
6514 {
6515     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6516     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6517     char * exp_spec, *ret_spec;
6518     char * trndir;
6519     unsigned short int trnlnm_iter_count;
6520     STRLEN trnlen;
6521     int need_to_lower;
6522
6523     if (vms_debug_fileify) {
6524         if (dir == NULL)
6525             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6526         else
6527             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6528     }
6529
6530     /* We may need to lower case the result if we translated  */
6531     /* a logical name or got the current working directory */
6532     need_to_lower = 0;
6533
6534     if (!dir || !*dir) {
6535       set_errno(EINVAL);
6536       set_vaxc_errno(SS$_BADPARAM);
6537       return NULL;
6538     }
6539
6540     trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
6541     if (trndir == NULL)
6542         _ckvmssts_noperl(SS$_INSFMEM);
6543
6544     /* If no directory specified use the current default */
6545     if (*dir)
6546         my_strlcpy(trndir, dir, VMS_MAXRSS);
6547     else {
6548         getcwd(trndir, VMS_MAXRSS - 1);
6549         need_to_lower = 1;
6550     }
6551
6552     /* now deal with bare names that could be logical names */
6553     trnlnm_iter_count = 0;
6554     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6555            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6556         trnlnm_iter_count++;
6557         need_to_lower = 1;
6558         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6559             break;
6560         trnlen = strlen(trndir);
6561
6562         /* Trap simple rooted lnms, and return lnm:[000000] */
6563         if (!strcmp(trndir+trnlen-2,".]")) {
6564             my_strlcpy(buf, dir, VMS_MAXRSS);
6565             strcat(buf, ":[000000]");
6566             PerlMem_free(trndir);
6567
6568             if (vms_debug_fileify) {
6569                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6570             }
6571             return buf;
6572         }
6573     }
6574
6575     /* At this point we do not work with *dir, but the copy in  *trndir */
6576
6577     if (need_to_lower && !decc_efs_case_preserve) {
6578         /* Legacy mode, lower case the returned value */
6579         __mystrtolower(trndir);
6580     }
6581
6582
6583     /* Some special cases, '..', '.' */
6584     sts = 0;
6585     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6586        /* Force UNIX filespec */
6587        sts = 1;
6588
6589     } else {
6590         /* Is this Unix or VMS format? */
6591         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6592                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6593                              &e_len, &vs_spec, &vs_len);
6594         if (sts == 0) {
6595
6596             /* Just a filename? */
6597             if ((v_len + r_len + d_len) == 0) {
6598
6599                 /* Now we have a problem, this could be Unix or VMS */
6600                 /* We have to guess.  .DIR usually means VMS */
6601
6602                 /* In UNIX report mode, the .DIR extension is removed */
6603                 /* if one shows up, it is for a non-directory or a directory */
6604                 /* in EFS charset mode */
6605
6606                 /* So if we are in Unix report mode, assume that this */
6607                 /* is a relative Unix directory specification */
6608
6609                 sts = 1;
6610                 if (!decc_filename_unix_report && decc_efs_charset) {
6611                     int is_dir;
6612                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6613
6614                     if (is_dir) {
6615                         /* Traditional mode, assume .DIR is directory */
6616                         buf[0] = '[';
6617                         buf[1] = '.';
6618                         memcpy(&buf[2], n_spec, n_len);
6619                         buf[n_len + 2] = ']';
6620                         buf[n_len + 3] = '\0';
6621                         PerlMem_free(trndir);
6622                         if (vms_debug_fileify) {
6623                             fprintf(stderr,
6624                                     "int_pathify_dirspec: buf = %s\n",
6625                                     buf);
6626                         }
6627                         return buf;
6628                     }
6629                 }
6630             }
6631         }
6632     }
6633     if (sts == 0) {
6634         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6635             v_spec, v_len, r_spec, r_len,
6636             d_spec, d_len, n_spec, n_len,
6637             e_spec, e_len, vs_spec, vs_len);
6638
6639         if (ret_spec != NULL) {
6640             PerlMem_free(trndir);
6641             if (vms_debug_fileify) {
6642                 fprintf(stderr,
6643                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6644             }
6645             return ret_spec;
6646         }
6647
6648         /* Simple way did not work, which means that a logical name */
6649         /* was present for the directory specification.             */
6650         /* Need to use an rmsexpand variant to decode it completely */
6651         exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
6652         if (exp_spec == NULL)
6653             _ckvmssts_noperl(SS$_INSFMEM);
6654
6655         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6656         if (ret_spec != NULL) {
6657             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6658                                  &r_spec, &r_len, &d_spec, &d_len,
6659                                  &n_spec, &n_len, &e_spec,
6660                                  &e_len, &vs_spec, &vs_len);
6661             if (sts == 0) {
6662                 ret_spec = int_pathify_dirspec_simple(
6663                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6664                     d_spec, d_len, n_spec, n_len,
6665                     e_spec, e_len, vs_spec, vs_len);
6666
6667                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6668                     /* Legacy mode, lower case the returned value */
6669                     __mystrtolower(ret_spec);
6670                 }
6671             } else {
6672                 set_vaxc_errno(RMS$_DIR);
6673                 set_errno(ENOTDIR);
6674                 ret_spec = NULL;
6675             }
6676         }
6677         PerlMem_free(exp_spec);
6678         PerlMem_free(trndir);
6679         if (vms_debug_fileify) {
6680             if (ret_spec == NULL)
6681                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6682             else
6683                 fprintf(stderr,
6684                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6685         }
6686         return ret_spec;
6687
6688     } else {
6689         /* Unix specification, Could be trivial conversion, */
6690         /* but have to deal with trailing '.dir' or extra '.' */
6691
6692         char * lastdot;
6693         char * lastslash;
6694         int is_dir;
6695         STRLEN dir_len = strlen(trndir);
6696
6697         lastslash = strrchr(trndir, '/');
6698         if (lastslash == NULL)
6699             lastslash = trndir;
6700         else
6701             lastslash++;
6702
6703         lastdot = NULL;
6704
6705         /* '..' or '.' are valid directory components */
6706         is_dir = 0;
6707         if (lastslash[0] == '.') {
6708             if (lastslash[1] == '\0') {
6709                is_dir = 1;
6710             } else if (lastslash[1] == '.') {
6711                 if (lastslash[2] == '\0') {
6712                     is_dir = 1;
6713                 } else {
6714                     /* And finally allow '...' */
6715                     if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6716                         is_dir = 1;
6717                     }
6718                 }
6719             }
6720         }
6721
6722         if (!is_dir) {
6723            lastdot = strrchr(lastslash, '.');
6724         }
6725         if (lastdot != NULL) {
6726             STRLEN e_len;
6727              /* '.dir' is discarded, and any other '.' is invalid */
6728             e_len = strlen(lastdot);
6729
6730             is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6731
6732             if (is_dir) {
6733                 dir_len = dir_len - 4;
6734             }
6735         }
6736
6737         my_strlcpy(buf, trndir, VMS_MAXRSS);
6738         if (buf[dir_len - 1] != '/') {
6739             buf[dir_len] = '/';
6740             buf[dir_len + 1] = '\0';
6741         }
6742
6743         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6744         if (!decc_efs_charset) {
6745              int dir_start = 0;
6746              char * str = buf;
6747              if (str[0] == '.') {
6748                  char * dots = str;
6749                  int cnt = 1;
6750                  while ((dots[cnt] == '.') && (cnt < 3))
6751                      cnt++;
6752                  if (cnt <= 3) {
6753                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6754                          dir_start = 1;
6755                          str += cnt;
6756                      }
6757                  }
6758              }
6759              for (; *str; ++str) {
6760                  while (*str == '/') {
6761                      dir_start = 1;
6762                      *str++;
6763                  }
6764                  if (dir_start) {
6765
6766                      /* Have to skip up to three dots which could be */
6767                      /* directories, 3 dots being a VMS extension for Perl */
6768                      char * dots = str;
6769                      int cnt = 0;
6770                      while ((dots[cnt] == '.') && (cnt < 3)) {
6771                          cnt++;
6772                      }
6773                      if (dots[cnt] == '\0')
6774                          break;
6775                      if ((cnt > 1) && (dots[cnt] != '/')) {
6776                          dir_start = 0;
6777                      } else {
6778                          str += cnt;
6779                      }
6780
6781                      /* too many dots? */
6782                      if ((cnt == 0) || (cnt > 3)) {
6783                          dir_start = 0;
6784                      }
6785                  }
6786                  if (!dir_start && (*str == '.')) {
6787                      *str = '_';
6788                  }
6789              }
6790         }
6791         PerlMem_free(trndir);
6792         ret_spec = buf;
6793         if (vms_debug_fileify) {
6794             if (ret_spec == NULL)
6795                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6796             else
6797                 fprintf(stderr,
6798                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6799         }
6800         return ret_spec;
6801     }
6802 }
6803
6804 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6805 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6806 {
6807     static char __pathify_retbuf[VMS_MAXRSS];
6808     char * pathified, *ret_spec, *ret_buf;
6809
6810     pathified = NULL;
6811     ret_buf = buf;
6812     if (ret_buf == NULL) {
6813         if (ts) {
6814             Newx(pathified, VMS_MAXRSS, char);
6815             if (pathified == NULL)
6816                 _ckvmssts(SS$_INSFMEM);
6817             ret_buf = pathified;
6818         } else {
6819             ret_buf = __pathify_retbuf;
6820         }
6821     }
6822
6823     ret_spec = int_pathify_dirspec(dir, ret_buf);
6824
6825     if (ret_spec == NULL) {
6826        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6827        if (pathified)
6828            Safefree(pathified);
6829     }
6830
6831     return ret_spec;
6832
6833 }  /* end of do_pathify_dirspec() */
6834
6835
6836 /* External entry points */
6837 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6838 { return do_pathify_dirspec(dir,buf,0,NULL); }
6839 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6840 { return do_pathify_dirspec(dir,buf,1,NULL); }
6841 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6842 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6843 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6844 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6845
6846 /* Internal tounixspec routine that does not use a thread context */
6847 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6848 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6849 {
6850   char *dirend, *cp1, *cp3, *tmp;
6851   const char *cp2;
6852   int dirlen;
6853   unsigned short int trnlnm_iter_count;
6854   int cmp_rslt;
6855   if (utf8_fl != NULL)
6856     *utf8_fl = 0;
6857
6858   if (vms_debug_fileify) {
6859       if (spec == NULL)
6860           fprintf(stderr, "int_tounixspec: spec = NULL\n");
6861       else
6862           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6863   }
6864
6865
6866   if (spec == NULL) {
6867       set_errno(EINVAL);
6868       set_vaxc_errno(SS$_BADPARAM);
6869       return NULL;
6870   }
6871   if (strlen(spec) > (VMS_MAXRSS-1)) {
6872       set_errno(E2BIG);
6873       set_vaxc_errno(SS$_BUFFEROVF);
6874       return NULL;
6875   }
6876
6877   /* New VMS specific format needs translation
6878    * glob passes filenames with trailing '\n' and expects this preserved.
6879    */
6880   if (decc_posix_compliant_pathnames) {
6881     if (strncmp(spec, "\"^UP^", 5) == 0) {
6882       char * uspec;
6883       char *tunix;
6884       int tunix_len;
6885       int nl_flag;
6886
6887       tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
6888       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6889       tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
6890       nl_flag = 0;
6891       if (tunix[tunix_len - 1] == '\n') {
6892         tunix[tunix_len - 1] = '\"';
6893         tunix[tunix_len] = '\0';
6894         tunix_len--;
6895         nl_flag = 1;
6896       }
6897       uspec = decc$translate_vms(tunix);
6898       PerlMem_free(tunix);
6899       if ((int)uspec > 0) {
6900         my_strlcpy(rslt, uspec, VMS_MAXRSS);
6901         if (nl_flag) {
6902           strcat(rslt,"\n");
6903         }
6904         else {
6905           /* If we can not translate it, makemaker wants as-is */
6906           my_strlcpy(rslt, spec, VMS_MAXRSS);
6907         }
6908         return rslt;
6909       }
6910     }
6911   }
6912
6913   cmp_rslt = 0; /* Presume VMS */
6914   cp1 = strchr(spec, '/');
6915   if (cp1 == NULL)
6916     cmp_rslt = 0;
6917
6918     /* Look for EFS ^/ */
6919     if (decc_efs_charset) {
6920       while (cp1 != NULL) {
6921         cp2 = cp1 - 1;
6922         if (*cp2 != '^') {
6923           /* Found illegal VMS, assume UNIX */
6924           cmp_rslt = 1;
6925           break;
6926         }
6927       cp1++;
6928       cp1 = strchr(cp1, '/');
6929     }
6930   }
6931
6932   /* Look for "." and ".." */
6933   if (decc_filename_unix_report) {
6934     if (spec[0] == '.') {
6935       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6936         cmp_rslt = 1;
6937       }
6938       else {
6939         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6940           cmp_rslt = 1;
6941         }
6942       }
6943     }
6944   }
6945   /* This is already UNIX or at least nothing VMS understands */
6946   if (cmp_rslt) {
6947     my_strlcpy(rslt, spec, VMS_MAXRSS);
6948     if (vms_debug_fileify) {
6949         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6950     }
6951     return rslt;
6952   }
6953
6954   cp1 = rslt;
6955   cp2 = spec;
6956   dirend = strrchr(spec,']');
6957   if (dirend == NULL) dirend = strrchr(spec,'>');
6958   if (dirend == NULL) dirend = strchr(spec,':');
6959   if (dirend == NULL) {
6960     strcpy(rslt,spec);
6961     if (vms_debug_fileify) {
6962         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6963     }
6964     return rslt;
6965   }
6966
6967   /* Special case 1 - sys$posix_root = / */
6968   if (!decc_disable_posix_root) {
6969     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6970       *cp1 = '/';
6971       cp1++;
6972       cp2 = cp2 + 15;
6973       }
6974   }
6975
6976   /* Special case 2 - Convert NLA0: to /dev/null */
6977   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6978   if (cmp_rslt == 0) {
6979     strcpy(rslt, "/dev/null");
6980     cp1 = cp1 + 9;
6981     cp2 = cp2 + 5;
6982     if (spec[6] != '\0') {
6983       cp1[9] = '/';
6984       cp1++;
6985       cp2++;
6986     }
6987   }
6988
6989    /* Also handle special case "SYS$SCRATCH:" */
6990   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6991   tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
6992   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6993   if (cmp_rslt == 0) {
6994   int islnm;
6995
6996     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
6997     if (!islnm) {
6998       strcpy(rslt, "/tmp");
6999       cp1 = cp1 + 4;
7000       cp2 = cp2 + 12;
7001       if (spec[12] != '\0') {
7002         cp1[4] = '/';
7003         cp1++;
7004         cp2++;
7005       }
7006     }
7007   }
7008
7009   if (*cp2 != '[' && *cp2 != '<') {
7010     *(cp1++) = '/';
7011   }
7012   else {  /* the VMS spec begins with directories */
7013     cp2++;
7014     if (*cp2 == ']' || *cp2 == '>') {
7015       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7016       PerlMem_free(tmp);
7017       return rslt;
7018     }
7019     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7020       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7021         PerlMem_free(tmp);
7022         if (vms_debug_fileify) {
7023             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7024         }
7025         return NULL;
7026       }
7027       trnlnm_iter_count = 0;
7028       do {
7029         cp3 = tmp;
7030         while (*cp3 != ':' && *cp3) cp3++;
7031         *(cp3++) = '\0';
7032         if (strchr(cp3,']') != NULL) break;
7033         trnlnm_iter_count++;
7034         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7035       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7036       cp1 = rslt;
7037       cp3 = tmp;
7038       *(cp1++) = '/';
7039       while (*cp3) {
7040         *(cp1++) = *(cp3++);
7041         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7042             PerlMem_free(tmp);
7043             set_errno(ENAMETOOLONG);
7044             set_vaxc_errno(SS$_BUFFEROVF);
7045             if (vms_debug_fileify) {
7046                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7047             }
7048             return NULL; /* No room */
7049         }
7050       }
7051       *(cp1++) = '/';
7052     }
7053     if ((*cp2 == '^')) {
7054         /* EFS file escape, pass the next character as is */
7055         /* Fix me: HEX encoding for Unicode not implemented */
7056         cp2++;
7057     }
7058     else if ( *cp2 == '.') {
7059       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7060         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7061         cp2 += 3;
7062       }
7063       else cp2++;
7064     }
7065   }
7066   PerlMem_free(tmp);
7067   for (; cp2 <= dirend; cp2++) {
7068     if ((*cp2 == '^')) {
7069         /* EFS file escape, pass the next character as is */
7070         /* Fix me: HEX encoding for Unicode not implemented */
7071         *(cp1++) = *(++cp2);
7072         /* An escaped dot stays as is -- don't convert to slash */
7073         if (*cp2 == '.') cp2++;
7074     }
7075     if (*cp2 == ':') {
7076       *(cp1++) = '/';
7077       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7078     }
7079     else if (*cp2 == ']' || *cp2 == '>') {
7080       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7081     }
7082     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7083       *(cp1++) = '/';
7084       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7085         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7086                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7087         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7088             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7089       }
7090       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7091         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7092         cp2 += 2;
7093       }
7094     }
7095     else if (*cp2 == '-') {
7096       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7097         while (*cp2 == '-') {
7098           cp2++;
7099           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7100         }
7101         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7102                                                          /* filespecs like */
7103           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7104           if (vms_debug_fileify) {
7105               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7106           }
7107           return NULL;
7108         }
7109       }
7110       else *(cp1++) = *cp2;
7111     }
7112     else *(cp1++) = *cp2;
7113   }
7114   /* Translate the rest of the filename. */
7115   while (*cp2) {
7116       int dot_seen;
7117       dot_seen = 0;
7118       switch(*cp2) {
7119       /* Fixme - for compatibility with the CRTL we should be removing */
7120       /* spaces from the file specifications, but this may show that */
7121       /* some tests that were appearing to pass are not really passing */
7122       case '%':
7123           cp2++;
7124           *(cp1++) = '?';
7125           break;
7126       case '^':
7127           /* Fix me hex expansions not implemented */
7128           cp2++;  /* '^.' --> '.' and other. */
7129           if (*cp2) {
7130               if (*cp2 == '_') {
7131                   cp2++;
7132                   *(cp1++) = ' ';
7133               } else {
7134                   *(cp1++) = *(cp2++);
7135               }
7136           }
7137           break;
7138       case ';':
7139           if (decc_filename_unix_no_version) {
7140               /* Easy, drop the version */
7141               while (*cp2)
7142                   cp2++;
7143               break;
7144           } else {
7145               /* Punt - passing the version as a dot will probably */
7146               /* break perl in weird ways, but so did passing */
7147               /* through the ; as a version.  Follow the CRTL and */
7148               /* hope for the best. */
7149               cp2++;
7150               *(cp1++) = '.';
7151           }
7152           break;
7153       case '.':
7154           if (dot_seen) {
7155               /* We will need to fix this properly later */
7156               /* As Perl may be installed on an ODS-5 volume, but not */
7157               /* have the EFS_CHARSET enabled, it still may encounter */
7158               /* filenames with extra dots in them, and a precedent got */
7159               /* set which allowed them to work, that we will uphold here */
7160               /* If extra dots are present in a name and no ^ is on them */
7161               /* VMS assumes that the first one is the extension delimiter */
7162               /* the rest have an implied ^. */
7163
7164               /* this is also a conflict as the . is also a version */
7165               /* delimiter in VMS, */
7166
7167               *(cp1++) = *(cp2++);
7168               break;
7169           }
7170           dot_seen = 1;
7171           /* This is an extension */
7172           if (decc_readdir_dropdotnotype) {
7173               cp2++;
7174               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7175                   /* Drop the dot for the extension */
7176                   break;
7177               } else {
7178                   *(cp1++) = '.';
7179               }
7180               break;
7181           }
7182       default:
7183           *(cp1++) = *(cp2++);
7184       }
7185   }
7186   *cp1 = '\0';
7187
7188   /* This still leaves /000000/ when working with a
7189    * VMS device root or concealed root.
7190    */
7191   {
7192   int ulen;
7193   char * zeros;
7194
7195       ulen = strlen(rslt);
7196
7197       /* Get rid of "000000/ in rooted filespecs */
7198       if (ulen > 7) {
7199         zeros = strstr(rslt, "/000000/");
7200         if (zeros != NULL) {
7201           int mlen;
7202           mlen = ulen - (zeros - rslt) - 7;
7203           memmove(zeros, &zeros[7], mlen);
7204           ulen = ulen - 7;
7205           rslt[ulen] = '\0';
7206         }
7207       }
7208   }
7209
7210   if (vms_debug_fileify) {
7211       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7212   }
7213   return rslt;
7214
7215 }  /* end of int_tounixspec() */
7216
7217
7218 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7219 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7220 {
7221     static char __tounixspec_retbuf[VMS_MAXRSS];
7222     char * unixspec, *ret_spec, *ret_buf;
7223
7224     unixspec = NULL;
7225     ret_buf = buf;
7226     if (ret_buf == NULL) {
7227         if (ts) {
7228             Newx(unixspec, VMS_MAXRSS, char);
7229             if (unixspec == NULL)
7230                 _ckvmssts(SS$_INSFMEM);
7231             ret_buf = unixspec;
7232         } else {
7233             ret_buf = __tounixspec_retbuf;
7234         }
7235     }
7236
7237     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7238
7239     if (ret_spec == NULL) {
7240        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7241        if (unixspec)
7242            Safefree(unixspec);
7243     }
7244
7245     return ret_spec;
7246
7247 }  /* end of do_tounixspec() */
7248 /*}}}*/
7249 /* External entry points */
7250 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7251   { return do_tounixspec(spec,buf,0, NULL); }
7252 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7253   { return do_tounixspec(spec,buf,1, NULL); }
7254 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7255   { return do_tounixspec(spec,buf,0, utf8_fl); }
7256 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7257   { return do_tounixspec(spec,buf,1, utf8_fl); }
7258
7259 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7260
7261 /*
7262  This procedure is used to identify if a path is based in either
7263  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7264  it returns the OpenVMS format directory for it.
7265
7266  It is expecting specifications of only '/' or '/xxxx/'
7267
7268  If a posix root does not exist, or 'xxxx' is not a directory
7269  in the posix root, it returns a failure.
7270
7271  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7272
7273  It is used only internally by posix_to_vmsspec_hardway().
7274  */
7275
7276 static int posix_root_to_vms
7277   (char *vmspath, int vmspath_len,
7278    const char *unixpath,
7279    const int * utf8_fl)
7280 {
7281 int sts;
7282 struct FAB myfab = cc$rms_fab;
7283 rms_setup_nam(mynam);
7284 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7285 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7286 char * esa, * esal, * rsa, * rsal;
7287 int dir_flag;
7288 int unixlen;
7289
7290     dir_flag = 0;
7291     vmspath[0] = '\0';
7292     unixlen = strlen(unixpath);
7293     if (unixlen == 0) {
7294       return RMS$_FNF;
7295     }
7296
7297 #if __CRTL_VER >= 80200000
7298   /* If not a posix spec already, convert it */
7299   if (decc_posix_compliant_pathnames) {
7300     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7301       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7302     }
7303     else {
7304       /* This is already a VMS specification, no conversion */
7305       unixlen--;
7306       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7307     }
7308   }
7309   else
7310 #endif
7311   {
7312   int path_len;
7313   int i,j;
7314
7315      /* Check to see if this is under the POSIX root */
7316      if (decc_disable_posix_root) {
7317         return RMS$_FNF;
7318      }
7319
7320      /* Skip leading / */
7321      if (unixpath[0] == '/') {
7322         unixpath++;
7323         unixlen--;
7324      }
7325
7326
7327      strcpy(vmspath,"SYS$POSIX_ROOT:");
7328
7329      /* If this is only the / , or blank, then... */
7330      if (unixpath[0] == '\0') {
7331         /* by definition, this is the answer */
7332         return SS$_NORMAL;
7333      }
7334
7335      /* Need to look up a directory */
7336      vmspath[15] = '[';
7337      vmspath[16] = '\0';
7338
7339      /* Copy and add '^' escape characters as needed */
7340      j = 16;
7341      i = 0;
7342      while (unixpath[i] != 0) {
7343      int k;
7344
7345         j += copy_expand_unix_filename_escape
7346             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7347         i += k;
7348      }
7349
7350      path_len = strlen(vmspath);
7351      if (vmspath[path_len - 1] == '/')
7352         path_len--;
7353      vmspath[path_len] = ']';
7354      path_len++;
7355      vmspath[path_len] = '\0';
7356
7357   }
7358   vmspath[vmspath_len] = 0;
7359   if (unixpath[unixlen - 1] == '/')
7360   dir_flag = 1;
7361   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7362   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7363   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7364   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7365   rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7366   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7367   rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7368   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7369   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7370   rms_bind_fab_nam(myfab, mynam);
7371   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7372   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7373   if (decc_efs_case_preserve)
7374     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7375 #ifdef NAML$M_OPEN_SPECIAL
7376   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7377 #endif
7378
7379   /* Set up the remaining naml fields */
7380   sts = sys$parse(&myfab);
7381
7382   /* It failed! Try again as a UNIX filespec */
7383   if (!(sts & 1)) {
7384     PerlMem_free(esal);
7385     PerlMem_free(esa);
7386     PerlMem_free(rsal);
7387     PerlMem_free(rsa);
7388     return sts;
7389   }
7390
7391    /* get the Device ID and the FID */
7392    sts = sys$search(&myfab);
7393
7394    /* These are no longer needed */
7395    PerlMem_free(esa);
7396    PerlMem_free(rsal);
7397    PerlMem_free(rsa);
7398
7399    /* on any failure, returned the POSIX ^UP^ filespec */
7400    if (!(sts & 1)) {
7401       PerlMem_free(esal);
7402       return sts;
7403    }
7404    specdsc.dsc$a_pointer = vmspath;
7405    specdsc.dsc$w_length = vmspath_len;
7406
7407    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7408    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7409    sts = lib$fid_to_name
7410       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7411
7412   /* on any failure, returned the POSIX ^UP^ filespec */
7413   if (!(sts & 1)) {
7414      /* This can happen if user does not have permission to read directories */
7415      if (strncmp(unixpath,"\"^UP^",5) != 0)
7416        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7417      else
7418        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7419   }
7420   else {
7421     vmspath[specdsc.dsc$w_length] = 0;
7422
7423     /* Are we expecting a directory? */
7424     if (dir_flag != 0) {
7425     int i;
7426     char *eptr;
7427
7428       eptr = NULL;
7429
7430       i = specdsc.dsc$w_length - 1;
7431       while (i > 0) {
7432       int zercnt;
7433         zercnt = 0;
7434         /* Version must be '1' */
7435         if (vmspath[i--] != '1')
7436           break;
7437         /* Version delimiter is one of ".;" */
7438         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7439           break;
7440         i--;
7441         if (vmspath[i--] != 'R')
7442           break;
7443         if (vmspath[i--] != 'I')
7444           break;
7445         if (vmspath[i--] != 'D')
7446           break;
7447         if (vmspath[i--] != '.')
7448           break;
7449         eptr = &vmspath[i+1];
7450         while (i > 0) {
7451           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7452             if (vmspath[i-1] != '^') {
7453               if (zercnt != 6) {
7454                 *eptr = vmspath[i];
7455                 eptr[1] = '\0';
7456                 vmspath[i] = '.';
7457                 break;
7458               }
7459               else {
7460                 /* Get rid of 6 imaginary zero directory filename */
7461                 vmspath[i+1] = '\0';
7462               }
7463             }
7464           }
7465           if (vmspath[i] == '0')
7466             zercnt++;
7467           else
7468             zercnt = 10;
7469           i--;
7470         }
7471         break;
7472       }
7473     }
7474   }
7475   PerlMem_free(esal);
7476   return sts;
7477 }
7478
7479 /* /dev/mumble needs to be handled special.
7480    /dev/null becomes NLA0:, And there is the potential for other stuff
7481    like /dev/tty which may need to be mapped to something.
7482 */
7483
7484 static int
7485 slash_dev_special_to_vms
7486    (const char * unixptr,
7487     char * vmspath,
7488     int vmspath_len)
7489 {
7490 char * nextslash;
7491 int len;
7492 int cmp;
7493
7494     unixptr += 4;
7495     nextslash = strchr(unixptr, '/');
7496     len = strlen(unixptr);
7497     if (nextslash != NULL)
7498         len = nextslash - unixptr;
7499     cmp = strncmp("null", unixptr, 5);
7500     if (cmp == 0) {
7501         if (vmspath_len >= 6) {
7502             strcpy(vmspath, "_NLA0:");
7503             return SS$_NORMAL;
7504         }
7505     }
7506     return 0;
7507 }
7508
7509
7510 /* The built in routines do not understand perl's special needs, so
7511     doing a manual conversion from UNIX to VMS
7512
7513     If the utf8_fl is not null and points to a non-zero value, then
7514     treat 8 bit characters as UTF-8.
7515
7516     The sequence starting with '$(' and ending with ')' will be passed
7517     through with out interpretation instead of being escaped.
7518
7519   */
7520 static int posix_to_vmsspec_hardway
7521   (char *vmspath, int vmspath_len,
7522    const char *unixpath,
7523    int dir_flag,
7524    int * utf8_fl) {
7525
7526 char *esa;
7527 const char *unixptr;
7528 const char *unixend;
7529 char *vmsptr;
7530 const char *lastslash;
7531 const char *lastdot;
7532 int unixlen;
7533 int vmslen;
7534 int dir_start;
7535 int dir_dot;
7536 int quoted;
7537 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7538 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7539
7540   if (utf8_fl != NULL)
7541     *utf8_fl = 0;
7542
7543   unixptr = unixpath;
7544   dir_dot = 0;
7545
7546   /* Ignore leading "/" characters */
7547   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7548     unixptr++;
7549   }
7550   unixlen = strlen(unixptr);
7551
7552   /* Do nothing with blank paths */
7553   if (unixlen == 0) {
7554     vmspath[0] = '\0';
7555     return SS$_NORMAL;
7556   }
7557
7558   quoted = 0;
7559   /* This could have a "^UP^ on the front */
7560   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7561     quoted = 1;
7562     unixptr+= 5;
7563     unixlen-= 5;
7564   }
7565
7566   lastslash = strrchr(unixptr,'/');
7567   lastdot = strrchr(unixptr,'.');
7568   unixend = strrchr(unixptr,'\"');
7569   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7570     unixend = unixptr + unixlen;
7571   }
7572
7573   /* last dot is last dot or past end of string */
7574   if (lastdot == NULL)
7575     lastdot = unixptr + unixlen;
7576
7577   /* if no directories, set last slash to beginning of string */
7578   if (lastslash == NULL) {
7579     lastslash = unixptr;
7580   }
7581   else {
7582     /* Watch out for trailing "." after last slash, still a directory */
7583     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7584       lastslash = unixptr + unixlen;
7585     }
7586
7587     /* Watch out for trailing ".." after last slash, still a directory */
7588     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7589       lastslash = unixptr + unixlen;
7590     }
7591
7592     /* dots in directories are aways escaped */
7593     if (lastdot < lastslash)
7594       lastdot = unixptr + unixlen;
7595   }
7596
7597   /* if (unixptr < lastslash) then we are in a directory */
7598
7599   dir_start = 0;
7600
7601   vmsptr = vmspath;
7602   vmslen = 0;
7603
7604   /* Start with the UNIX path */
7605   if (*unixptr != '/') {
7606     /* relative paths */
7607
7608     /* If allowing logical names on relative pathnames, then handle here */
7609     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7610         !decc_posix_compliant_pathnames) {
7611     char * nextslash;
7612     int seg_len;
7613     char * trn;
7614     int islnm;
7615
7616         /* Find the next slash */
7617         nextslash = strchr(unixptr,'/');
7618
7619         esa = (char *)PerlMem_malloc(vmspath_len);
7620         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7621
7622         trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7623         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7624
7625         if (nextslash != NULL) {
7626
7627             seg_len = nextslash - unixptr;
7628             memcpy(esa, unixptr, seg_len);
7629             esa[seg_len] = 0;
7630         }
7631         else {
7632             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7633         }
7634         /* trnlnm(section) */
7635         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7636
7637         if (islnm) {
7638             /* Now fix up the directory */
7639
7640             /* Split up the path to find the components */
7641             sts = vms_split_path
7642                   (trn,
7643                    &v_spec,
7644                    &v_len,
7645                    &r_spec,
7646                    &r_len,
7647                    &d_spec,
7648                    &d_len,
7649                    &n_spec,
7650                    &n_len,
7651                    &e_spec,
7652                    &e_len,
7653                    &vs_spec,
7654                    &vs_len);
7655
7656             while (sts == 0) {
7657             int cmp;
7658
7659                 /* A logical name must be a directory  or the full
7660                    specification.  It is only a full specification if
7661                    it is the only component */
7662                 if ((unixptr[seg_len] == '\0') ||
7663                     (unixptr[seg_len+1] == '\0')) {
7664
7665                     /* Is a directory being required? */
7666                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7667                         /* Not a logical name */
7668                         break;
7669                     }
7670
7671
7672                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7673                         /* This must be a directory */
7674                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7675                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7676                             vmsptr[vmslen] = ':';
7677                             vmslen++;
7678                             vmsptr[vmslen] = '\0';
7679                             return SS$_NORMAL;
7680                         }
7681                     }
7682
7683                 }
7684
7685
7686                 /* must be dev/directory - ignore version */
7687                 if ((n_len + e_len) != 0)
7688                     break;
7689
7690                 /* transfer the volume */
7691                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7692                     memcpy(vmsptr, v_spec, v_len);
7693                     vmsptr += v_len;
7694                     vmsptr[0] = '\0';
7695                     vmslen += v_len;
7696                 }
7697
7698                 /* unroot the rooted directory */
7699                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7700                     r_spec[0] = '[';
7701                     r_spec[r_len - 1] = ']';
7702
7703                     /* This should not be there, but nothing is perfect */
7704                     if (r_len > 9) {
7705                         cmp = strcmp(&r_spec[1], "000000.");
7706                         if (cmp == 0) {
7707                             r_spec += 7;
7708                             r_spec[7] = '[';
7709                             r_len -= 7;
7710                             if (r_len == 2)
7711                                 r_len = 0;
7712                         }
7713                     }
7714                     if (r_len > 0) {
7715                         memcpy(vmsptr, r_spec, r_len);
7716                         vmsptr += r_len;
7717                         vmslen += r_len;
7718                         vmsptr[0] = '\0';
7719                     }
7720                 }
7721                 /* Bring over the directory. */
7722                 if ((d_len > 0) &&
7723                     ((d_len + vmslen) < vmspath_len)) {
7724                     d_spec[0] = '[';
7725                     d_spec[d_len - 1] = ']';
7726                     if (d_len > 9) {
7727                         cmp = strcmp(&d_spec[1], "000000.");
7728                         if (cmp == 0) {
7729                             d_spec += 7;
7730                             d_spec[7] = '[';
7731                             d_len -= 7;
7732                             if (d_len == 2)
7733                                 d_len = 0;
7734                         }
7735                     }
7736
7737                     if (r_len > 0) {
7738                         /* Remove the redundant root */
7739                         if (r_len > 0) {
7740                             /* remove the ][ */
7741                             vmsptr--;
7742                             vmslen--;
7743                             d_spec++;
7744                             d_len--;
7745                         }
7746                         memcpy(vmsptr, d_spec, d_len);
7747                             vmsptr += d_len;
7748                             vmslen += d_len;
7749                             vmsptr[0] = '\0';
7750                     }
7751                 }
7752                 break;
7753             }
7754         }
7755
7756         PerlMem_free(esa);
7757         PerlMem_free(trn);
7758     }
7759
7760     if (lastslash > unixptr) {
7761     int dotdir_seen;
7762
7763       /* skip leading ./ */
7764       dotdir_seen = 0;
7765       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7766         dotdir_seen = 1;
7767         unixptr++;
7768         unixptr++;
7769       }
7770
7771       /* Are we still in a directory? */
7772       if (unixptr <= lastslash) {
7773         *vmsptr++ = '[';
7774         vmslen = 1;
7775         dir_start = 1;
7776
7777         /* if not backing up, then it is relative forward. */
7778         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7779               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7780           *vmsptr++ = '.';
7781           vmslen++;
7782           dir_dot = 1;
7783           }
7784        }
7785        else {
7786          if (dotdir_seen) {
7787            /* Perl wants an empty directory here to tell the difference
7788             * between a DCL command and a filename
7789             */
7790           *vmsptr++ = '[';
7791           *vmsptr++ = ']';
7792           vmslen = 2;
7793         }
7794       }
7795     }
7796     else {
7797       /* Handle two special files . and .. */
7798       if (unixptr[0] == '.') {
7799         if (&unixptr[1] == unixend) {
7800           *vmsptr++ = '[';
7801           *vmsptr++ = ']';
7802           vmslen += 2;
7803           *vmsptr++ = '\0';
7804           return SS$_NORMAL;
7805         }
7806         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7807           *vmsptr++ = '[';
7808           *vmsptr++ = '-';
7809           *vmsptr++ = ']';
7810           vmslen += 3;
7811           *vmsptr++ = '\0';
7812           return SS$_NORMAL;
7813         }
7814       }
7815     }
7816   }
7817   else {        /* Absolute PATH handling */
7818   int sts;
7819   char * nextslash;
7820   int seg_len;
7821     /* Need to find out where root is */
7822
7823     /* In theory, this procedure should never get an absolute POSIX pathname
7824      * that can not be found on the POSIX root.
7825      * In practice, that can not be relied on, and things will show up
7826      * here that are a VMS device name or concealed logical name instead.
7827      * So to make things work, this procedure must be tolerant.
7828      */
7829     esa = (char *)PerlMem_malloc(vmspath_len);
7830     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7831
7832     sts = SS$_NORMAL;
7833     nextslash = strchr(&unixptr[1],'/');
7834     seg_len = 0;
7835     if (nextslash != NULL) {
7836       int cmp;
7837       seg_len = nextslash - &unixptr[1];
7838       my_strlcpy(vmspath, unixptr, seg_len + 2);
7839       cmp = 1;
7840       if (seg_len == 3) {
7841         cmp = strncmp(vmspath, "dev", 4);
7842         if (cmp == 0) {
7843             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7844             if (sts == SS$_NORMAL)
7845                 return SS$_NORMAL;
7846         }
7847       }
7848       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7849     }
7850
7851     if ($VMS_STATUS_SUCCESS(sts)) {
7852       /* This is verified to be a real path */
7853
7854       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7855       if ($VMS_STATUS_SUCCESS(sts)) {
7856         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
7857         vmsptr = vmspath + vmslen;
7858         unixptr++;
7859         if (unixptr < lastslash) {
7860         char * rptr;
7861           vmsptr--;
7862           *vmsptr++ = '.';
7863           dir_start = 1;
7864           dir_dot = 1;
7865           if (vmslen > 7) {
7866           int cmp;
7867             rptr = vmsptr - 7;
7868             cmp = strcmp(rptr,"000000.");
7869             if (cmp == 0) {
7870               vmslen -= 7;
7871               vmsptr -= 7;
7872               vmsptr[1] = '\0';
7873             } /* removing 6 zeros */
7874           } /* vmslen < 7, no 6 zeros possible */
7875         } /* Not in a directory */
7876       } /* Posix root found */
7877       else {
7878         /* No posix root, fall back to default directory */
7879         strcpy(vmspath, "SYS$DISK:[");
7880         vmsptr = &vmspath[10];
7881         vmslen = 10;
7882         if (unixptr > lastslash) {
7883            *vmsptr = ']';
7884            vmsptr++;
7885            vmslen++;
7886         }
7887         else {
7888            dir_start = 1;
7889         }
7890       }
7891     } /* end of verified real path handling */
7892     else {
7893     int add_6zero;
7894     int islnm;
7895
7896       /* Ok, we have a device or a concealed root that is not in POSIX
7897        * or we have garbage.  Make the best of it.
7898        */
7899
7900       /* Posix to VMS destroyed this, so copy it again */
7901       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
7902       vmslen = strlen(vmspath); /* We know we're truncating. */
7903       vmsptr = &vmsptr[vmslen];
7904       islnm = 0;
7905
7906       /* Now do we need to add the fake 6 zero directory to it? */
7907       add_6zero = 1;
7908       if ((*lastslash == '/') && (nextslash < lastslash)) {
7909         /* No there is another directory */
7910         add_6zero = 0;
7911       }
7912       else {
7913       int trnend;
7914       int cmp;
7915
7916         /* now we have foo:bar or foo:[000000]bar to decide from */
7917         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7918
7919         if (!islnm && !decc_posix_compliant_pathnames) {
7920
7921             cmp = strncmp("bin", vmspath, 4);
7922             if (cmp == 0) {
7923                 /* bin => SYS$SYSTEM: */
7924                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7925             }
7926             else {
7927                 /* tmp => SYS$SCRATCH: */
7928                 cmp = strncmp("tmp", vmspath, 4);
7929                 if (cmp == 0) {
7930                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7931                 }
7932             }
7933         }
7934
7935         trnend = islnm ? islnm - 1 : 0;
7936
7937         /* if this was a logical name, ']' or '>' must be present */
7938         /* if not a logical name, then assume a device and hope. */
7939         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7940
7941         /* if log name and trailing '.' then rooted - treat as device */
7942         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7943
7944         /* Fix me, if not a logical name, a device lookup should be
7945          * done to see if the device is file structured.  If the device
7946          * is not file structured, the 6 zeros should not be put on.
7947          *
7948          * As it is, perl is occasionally looking for dev:[000000]tty.
7949          * which looks a little strange.
7950          *
7951          * Not that easy to detect as "/dev" may be file structured with
7952          * special device files.
7953          */
7954
7955         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
7956             (&nextslash[1] == unixend)) {
7957           /* No real directory present */
7958           add_6zero = 1;
7959         }
7960       }
7961
7962       /* Put the device delimiter on */
7963       *vmsptr++ = ':';
7964       vmslen++;
7965       unixptr = nextslash;
7966       unixptr++;
7967
7968       /* Start directory if needed */
7969       if (!islnm || add_6zero) {
7970         *vmsptr++ = '[';
7971         vmslen++;
7972         dir_start = 1;
7973       }
7974
7975       /* add fake 000000] if needed */
7976       if (add_6zero) {
7977         *vmsptr++ = '0';
7978         *vmsptr++ = '0';
7979         *vmsptr++ = '0';
7980         *vmsptr++ = '0';
7981         *vmsptr++ = '0';
7982         *vmsptr++ = '0';
7983         *vmsptr++ = ']';
7984         vmslen += 7;
7985         dir_start = 0;
7986       }
7987
7988     } /* non-POSIX translation */
7989     PerlMem_free(esa);
7990   } /* End of relative/absolute path handling */
7991
7992   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7993   int dash_flag;
7994   int in_cnt;
7995   int out_cnt;
7996
7997     dash_flag = 0;
7998
7999     if (dir_start != 0) {
8000
8001       /* First characters in a directory are handled special */
8002       while ((*unixptr == '/') ||
8003              ((*unixptr == '.') &&
8004               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8005                 (&unixptr[1]==unixend)))) {
8006       int loop_flag;
8007
8008         loop_flag = 0;
8009
8010         /* Skip redundant / in specification */
8011         while ((*unixptr == '/') && (dir_start != 0)) {
8012           loop_flag = 1;
8013           unixptr++;
8014           if (unixptr == lastslash)
8015             break;
8016         }
8017         if (unixptr == lastslash)
8018           break;
8019
8020         /* Skip redundant ./ characters */
8021         while ((*unixptr == '.') &&
8022                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8023           loop_flag = 1;
8024           unixptr++;
8025           if (unixptr == lastslash)
8026             break;
8027           if (*unixptr == '/')
8028             unixptr++;
8029         }
8030         if (unixptr == lastslash)
8031           break;
8032
8033         /* Skip redundant ../ characters */
8034         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8035              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8036           /* Set the backing up flag */
8037           loop_flag = 1;
8038           dir_dot = 0;
8039           dash_flag = 1;
8040           *vmsptr++ = '-';
8041           vmslen++;
8042           unixptr++; /* first . */
8043           unixptr++; /* second . */
8044           if (unixptr == lastslash)
8045             break;
8046           if (*unixptr == '/') /* The slash */
8047             unixptr++;
8048         }
8049         if (unixptr == lastslash)
8050           break;
8051
8052         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8053         /* Not needed when VMS is pretending to be UNIX. */
8054
8055         /* Is this loop stuck because of too many dots? */
8056         if (loop_flag == 0) {
8057           /* Exit the loop and pass the rest through */
8058           break;
8059         }
8060       }
8061
8062       /* Are we done with directories yet? */
8063       if (unixptr >= lastslash) {
8064
8065         /* Watch out for trailing dots */
8066         if (dir_dot != 0) {
8067             vmslen --;
8068             vmsptr--;
8069         }
8070         *vmsptr++ = ']';
8071         vmslen++;
8072         dash_flag = 0;
8073         dir_start = 0;
8074         if (*unixptr == '/')
8075           unixptr++;
8076       }
8077       else {
8078         /* Have we stopped backing up? */
8079         if (dash_flag) {
8080           *vmsptr++ = '.';
8081           vmslen++;
8082           dash_flag = 0;
8083           /* dir_start continues to be = 1 */
8084         }
8085         if (*unixptr == '-') {
8086           *vmsptr++ = '^';
8087           *vmsptr++ = *unixptr++;
8088           vmslen += 2;
8089           dir_start = 0;
8090
8091           /* Now are we done with directories yet? */
8092           if (unixptr >= lastslash) {
8093
8094             /* Watch out for trailing dots */
8095             if (dir_dot != 0) {
8096               vmslen --;
8097               vmsptr--;
8098             }
8099
8100             *vmsptr++ = ']';
8101             vmslen++;
8102             dash_flag = 0;
8103             dir_start = 0;
8104           }
8105         }
8106       }
8107     }
8108
8109     /* All done? */
8110     if (unixptr >= unixend)
8111       break;
8112
8113     /* Normal characters - More EFS work probably needed */
8114     dir_start = 0;
8115     dir_dot = 0;
8116
8117     switch(*unixptr) {
8118     case '/':
8119         /* remove multiple / */
8120         while (unixptr[1] == '/') {
8121            unixptr++;
8122         }
8123         if (unixptr == lastslash) {
8124           /* Watch out for trailing dots */
8125           if (dir_dot != 0) {
8126             vmslen --;
8127             vmsptr--;
8128           }
8129           *vmsptr++ = ']';
8130         }
8131         else {
8132           dir_start = 1;
8133           *vmsptr++ = '.';
8134           dir_dot = 1;
8135
8136           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8137           /* Not needed when VMS is pretending to be UNIX. */
8138
8139         }
8140         dash_flag = 0;
8141         if (unixptr != unixend)
8142           unixptr++;
8143         vmslen++;
8144         break;
8145     case '.':
8146         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8147             (&unixptr[1] == unixend)) {
8148           *vmsptr++ = '^';
8149           *vmsptr++ = '.';
8150           vmslen += 2;
8151           unixptr++;
8152
8153           /* trailing dot ==> '^..' on VMS */
8154           if (unixptr == unixend) {
8155             *vmsptr++ = '.';
8156             vmslen++;
8157             unixptr++;
8158           }
8159           break;
8160         }
8161
8162         *vmsptr++ = *unixptr++;
8163         vmslen ++;
8164         break;
8165     case '"':
8166         if (quoted && (&unixptr[1] == unixend)) {
8167             unixptr++;
8168             break;
8169         }
8170         in_cnt = copy_expand_unix_filename_escape
8171                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8172         vmsptr += out_cnt;
8173         unixptr += in_cnt;
8174         break;
8175     case '~':
8176     case ';':
8177     case '\\':
8178     case '?':
8179     case ' ':
8180     default:
8181         in_cnt = copy_expand_unix_filename_escape
8182                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8183         vmsptr += out_cnt;
8184         unixptr += in_cnt;
8185         break;
8186     }
8187   }
8188
8189   /* Make sure directory is closed */
8190   if (unixptr == lastslash) {
8191     char *vmsptr2;
8192     vmsptr2 = vmsptr - 1;
8193
8194     if (*vmsptr2 != ']') {
8195       *vmsptr2--;
8196
8197       /* directories do not end in a dot bracket */
8198       if (*vmsptr2 == '.') {
8199         vmsptr2--;
8200
8201         /* ^. is allowed */
8202         if (*vmsptr2 != '^') {
8203           vmsptr--; /* back up over the dot */
8204         }
8205       }
8206       *vmsptr++ = ']';
8207     }
8208   }
8209   else {
8210     char *vmsptr2;
8211     /* Add a trailing dot if a file with no extension */
8212     vmsptr2 = vmsptr - 1;
8213     if ((vmslen > 1) &&
8214         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8215         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8216         *vmsptr++ = '.';
8217         vmslen++;
8218     }
8219   }
8220
8221   *vmsptr = '\0';
8222   return SS$_NORMAL;
8223 }
8224 #endif
8225
8226  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8227 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8228 {
8229 char * result;
8230 int utf8_flag;
8231
8232    /* If a UTF8 flag is being passed, honor it */
8233    utf8_flag = 0;
8234    if (utf8_fl != NULL) {
8235      utf8_flag = *utf8_fl;
8236     *utf8_fl = 0;
8237    }
8238
8239    if (utf8_flag) {
8240      /* If there is a possibility of UTF8, then if any UTF8 characters
8241         are present, then they must be converted to VTF-7
8242       */
8243      result = strcpy(rslt, path); /* FIX-ME */
8244    }
8245    else
8246      result = strcpy(rslt, path);
8247
8248    return result;
8249 }
8250
8251 /* A convenience macro for copying dots in filenames and escaping
8252  * them when they haven't already been escaped, with guards to
8253  * avoid checking before the start of the buffer or advancing
8254  * beyond the end of it (allowing room for the NUL terminator).
8255  */
8256 #define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
8257     if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8258           || ((vmsefsdot) == (vmsefsbuf))) \
8259          && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
8260        ) { \
8261         *((vmsefsdot)++) = '^'; \
8262     } \
8263     if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8264         *((vmsefsdot)++) = '.'; \
8265 } STMT_END
8266
8267 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8268 static char *int_tovmsspec
8269    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8270   char *dirend;
8271   char *lastdot;
8272   char *cp1;
8273   const char *cp2;
8274   unsigned long int infront = 0, hasdir = 1;
8275   int rslt_len;
8276   int no_type_seen;
8277   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8278   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8279
8280   if (vms_debug_fileify) {
8281       if (path == NULL)
8282           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8283       else
8284           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8285   }
8286
8287   if (path == NULL) {
8288       /* If we fail, we should be setting errno */
8289       set_errno(EINVAL);
8290       set_vaxc_errno(SS$_BADPARAM);
8291       return NULL;
8292   }
8293   rslt_len = VMS_MAXRSS-1;
8294
8295   /* '.' and '..' are "[]" and "[-]" for a quick check */
8296   if (path[0] == '.') {
8297     if (path[1] == '\0') {
8298       strcpy(rslt,"[]");
8299       if (utf8_flag != NULL)
8300         *utf8_flag = 0;
8301       return rslt;
8302     }
8303     else {
8304       if (path[1] == '.' && path[2] == '\0') {
8305         strcpy(rslt,"[-]");
8306         if (utf8_flag != NULL)
8307            *utf8_flag = 0;
8308         return rslt;
8309       }
8310     }
8311   }
8312
8313    /* Posix specifications are now a native VMS format */
8314   /*--------------------------------------------------*/
8315 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8316   if (decc_posix_compliant_pathnames) {
8317     if (strncmp(path,"\"^UP^",5) == 0) {
8318       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8319       return rslt;
8320     }
8321   }
8322 #endif
8323
8324   /* This is really the only way to see if this is already in VMS format */
8325   sts = vms_split_path
8326        (path,
8327         &v_spec,
8328         &v_len,
8329         &r_spec,
8330         &r_len,
8331         &d_spec,
8332         &d_len,
8333         &n_spec,
8334         &n_len,
8335         &e_spec,
8336         &e_len,
8337         &vs_spec,
8338         &vs_len);
8339   if (sts == 0) {
8340     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8341        replacement, because the above parse just took care of most of
8342        what is needed to do vmspath when the specification is already
8343        in VMS format.
8344
8345        And if it is not already, it is easier to do the conversion as
8346        part of this routine than to call this routine and then work on
8347        the result.
8348      */
8349
8350     /* If VMS punctuation was found, it is already VMS format */
8351     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8352       if (utf8_flag != NULL)
8353         *utf8_flag = 0;
8354       my_strlcpy(rslt, path, VMS_MAXRSS);
8355       if (vms_debug_fileify) {
8356           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8357       }
8358       return rslt;
8359     }
8360     /* Now, what to do with trailing "." cases where there is no
8361        extension?  If this is a UNIX specification, and EFS characters
8362        are enabled, then the trailing "." should be converted to a "^.".
8363        But if this was already a VMS specification, then it should be
8364        left alone.
8365
8366        So in the case of ambiguity, leave the specification alone.
8367      */
8368
8369
8370     /* If there is a possibility of UTF8, then if any UTF8 characters
8371         are present, then they must be converted to VTF-7
8372      */
8373     if (utf8_flag != NULL)
8374       *utf8_flag = 0;
8375     my_strlcpy(rslt, path, VMS_MAXRSS);
8376     if (vms_debug_fileify) {
8377         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8378     }
8379     return rslt;
8380   }
8381
8382   dirend = strrchr(path,'/');
8383
8384   if (dirend == NULL) {
8385      /* If we get here with no UNIX directory delimiters, then this is
8386       * not a complete file specification, such as a Unix glob
8387       * specification, shell macro, make macro, or even a valid VMS
8388       * filespec but with unescaped extended characters.  The safest
8389       * thing in all these cases is to pass it through as-is.
8390       */
8391       my_strlcpy(rslt, path, VMS_MAXRSS);
8392       if (vms_debug_fileify) {
8393           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8394       }
8395       return rslt;
8396   }
8397   else if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8398     if (!*(dirend+2)) dirend +=2;
8399     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8400     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8401   }
8402
8403   cp1 = rslt;
8404   cp2 = path;
8405   lastdot = strrchr(cp2,'.');
8406   if (*cp2 == '/') {
8407     char *trndev;
8408     int islnm, rooted;
8409     STRLEN trnend;
8410
8411     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8412     if (!*(cp2+1)) {
8413       if (decc_disable_posix_root) {
8414         strcpy(rslt,"sys$disk:[000000]");
8415       }
8416       else {
8417         strcpy(rslt,"sys$posix_root:[000000]");
8418       }
8419       if (utf8_flag != NULL)
8420         *utf8_flag = 0;
8421       if (vms_debug_fileify) {
8422           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8423       }
8424       return rslt;
8425     }
8426     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8427     *cp1 = '\0';
8428     trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8429     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8430     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8431
8432      /* DECC special handling */
8433     if (!islnm) {
8434       if (strcmp(rslt,"bin") == 0) {
8435         strcpy(rslt,"sys$system");
8436         cp1 = rslt + 10;
8437         *cp1 = 0;
8438         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8439       }
8440       else if (strcmp(rslt,"tmp") == 0) {
8441         strcpy(rslt,"sys$scratch");
8442         cp1 = rslt + 11;
8443         *cp1 = 0;
8444         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8445       }
8446       else if (!decc_disable_posix_root) {
8447         strcpy(rslt, "sys$posix_root");
8448         cp1 = rslt + 14;
8449         *cp1 = 0;
8450         cp2 = path;
8451         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8452         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8453       }
8454       else if (strcmp(rslt,"dev") == 0) {
8455         if (strncmp(cp2,"/null", 5) == 0) {
8456           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8457             strcpy(rslt,"NLA0");
8458             cp1 = rslt + 4;
8459             *cp1 = 0;
8460             cp2 = cp2 + 5;
8461             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8462           }
8463         }
8464       }
8465     }
8466
8467     trnend = islnm ? strlen(trndev) - 1 : 0;
8468     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8469     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8470     /* If the first element of the path is a logical name, determine
8471      * whether it has to be translated so we can add more directories. */
8472     if (!islnm || rooted) {
8473       *(cp1++) = ':';
8474       *(cp1++) = '[';
8475       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8476       else cp2++;
8477     }
8478     else {
8479       if (cp2 != dirend) {
8480         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8481         cp1 = rslt + trnend;
8482         if (*cp2 != 0) {
8483           *(cp1++) = '.';
8484           cp2++;
8485         }
8486       }
8487       else {
8488         if (decc_disable_posix_root) {
8489           *(cp1++) = ':';
8490           hasdir = 0;
8491         }
8492       }
8493     }
8494     PerlMem_free(trndev);
8495   }
8496   else {
8497     *(cp1++) = '[';
8498     if (*cp2 == '.') {
8499       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8500         cp2 += 2;         /* skip over "./" - it's redundant */
8501         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8502       }
8503       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8504         *(cp1++) = '-';                                 /* "../" --> "-" */
8505         cp2 += 3;
8506       }
8507       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8508                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8509         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8510         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8511         cp2 += 4;
8512       }
8513       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8514         /* Escape the extra dots in EFS file specifications */
8515         *(cp1++) = '^';
8516       }
8517       if (cp2 > dirend) cp2 = dirend;
8518     }
8519     else *(cp1++) = '.';
8520   }
8521   for (; cp2 < dirend; cp2++) {
8522     if (*cp2 == '/') {
8523       if (*(cp2-1) == '/') continue;
8524       if (*(cp1-1) != '.') *(cp1++) = '.';
8525       infront = 0;
8526     }
8527     else if (!infront && *cp2 == '.') {
8528       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8529       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8530       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8531         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8532         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8533         else {
8534           *(cp1++) = '-';
8535         }
8536         cp2 += 2;
8537         if (cp2 == dirend) break;
8538       }
8539       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8540                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8541         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8542         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8543         if (!*(cp2+3)) {
8544           *(cp1++) = '.';  /* Simulate trailing '/' */
8545           cp2 += 2;  /* for loop will incr this to == dirend */
8546         }
8547         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8548       }
8549       else {
8550         if (decc_efs_charset == 0) {
8551           if (*(cp1-1) == '^')
8552             cp1--;         /* remove the escape, if any */
8553           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8554         }
8555         else {
8556           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8557         }
8558       }
8559     }
8560     else {
8561       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8562       if (*cp2 == '.') {
8563         if (decc_efs_charset == 0) {
8564           if (*(cp1-1) == '^')
8565             cp1--;         /* remove the escape, if any */
8566           *(cp1++) = '_';
8567         }
8568         else {
8569           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8570         }
8571       }
8572       else                  *(cp1++) =  *cp2;
8573       infront = 1;
8574     }
8575   }
8576   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8577   if (hasdir) *(cp1++) = ']';
8578   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8579   /* fixme for ODS5 */
8580   no_type_seen = 0;
8581   if (cp2 > lastdot)
8582     no_type_seen = 1;
8583   while (*cp2) {
8584     switch(*cp2) {
8585     case '?':
8586         if (decc_efs_charset == 0)
8587           *(cp1++) = '%';
8588         else
8589           *(cp1++) = '?';
8590         cp2++;
8591     case ' ':
8592         if (cp2 > path && *(cp2-1) != '^') /* not previously escaped */
8593             *(cp1)++ = '^';
8594         *(cp1)++ = '_';
8595         cp2++;
8596         break;
8597     case '.':
8598         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8599             decc_readdir_dropdotnotype) {
8600           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8601           cp2++;
8602
8603           /* trailing dot ==> '^..' on VMS */
8604           if (*cp2 == '\0') {
8605             *(cp1++) = '.';
8606             no_type_seen = 0;
8607           }
8608         }
8609         else {
8610           *(cp1++) = *(cp2++);
8611           no_type_seen = 0;
8612         }
8613         break;
8614     case '$':
8615          /* This could be a macro to be passed through */
8616         *(cp1++) = *(cp2++);
8617         if (*cp2 == '(') {
8618         const char * save_cp2;
8619         char * save_cp1;
8620         int is_macro;
8621
8622             /* paranoid check */
8623             save_cp2 = cp2;
8624             save_cp1 = cp1;
8625             is_macro = 0;
8626
8627             /* Test through */
8628             *(cp1++) = *(cp2++);
8629             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8630                 *(cp1++) = *(cp2++);
8631                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8632                     *(cp1++) = *(cp2++);
8633                 }
8634                 if (*cp2 == ')') {
8635                     *(cp1++) = *(cp2++);
8636                     is_macro = 1;
8637                 }
8638             }
8639             if (is_macro == 0) {
8640                 /* Not really a macro - never mind */
8641                 cp2 = save_cp2;
8642                 cp1 = save_cp1;
8643             }
8644         }
8645         break;
8646     case '\"':
8647     case '~':
8648     case '`':
8649     case '!':
8650     case '#':
8651     case '%':
8652     case '^':
8653         /* Don't escape again if following character is
8654          * already something we escape.
8655          */
8656         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8657             *(cp1++) = *(cp2++);
8658             break;
8659         }
8660         /* But otherwise fall through and escape it. */
8661     case '&':
8662     case '(':
8663     case ')':
8664     case '=':
8665     case '+':
8666     case '\'':
8667     case '@':
8668     case '[':
8669     case ']':
8670     case '{':
8671     case '}':
8672     case ':':
8673     case '\\':
8674     case '|':
8675     case '<':
8676     case '>':
8677         if (cp2 > path && *(cp2-1) != '^') /* not previously escaped */
8678             *(cp1++) = '^';
8679         *(cp1++) = *(cp2++);
8680         break;
8681     case ';':
8682         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8683          * which is wrong.  UNIX notation should be ".dir." unless
8684          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8685          * changing this behavior could break more things at this time.
8686          * efs character set effectively does not allow "." to be a version
8687          * delimiter as a further complication about changing this.
8688          */
8689         if (decc_filename_unix_report != 0) {
8690           *(cp1++) = '^';
8691         }
8692         *(cp1++) = *(cp2++);
8693         break;
8694     default:
8695         *(cp1++) = *(cp2++);
8696     }
8697   }
8698   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8699   char *lcp1;
8700     lcp1 = cp1;
8701     lcp1--;
8702      /* Fix me for "^]", but that requires making sure that you do
8703       * not back up past the start of the filename
8704       */
8705     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8706       *cp1++ = '.';
8707   }
8708   *cp1 = '\0';
8709
8710   if (utf8_flag != NULL)
8711     *utf8_flag = 0;
8712   if (vms_debug_fileify) {
8713       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8714   }
8715   return rslt;
8716
8717 }  /* end of int_tovmsspec() */
8718
8719
8720 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8721 static char *mp_do_tovmsspec
8722    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8723   static char __tovmsspec_retbuf[VMS_MAXRSS];
8724     char * vmsspec, *ret_spec, *ret_buf;
8725
8726     vmsspec = NULL;
8727     ret_buf = buf;
8728     if (ret_buf == NULL) {
8729         if (ts) {
8730             Newx(vmsspec, VMS_MAXRSS, char);
8731             if (vmsspec == NULL)
8732                 _ckvmssts(SS$_INSFMEM);
8733             ret_buf = vmsspec;
8734         } else {
8735             ret_buf = __tovmsspec_retbuf;
8736         }
8737     }
8738
8739     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8740
8741     if (ret_spec == NULL) {
8742        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8743        if (vmsspec)
8744            Safefree(vmsspec);
8745     }
8746
8747     return ret_spec;
8748
8749 }  /* end of mp_do_tovmsspec() */
8750 /*}}}*/
8751 /* External entry points */
8752 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8753   { return do_tovmsspec(path,buf,0,NULL); }
8754 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8755   { return do_tovmsspec(path,buf,1,NULL); }
8756 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8757   { return do_tovmsspec(path,buf,0,utf8_fl); }
8758 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8759   { return do_tovmsspec(path,buf,1,utf8_fl); }
8760
8761 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8762 /* Internal routine for use with out an explicit context present */
8763 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
8764
8765     char * ret_spec, *pathified;
8766
8767     if (path == NULL)
8768         return NULL;
8769
8770     pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8771     if (pathified == NULL)
8772         _ckvmssts_noperl(SS$_INSFMEM);
8773
8774     ret_spec = int_pathify_dirspec(path, pathified);
8775
8776     if (ret_spec == NULL) {
8777         PerlMem_free(pathified);
8778         return NULL;
8779     }
8780
8781     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8782
8783     PerlMem_free(pathified);
8784     return ret_spec;
8785
8786 }
8787
8788 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8789 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8790   static char __tovmspath_retbuf[VMS_MAXRSS];
8791   int vmslen;
8792   char *pathified, *vmsified, *cp;
8793
8794   if (path == NULL) return NULL;
8795   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8796   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8797   if (int_pathify_dirspec(path, pathified) == NULL) {
8798     PerlMem_free(pathified);
8799     return NULL;
8800   }
8801
8802   vmsified = NULL;
8803   if (buf == NULL)
8804      Newx(vmsified, VMS_MAXRSS, char);
8805   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8806     PerlMem_free(pathified);
8807     if (vmsified) Safefree(vmsified);
8808     return NULL;
8809   }
8810   PerlMem_free(pathified);
8811   if (buf) {
8812     return buf;
8813   }
8814   else if (ts) {
8815     vmslen = strlen(vmsified);
8816     Newx(cp,vmslen+1,char);
8817     memcpy(cp,vmsified,vmslen);
8818     cp[vmslen] = '\0';
8819     Safefree(vmsified);
8820     return cp;
8821   }
8822   else {
8823     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8824     Safefree(vmsified);
8825     return __tovmspath_retbuf;
8826   }
8827
8828 }  /* end of do_tovmspath() */
8829 /*}}}*/
8830 /* External entry points */
8831 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8832   { return do_tovmspath(path,buf,0, NULL); }
8833 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8834   { return do_tovmspath(path,buf,1, NULL); }
8835 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8836   { return do_tovmspath(path,buf,0,utf8_fl); }
8837 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8838   { return do_tovmspath(path,buf,1,utf8_fl); }
8839
8840
8841 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8842 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8843   static char __tounixpath_retbuf[VMS_MAXRSS];
8844   int unixlen;
8845   char *pathified, *unixified, *cp;
8846
8847   if (path == NULL) return NULL;
8848   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8849   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8850   if (int_pathify_dirspec(path, pathified) == NULL) {
8851     PerlMem_free(pathified);
8852     return NULL;
8853   }
8854
8855   unixified = NULL;
8856   if (buf == NULL) {
8857       Newx(unixified, VMS_MAXRSS, char);
8858   }
8859   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8860     PerlMem_free(pathified);
8861     if (unixified) Safefree(unixified);
8862     return NULL;
8863   }
8864   PerlMem_free(pathified);
8865   if (buf) {
8866     return buf;
8867   }
8868   else if (ts) {
8869     unixlen = strlen(unixified);
8870     Newx(cp,unixlen+1,char);
8871     memcpy(cp,unixified,unixlen);
8872     cp[unixlen] = '\0';
8873     Safefree(unixified);
8874     return cp;
8875   }
8876   else {
8877     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
8878     Safefree(unixified);
8879     return __tounixpath_retbuf;
8880   }
8881
8882 }  /* end of do_tounixpath() */
8883 /*}}}*/
8884 /* External entry points */
8885 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8886   { return do_tounixpath(path,buf,0,NULL); }
8887 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8888   { return do_tounixpath(path,buf,1,NULL); }
8889 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8890   { return do_tounixpath(path,buf,0,utf8_fl); }
8891 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8892   { return do_tounixpath(path,buf,1,utf8_fl); }
8893
8894 /*
8895  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8896  *
8897  *****************************************************************************
8898  *                                                                           *
8899  *  Copyright (C) 1989-1994, 2007 by                                         *
8900  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8901  *                                                                           *
8902  *  Permission is hereby granted for the reproduction of this software       *
8903  *  on condition that this copyright notice is included in source            *
8904  *  distributions of the software.  The code may be modified and             *
8905  *  distributed under the same terms as Perl itself.                         *
8906  *                                                                           *
8907  *  27-Aug-1994 Modified for inclusion in perl5                              *
8908  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8909  *****************************************************************************
8910  */
8911
8912 /*
8913  * getredirection() is intended to aid in porting C programs
8914  * to VMS (Vax-11 C).  The native VMS environment does not support
8915  * '>' and '<' I/O redirection, or command line wild card expansion,
8916  * or a command line pipe mechanism using the '|' AND background
8917  * command execution '&'.  All of these capabilities are provided to any
8918  * C program which calls this procedure as the first thing in the
8919  * main program.
8920  * The piping mechanism will probably work with almost any 'filter' type
8921  * of program.  With suitable modification, it may useful for other
8922  * portability problems as well.
8923  *
8924  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8925  */
8926 struct list_item
8927     {
8928     struct list_item *next;
8929     char *value;
8930     };
8931
8932 static void add_item(struct list_item **head,
8933                      struct list_item **tail,
8934                      char *value,
8935                      int *count);
8936
8937 static void mp_expand_wild_cards(pTHX_ char *item,
8938                                 struct list_item **head,
8939                                 struct list_item **tail,
8940                                 int *count);
8941
8942 static int background_process(pTHX_ int argc, char **argv);
8943
8944 static void pipe_and_fork(pTHX_ char **cmargv);
8945
8946 /*{{{ void getredirection(int *ac, char ***av)*/
8947 static void
8948 mp_getredirection(pTHX_ int *ac, char ***av)
8949 /*
8950  * Process vms redirection arg's.  Exit if any error is seen.
8951  * If getredirection() processes an argument, it is erased
8952  * from the vector.  getredirection() returns a new argc and argv value.
8953  * In the event that a background command is requested (by a trailing "&"),
8954  * this routine creates a background subprocess, and simply exits the program.
8955  *
8956  * Warning: do not try to simplify the code for vms.  The code
8957  * presupposes that getredirection() is called before any data is
8958  * read from stdin or written to stdout.
8959  *
8960  * Normal usage is as follows:
8961  *
8962  *      main(argc, argv)
8963  *      int             argc;
8964  *      char            *argv[];
8965  *      {
8966  *              getredirection(&argc, &argv);
8967  *      }
8968  */
8969 {
8970     int                 argc = *ac;     /* Argument Count         */
8971     char                **argv = *av;   /* Argument Vector        */
8972     char                *ap;            /* Argument pointer       */
8973     int                 j;              /* argv[] index           */
8974     int                 item_count = 0; /* Count of Items in List */
8975     struct list_item    *list_head = 0; /* First Item in List       */
8976     struct list_item    *list_tail;     /* Last Item in List        */
8977     char                *in = NULL;     /* Input File Name          */
8978     char                *out = NULL;    /* Output File Name         */
8979     char                *outmode = "w"; /* Mode to Open Output File */
8980     char                *err = NULL;    /* Error File Name          */
8981     char                *errmode = "w"; /* Mode to Open Error File  */
8982     int                 cmargc = 0;     /* Piped Command Arg Count  */
8983     char                **cmargv = NULL;/* Piped Command Arg Vector */
8984
8985     /*
8986      * First handle the case where the last thing on the line ends with
8987      * a '&'.  This indicates the desire for the command to be run in a
8988      * subprocess, so we satisfy that desire.
8989      */
8990     ap = argv[argc-1];
8991     if (0 == strcmp("&", ap))
8992        exit(background_process(aTHX_ --argc, argv));
8993     if (*ap && '&' == ap[strlen(ap)-1])
8994         {
8995         ap[strlen(ap)-1] = '\0';
8996        exit(background_process(aTHX_ argc, argv));
8997         }
8998     /*
8999      * Now we handle the general redirection cases that involve '>', '>>',
9000      * '<', and pipes '|'.
9001      */
9002     for (j = 0; j < argc; ++j)
9003         {
9004         if (0 == strcmp("<", argv[j]))
9005             {
9006             if (j+1 >= argc)
9007                 {
9008                 fprintf(stderr,"No input file after < on command line");
9009                 exit(LIB$_WRONUMARG);
9010                 }
9011             in = argv[++j];
9012             continue;
9013             }
9014         if ('<' == *(ap = argv[j]))
9015             {
9016             in = 1 + ap;
9017             continue;
9018             }
9019         if (0 == strcmp(">", ap))
9020             {
9021             if (j+1 >= argc)
9022                 {
9023                 fprintf(stderr,"No output file after > on command line");
9024                 exit(LIB$_WRONUMARG);
9025                 }
9026             out = argv[++j];
9027             continue;
9028             }
9029         if ('>' == *ap)
9030             {
9031             if ('>' == ap[1])
9032                 {
9033                 outmode = "a";
9034                 if ('\0' == ap[2])
9035                     out = argv[++j];
9036                 else
9037                     out = 2 + ap;
9038                 }
9039             else
9040                 out = 1 + ap;
9041             if (j >= argc)
9042                 {
9043                 fprintf(stderr,"No output file after > or >> on command line");
9044                 exit(LIB$_WRONUMARG);
9045                 }
9046             continue;
9047             }
9048         if (('2' == *ap) && ('>' == ap[1]))
9049             {
9050             if ('>' == ap[2])
9051                 {
9052                 errmode = "a";
9053                 if ('\0' == ap[3])
9054                     err = argv[++j];
9055                 else
9056                     err = 3 + ap;
9057                 }
9058             else
9059                 if ('\0' == ap[2])
9060                     err = argv[++j];
9061                 else
9062                     err = 2 + ap;
9063             if (j >= argc)
9064                 {
9065                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9066                 exit(LIB$_WRONUMARG);
9067                 }
9068             continue;
9069             }
9070         if (0 == strcmp("|", argv[j]))
9071             {
9072             if (j+1 >= argc)
9073                 {
9074                 fprintf(stderr,"No command into which to pipe on command line");
9075                 exit(LIB$_WRONUMARG);
9076                 }
9077             cmargc = argc-(j+1);
9078             cmargv = &argv[j+1];
9079             argc = j;
9080             continue;
9081             }
9082         if ('|' == *(ap = argv[j]))
9083             {
9084             ++argv[j];
9085             cmargc = argc-j;
9086             cmargv = &argv[j];
9087             argc = j;
9088             continue;
9089             }
9090         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9091         }
9092     /*
9093      * Allocate and fill in the new argument vector, Some Unix's terminate
9094      * the list with an extra null pointer.
9095      */
9096     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9097     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9098     *av = argv;
9099     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9100         argv[j] = list_head->value;
9101     *ac = item_count;
9102     if (cmargv != NULL)
9103         {
9104         if (out != NULL)
9105             {
9106             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9107             exit(LIB$_INVARGORD);
9108             }
9109         pipe_and_fork(aTHX_ cmargv);
9110         }
9111
9112     /* Check for input from a pipe (mailbox) */
9113
9114     if (in == NULL && 1 == isapipe(0))
9115         {
9116         char mbxname[L_tmpnam];
9117         long int bufsize;
9118         long int dvi_item = DVI$_DEVBUFSIZ;
9119         $DESCRIPTOR(mbxnam, "");
9120         $DESCRIPTOR(mbxdevnam, "");
9121
9122         /* Input from a pipe, reopen it in binary mode to disable       */
9123         /* carriage control processing.                                 */
9124
9125         fgetname(stdin, mbxname, 1);
9126         mbxnam.dsc$a_pointer = mbxname;
9127         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9128         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9129         mbxdevnam.dsc$a_pointer = mbxname;
9130         mbxdevnam.dsc$w_length = sizeof(mbxname);
9131         dvi_item = DVI$_DEVNAM;
9132         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9133         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9134         set_errno(0);
9135         set_vaxc_errno(1);
9136         freopen(mbxname, "rb", stdin);
9137         if (errno != 0)
9138             {
9139             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9140             exit(vaxc$errno);
9141             }
9142         }
9143     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9144         {
9145         fprintf(stderr,"Can't open input file %s as stdin",in);
9146         exit(vaxc$errno);
9147         }
9148     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9149         {
9150         fprintf(stderr,"Can't open output file %s as stdout",out);
9151         exit(vaxc$errno);
9152         }
9153         if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
9154
9155     if (err != NULL) {
9156         if (strcmp(err,"&1") == 0) {
9157             dup2(fileno(stdout), fileno(stderr));
9158             vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
9159         } else {
9160         FILE *tmperr;
9161         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9162             {
9163             fprintf(stderr,"Can't open error file %s as stderr",err);
9164             exit(vaxc$errno);
9165             }
9166             fclose(tmperr);
9167            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9168                 {
9169                 exit(vaxc$errno);
9170                 }
9171             vmssetuserlnm("SYS$ERROR", err);
9172         }
9173         }
9174 #ifdef ARGPROC_DEBUG
9175     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9176     for (j = 0; j < *ac;  ++j)
9177         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9178 #endif
9179    /* Clear errors we may have hit expanding wildcards, so they don't
9180       show up in Perl's $! later */
9181    set_errno(0); set_vaxc_errno(1);
9182 }  /* end of getredirection() */
9183 /*}}}*/
9184
9185 static void add_item(struct list_item **head,
9186                      struct list_item **tail,
9187                      char *value,
9188                      int *count)
9189 {
9190     if (*head == 0)
9191         {
9192         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9193         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9194         *tail = *head;
9195         }
9196     else {
9197         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9198         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9199         *tail = (*tail)->next;
9200         }
9201     (*tail)->value = value;
9202     ++(*count);
9203 }
9204
9205 static void mp_expand_wild_cards(pTHX_ char *item,
9206                               struct list_item **head,
9207                               struct list_item **tail,
9208                               int *count)
9209 {
9210 int expcount = 0;
9211 unsigned long int context = 0;
9212 int isunix = 0;
9213 int item_len = 0;
9214 char *had_version;
9215 char *had_device;
9216 int had_directory;
9217 char *devdir,*cp;
9218 char *vmsspec;
9219 $DESCRIPTOR(filespec, "");
9220 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9221 $DESCRIPTOR(resultspec, "");
9222 unsigned long int lff_flags = 0;
9223 int sts;
9224 int rms_sts;
9225
9226 #ifdef VMS_LONGNAME_SUPPORT
9227     lff_flags = LIB$M_FIL_LONG_NAMES;
9228 #endif
9229
9230     for (cp = item; *cp; cp++) {
9231         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9232         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9233     }
9234     if (!*cp || isspace(*cp))
9235         {
9236         add_item(head, tail, item, count);
9237         return;
9238         }
9239     else
9240         {
9241      /* "double quoted" wild card expressions pass as is */
9242      /* From DCL that means using e.g.:                  */
9243      /* perl program """perl.*"""                        */
9244      item_len = strlen(item);
9245      if ( '"' == *item && '"' == item[item_len-1] )
9246        {
9247        item++;
9248        item[item_len-2] = '\0';
9249        add_item(head, tail, item, count);
9250        return;
9251        }
9252      }
9253     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9254     resultspec.dsc$b_class = DSC$K_CLASS_D;
9255     resultspec.dsc$a_pointer = NULL;
9256     vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9257     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9258     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9259       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9260     if (!isunix || !filespec.dsc$a_pointer)
9261       filespec.dsc$a_pointer = item;
9262     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9263     /*
9264      * Only return version specs, if the caller specified a version
9265      */
9266     had_version = strchr(item, ';');
9267     /*
9268      * Only return device and directory specs, if the caller specified either.
9269      */
9270     had_device = strchr(item, ':');
9271     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9272
9273     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9274                                  (&filespec, &resultspec, &context,
9275                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9276         {
9277         char *string;
9278         char *c;
9279
9280         string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9281         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9282         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9283         if (NULL == had_version)
9284             *(strrchr(string, ';')) = '\0';
9285         if ((!had_directory) && (had_device == NULL))
9286             {
9287             if (NULL == (devdir = strrchr(string, ']')))
9288                 devdir = strrchr(string, '>');
9289             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9290             }
9291         /*
9292          * Be consistent with what the C RTL has already done to the rest of
9293          * the argv items and lowercase all of these names.
9294          */
9295         if (!decc_efs_case_preserve) {
9296             for (c = string; *c; ++c)
9297             if (isupper(*c))
9298                 *c = tolower(*c);
9299         }
9300         if (isunix) trim_unixpath(string,item,1);
9301         add_item(head, tail, string, count);
9302         ++expcount;
9303     }
9304     PerlMem_free(vmsspec);
9305     if (sts != RMS$_NMF)
9306         {
9307         set_vaxc_errno(sts);
9308         switch (sts)
9309             {
9310             case RMS$_FNF: case RMS$_DNF:
9311                 set_errno(ENOENT); break;
9312             case RMS$_DIR:
9313                 set_errno(ENOTDIR); break;
9314             case RMS$_DEV:
9315                 set_errno(ENODEV); break;
9316             case RMS$_FNM: case RMS$_SYN:
9317                 set_errno(EINVAL); break;
9318             case RMS$_PRV:
9319                 set_errno(EACCES); break;
9320             default:
9321                 _ckvmssts_noperl(sts);
9322             }
9323         }
9324     if (expcount == 0)
9325         add_item(head, tail, item, count);
9326     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9327     _ckvmssts_noperl(lib$find_file_end(&context));
9328 }
9329
9330 static int child_st[2];/* Event Flag set when child process completes   */
9331
9332 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9333
9334 static unsigned long int exit_handler(void)
9335 {
9336 short iosb[4];
9337
9338     if (0 == child_st[0])
9339         {
9340 #ifdef ARGPROC_DEBUG
9341         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9342 #endif
9343         fflush(stdout);     /* Have to flush pipe for binary data to    */
9344                             /* terminate properly -- <tp@mccall.com>    */
9345         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9346         sys$dassgn(child_chan);
9347         fclose(stdout);
9348         sys$synch(0, child_st);
9349         }
9350     return(1);
9351 }
9352
9353 static void sig_child(int chan)
9354 {
9355 #ifdef ARGPROC_DEBUG
9356     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9357 #endif
9358     if (child_st[0] == 0)
9359         child_st[0] = 1;
9360 }
9361
9362 static struct exit_control_block exit_block =
9363     {
9364     0,
9365     exit_handler,
9366     1,
9367     &exit_block.exit_status,
9368     0
9369     };
9370
9371 static void
9372 pipe_and_fork(pTHX_ char **cmargv)
9373 {
9374     PerlIO *fp;
9375     struct dsc$descriptor_s *vmscmd;
9376     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9377     int sts, j, l, ismcr, quote, tquote = 0;
9378
9379     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9380     vms_execfree(vmscmd);
9381
9382     j = l = 0;
9383     p = subcmd;
9384     q = cmargv[0];
9385     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9386               && toupper(*(q+2)) == 'R' && !*(q+3);
9387
9388     while (q && l < MAX_DCL_LINE_LENGTH) {
9389         if (!*q) {
9390             if (j > 0 && quote) {
9391                 *p++ = '"';
9392                 l++;
9393             }
9394             q = cmargv[++j];
9395             if (q) {
9396                 if (ismcr && j > 1) quote = 1;
9397                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9398                 *p++ = ' ';
9399                 l++;
9400                 if (quote || tquote) {
9401                     *p++ = '"';
9402                     l++;
9403                 }
9404             }
9405         } else {
9406             if ((quote||tquote) && *q == '"') {
9407                 *p++ = '"';
9408                 l++;
9409             }
9410             *p++ = *q++;
9411             l++;
9412         }
9413     }
9414     *p = '\0';
9415
9416     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9417     if (fp == NULL) {
9418         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9419     }
9420 }
9421
9422 static int background_process(pTHX_ int argc, char **argv)
9423 {
9424 char command[MAX_DCL_SYMBOL + 1] = "$";
9425 $DESCRIPTOR(value, "");
9426 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9427 static $DESCRIPTOR(null, "NLA0:");
9428 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9429 char pidstring[80];
9430 $DESCRIPTOR(pidstr, "");
9431 int pid;
9432 unsigned long int flags = 17, one = 1, retsts;
9433 int len;
9434
9435     len = my_strlcat(command, argv[0], sizeof(command));
9436     while (--argc && (len < MAX_DCL_SYMBOL))
9437         {
9438         my_strlcat(command, " \"", sizeof(command));
9439         my_strlcat(command, *(++argv), sizeof(command));
9440         len = my_strlcat(command, "\"", sizeof(command));
9441         }
9442     value.dsc$a_pointer = command;
9443     value.dsc$w_length = strlen(value.dsc$a_pointer);
9444     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9445     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9446     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9447         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9448     }
9449     else {
9450         _ckvmssts_noperl(retsts);
9451     }
9452 #ifdef ARGPROC_DEBUG
9453     PerlIO_printf(Perl_debug_log, "%s\n", command);
9454 #endif
9455     sprintf(pidstring, "%08X", pid);
9456     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9457     pidstr.dsc$a_pointer = pidstring;
9458     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9459     lib$set_symbol(&pidsymbol, &pidstr);
9460     return(SS$_NORMAL);
9461 }
9462 /*}}}*/
9463 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9464
9465
9466 /* OS-specific initialization at image activation (not thread startup) */
9467 /* Older VAXC header files lack these constants */
9468 #ifndef JPI$_RIGHTS_SIZE
9469 #  define JPI$_RIGHTS_SIZE 817
9470 #endif
9471 #ifndef KGB$M_SUBSYSTEM
9472 #  define KGB$M_SUBSYSTEM 0x8
9473 #endif
9474
9475 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9476
9477 /*{{{void vms_image_init(int *, char ***)*/
9478 void
9479 vms_image_init(int *argcp, char ***argvp)
9480 {
9481   int status;
9482   char eqv[LNM$C_NAMLENGTH+1] = "";
9483   unsigned int len, tabct = 8, tabidx = 0;
9484   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9485   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9486   unsigned short int dummy, rlen;
9487   struct dsc$descriptor_s **tabvec;
9488 #if defined(PERL_IMPLICIT_CONTEXT)
9489   pTHX = NULL;
9490 #endif
9491   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9492                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9493                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9494                                  {          0,                0,    0,      0} };
9495
9496 #ifdef KILL_BY_SIGPRC
9497     Perl_csighandler_init();
9498 #endif
9499
9500 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9501     /* This was moved from the pre-image init handler because on threaded */
9502     /* Perl it was always returning 0 for the default value. */
9503     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9504     if (status > 0) {
9505         int s;
9506         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9507         if (s > 0) {
9508             int initial;
9509             initial = decc$feature_get_value(s, 4);
9510             if (initial > 0) {
9511                 /* initial is: 0 if nothing has set the feature */
9512                 /*            -1 if initialized to default */
9513                 /*             1 if set by logical name */
9514                 /*             2 if set by decc$feature_set_value */
9515                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9516
9517                 /* If the value is not valid, force the feature off */
9518                 if (decc_disable_posix_root < 0) {
9519                     decc$feature_set_value(s, 1, 1);
9520                     decc_disable_posix_root = 1;
9521                 }
9522             }
9523             else {
9524                 /* Nothing has asked for it explicitly, so use our own default. */
9525                 decc_disable_posix_root = 1;
9526                 decc$feature_set_value(s, 1, 1);
9527             }
9528         }
9529     }
9530 #endif
9531
9532   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9533   _ckvmssts_noperl(iosb[0]);
9534   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9535     if (iprv[i]) {           /* Running image installed with privs? */
9536       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9537       will_taint = TRUE;
9538       break;
9539     }
9540   }
9541   /* Rights identifiers might trigger tainting as well. */
9542   if (!will_taint && (rlen || rsz)) {
9543     while (rlen < rsz) {
9544       /* We didn't get all the identifiers on the first pass.  Allocate a
9545        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9546        * were needed to hold all identifiers at time of last call; we'll
9547        * allocate that many unsigned long ints), and go back and get 'em.
9548        * If it gave us less than it wanted to despite ample buffer space,
9549        * something's broken.  Is your system missing a system identifier?
9550        */
9551       if (rsz <= jpilist[1].buflen) {
9552          /* Perl_croak accvios when used this early in startup. */
9553          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9554                          rsz, (unsigned long) jpilist[1].buflen,
9555                          "Check your rights database for corruption.\n");
9556          exit(SS$_ABORT);
9557       }
9558       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9559       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9560       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9561       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9562       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9563       _ckvmssts_noperl(iosb[0]);
9564     }
9565     mask = (unsigned long int *)jpilist[1].bufadr;
9566     /* Check attribute flags for each identifier (2nd longword); protected
9567      * subsystem identifiers trigger tainting.
9568      */
9569     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9570       if (mask[i] & KGB$M_SUBSYSTEM) {
9571         will_taint = TRUE;
9572         break;
9573       }
9574     }
9575     if (mask != rlst) PerlMem_free(mask);
9576   }
9577
9578   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9579    * logical, some versions of the CRTL will add a phanthom /000000/
9580    * directory.  This needs to be removed.
9581    */
9582   if (decc_filename_unix_report) {
9583   char * zeros;
9584   int ulen;
9585     ulen = strlen(argvp[0][0]);
9586     if (ulen > 7) {
9587       zeros = strstr(argvp[0][0], "/000000/");
9588       if (zeros != NULL) {
9589         int mlen;
9590         mlen = ulen - (zeros - argvp[0][0]) - 7;
9591         memmove(zeros, &zeros[7], mlen);
9592         ulen = ulen - 7;
9593         argvp[0][0][ulen] = '\0';
9594       }
9595     }
9596     /* It also may have a trailing dot that needs to be removed otherwise
9597      * it will be converted to VMS mode incorrectly.
9598      */
9599     ulen--;
9600     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9601       argvp[0][0][ulen] = '\0';
9602   }
9603
9604   /* We need to use this hack to tell Perl it should run with tainting,
9605    * since its tainting flag may be part of the PL_curinterp struct, which
9606    * hasn't been allocated when vms_image_init() is called.
9607    */
9608   if (will_taint) {
9609     char **newargv, **oldargv;
9610     oldargv = *argvp;
9611     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9612     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9613     newargv[0] = oldargv[0];
9614     newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9615     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9616     strcpy(newargv[1], "-T");
9617     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9618     (*argcp)++;
9619     newargv[*argcp] = NULL;
9620     /* We orphan the old argv, since we don't know where it's come from,
9621      * so we don't know how to free it.
9622      */
9623     *argvp = newargv;
9624   }
9625   else {  /* Did user explicitly request tainting? */
9626     int i;
9627     char *cp, **av = *argvp;
9628     for (i = 1; i < *argcp; i++) {
9629       if (*av[i] != '-') break;
9630       for (cp = av[i]+1; *cp; cp++) {
9631         if (*cp == 'T') { will_taint = 1; break; }
9632         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9633                   strchr("DFIiMmx",*cp)) break;
9634       }
9635       if (will_taint) break;
9636     }
9637   }
9638
9639   for (tabidx = 0;
9640        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9641        tabidx++) {
9642     if (!tabidx) {
9643       tabvec = (struct dsc$descriptor_s **)
9644             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9645       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9646     }
9647     else if (tabidx >= tabct) {
9648       tabct += 8;
9649       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9650       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9651     }
9652     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9653     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9654     tabvec[tabidx]->dsc$w_length  = 0;
9655     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9656     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9657     tabvec[tabidx]->dsc$a_pointer = NULL;
9658     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9659   }
9660   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9661
9662   getredirection(argcp,argvp);
9663 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9664   {
9665 # include <reentrancy.h>
9666   decc$set_reentrancy(C$C_MULTITHREAD);
9667   }
9668 #endif
9669   return;
9670 }
9671 /*}}}*/
9672
9673
9674 /* trim_unixpath()
9675  * Trim Unix-style prefix off filespec, so it looks like what a shell
9676  * glob expansion would return (i.e. from specified prefix on, not
9677  * full path).  Note that returned filespec is Unix-style, regardless
9678  * of whether input filespec was VMS-style or Unix-style.
9679  *
9680  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9681  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9682  * vector of options; at present, only bit 0 is used, and if set tells
9683  * trim unixpath to try the current default directory as a prefix when
9684  * presented with a possibly ambiguous ... wildcard.
9685  *
9686  * Returns !=0 on success, with trimmed filespec replacing contents of
9687  * fspec, and 0 on failure, with contents of fpsec unchanged.
9688  */
9689 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9690 int
9691 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9692 {
9693   char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9694   int tmplen, reslen = 0, dirs = 0;
9695
9696   if (!wildspec || !fspec) return 0;
9697
9698   unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9699   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9700   tplate = unixwild;
9701   if (strpbrk(wildspec,"]>:") != NULL) {
9702     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9703         PerlMem_free(unixwild);
9704         return 0;
9705     }
9706   }
9707   else {
9708     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9709   }
9710   unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9711   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9712   if (strpbrk(fspec,"]>:") != NULL) {
9713     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9714         PerlMem_free(unixwild);
9715         PerlMem_free(unixified);
9716         return 0;
9717     }
9718     else base = unixified;
9719     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9720      * check to see that final result fits into (isn't longer than) fspec */
9721     reslen = strlen(fspec);
9722   }
9723   else base = fspec;
9724
9725   /* No prefix or absolute path on wildcard, so nothing to remove */
9726   if (!*tplate || *tplate == '/') {
9727     PerlMem_free(unixwild);
9728     if (base == fspec) {
9729         PerlMem_free(unixified);
9730         return 1;
9731     }
9732     tmplen = strlen(unixified);
9733     if (tmplen > reslen) {
9734         PerlMem_free(unixified);
9735         return 0;  /* not enough space */
9736     }
9737     /* Copy unixified resultant, including trailing NUL */
9738     memmove(fspec,unixified,tmplen+1);
9739     PerlMem_free(unixified);
9740     return 1;
9741   }
9742
9743   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9744   if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9745     for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9746     for (cp1 = end ;cp1 >= base; cp1--)
9747       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9748         { cp1++; break; }
9749     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9750     PerlMem_free(unixified);
9751     PerlMem_free(unixwild);
9752     return 1;
9753   }
9754   else {
9755     char *tpl, *lcres;
9756     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9757     int ells = 1, totells, segdirs, match;
9758     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9759                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9760
9761     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9762     totells = ells;
9763     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9764     tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9765     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9766     if (ellipsis == tplate && opts & 1) {
9767       /* Template begins with an ellipsis.  Since we can't tell how many
9768        * directory names at the front of the resultant to keep for an
9769        * arbitrary starting point, we arbitrarily choose the current
9770        * default directory as a starting point.  If it's there as a prefix,
9771        * clip it off.  If not, fall through and act as if the leading
9772        * ellipsis weren't there (i.e. return shortest possible path that
9773        * could match template).
9774        */
9775       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9776           PerlMem_free(tpl);
9777           PerlMem_free(unixified);
9778           PerlMem_free(unixwild);
9779           return 0;
9780       }
9781       if (!decc_efs_case_preserve) {
9782         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9783           if (_tolower(*cp1) != _tolower(*cp2)) break;
9784       }
9785       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9786       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9787       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9788         memmove(fspec,cp2+1,end - cp2);
9789         PerlMem_free(tpl);
9790         PerlMem_free(unixified);
9791         PerlMem_free(unixwild);
9792         return 1;
9793       }
9794     }
9795     /* First off, back up over constant elements at end of path */
9796     if (dirs) {
9797       for (front = end ; front >= base; front--)
9798          if (*front == '/' && !dirs--) { front++; break; }
9799     }
9800     lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9801     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9802     for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9803          cp1++,cp2++) {
9804             if (!decc_efs_case_preserve) {
9805                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9806             }
9807             else {
9808                 *cp2 = *cp1;
9809             }
9810     }
9811     if (cp1 != '\0') {
9812         PerlMem_free(tpl);
9813         PerlMem_free(unixified);
9814         PerlMem_free(unixwild);
9815         PerlMem_free(lcres);
9816         return 0;  /* Path too long. */
9817     }
9818     lcend = cp2;
9819     *cp2 = '\0';  /* Pick up with memcpy later */
9820     lcfront = lcres + (front - base);
9821     /* Now skip over each ellipsis and try to match the path in front of it. */
9822     while (ells--) {
9823       for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9824         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9825             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9826       if (cp1 < tplate) break; /* template started with an ellipsis */
9827       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9828         ellipsis = cp1; continue;
9829       }
9830       wilddsc.dsc$a_pointer = tpl;
9831       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9832       nextell = cp1;
9833       for (segdirs = 0, cp2 = tpl;
9834            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9835            cp1++, cp2++) {
9836          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9837          else {
9838             if (!decc_efs_case_preserve) {
9839               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9840             }
9841             else {
9842               *cp2 = *cp1;  /* else preserve case for match */
9843             }
9844          }
9845          if (*cp2 == '/') segdirs++;
9846       }
9847       if (cp1 != ellipsis - 1) {
9848           PerlMem_free(tpl);
9849           PerlMem_free(unixified);
9850           PerlMem_free(unixwild);
9851           PerlMem_free(lcres);
9852           return 0; /* Path too long */
9853       }
9854       /* Back up at least as many dirs as in template before matching */
9855       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9856         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9857       for (match = 0; cp1 > lcres;) {
9858         resdsc.dsc$a_pointer = cp1;
9859         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9860           match++;
9861           if (match == 1) lcfront = cp1;
9862         }
9863         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9864       }
9865       if (!match) {
9866         PerlMem_free(tpl);
9867         PerlMem_free(unixified);
9868         PerlMem_free(unixwild);
9869         PerlMem_free(lcres);
9870         return 0;  /* Can't find prefix ??? */
9871       }
9872       if (match > 1 && opts & 1) {
9873         /* This ... wildcard could cover more than one set of dirs (i.e.
9874          * a set of similar dir names is repeated).  If the template
9875          * contains more than 1 ..., upstream elements could resolve the
9876          * ambiguity, but it's not worth a full backtracking setup here.
9877          * As a quick heuristic, clip off the current default directory
9878          * if it's present to find the trimmed spec, else use the
9879          * shortest string that this ... could cover.
9880          */
9881         char def[NAM$C_MAXRSS+1], *st;
9882
9883         if (getcwd(def, sizeof def,0) == NULL) {
9884             PerlMem_free(unixified);
9885             PerlMem_free(unixwild);
9886             PerlMem_free(lcres);
9887             PerlMem_free(tpl);
9888             return 0;
9889         }
9890         if (!decc_efs_case_preserve) {
9891           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9892             if (_tolower(*cp1) != _tolower(*cp2)) break;
9893         }
9894         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9895         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9896         if (*cp1 == '\0' && *cp2 == '/') {
9897           memmove(fspec,cp2+1,end - cp2);
9898           PerlMem_free(tpl);
9899           PerlMem_free(unixified);
9900           PerlMem_free(unixwild);
9901           PerlMem_free(lcres);
9902           return 1;
9903         }
9904         /* Nope -- stick with lcfront from above and keep going. */
9905       }
9906     }
9907     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9908     PerlMem_free(tpl);
9909     PerlMem_free(unixified);
9910     PerlMem_free(unixwild);
9911     PerlMem_free(lcres);
9912     return 1;
9913   }
9914
9915 }  /* end of trim_unixpath() */
9916 /*}}}*/
9917
9918
9919 /*
9920  *  VMS readdir() routines.
9921  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9922  *
9923  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9924  *  Minor modifications to original routines.
9925  */
9926
9927 /* readdir may have been redefined by reentr.h, so make sure we get
9928  * the local version for what we do here.
9929  */
9930 #ifdef readdir
9931 # undef readdir
9932 #endif
9933 #if !defined(PERL_IMPLICIT_CONTEXT)
9934 # define readdir Perl_readdir
9935 #else
9936 # define readdir(a) Perl_readdir(aTHX_ a)
9937 #endif
9938
9939     /* Number of elements in vms_versions array */
9940 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9941
9942 /*
9943  *  Open a directory, return a handle for later use.
9944  */
9945 /*{{{ DIR *opendir(char*name) */
9946 DIR *
9947 Perl_opendir(pTHX_ const char *name)
9948 {
9949     DIR *dd;
9950     char *dir;
9951     Stat_t sb;
9952
9953     Newx(dir, VMS_MAXRSS, char);
9954     if (int_tovmspath(name, dir, NULL) == NULL) {
9955       Safefree(dir);
9956       return NULL;
9957     }
9958     /* Check access before stat; otherwise stat does not
9959      * accurately report whether it's a directory.
9960      */
9961     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9962       /* cando_by_name has already set errno */
9963       Safefree(dir);
9964       return NULL;
9965     }
9966     if (flex_stat(dir,&sb) == -1) return NULL;
9967     if (!S_ISDIR(sb.st_mode)) {
9968       Safefree(dir);
9969       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9970       return NULL;
9971     }
9972     /* Get memory for the handle, and the pattern. */
9973     Newx(dd,1,DIR);
9974     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9975
9976     /* Fill in the fields; mainly playing with the descriptor. */
9977     sprintf(dd->pattern, "%s*.*",dir);
9978     Safefree(dir);
9979     dd->context = 0;
9980     dd->count = 0;
9981     dd->flags = 0;
9982     /* By saying we always want the result of readdir() in unix format, we
9983      * are really saying we want all the escapes removed.  Otherwise the caller,
9984      * having no way to know whether it's already in VMS format, might send it
9985      * through tovmsspec again, thus double escaping.
9986      */
9987     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9988     dd->pat.dsc$a_pointer = dd->pattern;
9989     dd->pat.dsc$w_length = strlen(dd->pattern);
9990     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9991     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9992 #if defined(USE_ITHREADS)
9993     Newx(dd->mutex,1,perl_mutex);
9994     MUTEX_INIT( (perl_mutex *) dd->mutex );
9995 #else
9996     dd->mutex = NULL;
9997 #endif
9998
9999     return dd;
10000 }  /* end of opendir() */
10001 /*}}}*/
10002
10003 /*
10004  *  Set the flag to indicate we want versions or not.
10005  */
10006 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10007 void
10008 vmsreaddirversions(DIR *dd, int flag)
10009 {
10010     if (flag)
10011         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10012     else
10013         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10014 }
10015 /*}}}*/
10016
10017 /*
10018  *  Free up an opened directory.
10019  */
10020 /*{{{ void closedir(DIR *dd)*/
10021 void
10022 Perl_closedir(DIR *dd)
10023 {
10024     int sts;
10025
10026     sts = lib$find_file_end(&dd->context);
10027     Safefree(dd->pattern);
10028 #if defined(USE_ITHREADS)
10029     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10030     Safefree(dd->mutex);
10031 #endif
10032     Safefree(dd);
10033 }
10034 /*}}}*/
10035
10036 /*
10037  *  Collect all the version numbers for the current file.
10038  */
10039 static void
10040 collectversions(pTHX_ DIR *dd)
10041 {
10042     struct dsc$descriptor_s     pat;
10043     struct dsc$descriptor_s     res;
10044     struct dirent *e;
10045     char *p, *text, *buff;
10046     int i;
10047     unsigned long context, tmpsts;
10048
10049     /* Convenient shorthand. */
10050     e = &dd->entry;
10051
10052     /* Add the version wildcard, ignoring the "*.*" put on before */
10053     i = strlen(dd->pattern);
10054     Newx(text,i + e->d_namlen + 3,char);
10055     my_strlcpy(text, dd->pattern, i + 1);
10056     sprintf(&text[i - 3], "%s;*", e->d_name);
10057
10058     /* Set up the pattern descriptor. */
10059     pat.dsc$a_pointer = text;
10060     pat.dsc$w_length = i + e->d_namlen - 1;
10061     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10062     pat.dsc$b_class = DSC$K_CLASS_S;
10063
10064     /* Set up result descriptor. */
10065     Newx(buff, VMS_MAXRSS, char);
10066     res.dsc$a_pointer = buff;
10067     res.dsc$w_length = VMS_MAXRSS - 1;
10068     res.dsc$b_dtype = DSC$K_DTYPE_T;
10069     res.dsc$b_class = DSC$K_CLASS_S;
10070
10071     /* Read files, collecting versions. */
10072     for (context = 0, e->vms_verscount = 0;
10073          e->vms_verscount < VERSIZE(e);
10074          e->vms_verscount++) {
10075         unsigned long rsts;
10076         unsigned long flags = 0;
10077
10078 #ifdef VMS_LONGNAME_SUPPORT
10079         flags = LIB$M_FIL_LONG_NAMES;
10080 #endif
10081         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10082         if (tmpsts == RMS$_NMF || context == 0) break;
10083         _ckvmssts(tmpsts);
10084         buff[VMS_MAXRSS - 1] = '\0';
10085         if ((p = strchr(buff, ';')))
10086             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10087         else
10088             e->vms_versions[e->vms_verscount] = -1;
10089     }
10090
10091     _ckvmssts(lib$find_file_end(&context));
10092     Safefree(text);
10093     Safefree(buff);
10094
10095 }  /* end of collectversions() */
10096
10097 /*
10098  *  Read the next entry from the directory.
10099  */
10100 /*{{{ struct dirent *readdir(DIR *dd)*/
10101 struct dirent *
10102 Perl_readdir(pTHX_ DIR *dd)
10103 {
10104     struct dsc$descriptor_s     res;
10105     char *p, *buff;
10106     unsigned long int tmpsts;
10107     unsigned long rsts;
10108     unsigned long flags = 0;
10109     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10110     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10111
10112     /* Set up result descriptor, and get next file. */
10113     Newx(buff, VMS_MAXRSS, char);
10114     res.dsc$a_pointer = buff;
10115     res.dsc$w_length = VMS_MAXRSS - 1;
10116     res.dsc$b_dtype = DSC$K_DTYPE_T;
10117     res.dsc$b_class = DSC$K_CLASS_S;
10118
10119 #ifdef VMS_LONGNAME_SUPPORT
10120     flags = LIB$M_FIL_LONG_NAMES;
10121 #endif
10122
10123     tmpsts = lib$find_file
10124         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10125     if (dd->context == 0)
10126         tmpsts = RMS$_NMF;  /* None left. (should be set, but make sure) */
10127
10128     if (!(tmpsts & 1)) {
10129       switch (tmpsts) {
10130         case RMS$_NMF:
10131           break;  /* no more files considered success */
10132         case RMS$_PRV:
10133           SETERRNO(EACCES, tmpsts); break;
10134         case RMS$_DEV:
10135           SETERRNO(ENODEV, tmpsts); break;
10136         case RMS$_DIR:
10137           SETERRNO(ENOTDIR, tmpsts); break;
10138         case RMS$_FNF: case RMS$_DNF:
10139           SETERRNO(ENOENT, tmpsts); break;
10140         default:
10141           SETERRNO(EVMSERR, tmpsts);
10142       }
10143       Safefree(buff);
10144       return NULL;
10145     }
10146     dd->count++;
10147     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10148     buff[res.dsc$w_length] = '\0';
10149     p = buff + res.dsc$w_length;
10150     while (--p >= buff) if (!isspace(*p)) break;
10151     *p = '\0';
10152     if (!decc_efs_case_preserve) {
10153       for (p = buff; *p; p++) *p = _tolower(*p);
10154     }
10155
10156     /* Skip any directory component and just copy the name. */
10157     sts = vms_split_path
10158        (buff,
10159         &v_spec,
10160         &v_len,
10161         &r_spec,
10162         &r_len,
10163         &d_spec,
10164         &d_len,
10165         &n_spec,
10166         &n_len,
10167         &e_spec,
10168         &e_len,
10169         &vs_spec,
10170         &vs_len);
10171
10172     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10173
10174         /* In Unix report mode, remove the ".dir;1" from the name */
10175         /* if it is a real directory. */
10176         if (decc_filename_unix_report && decc_efs_charset) {
10177             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10178                 Stat_t statbuf;
10179                 int ret_sts;
10180
10181                 ret_sts = flex_lstat(buff, &statbuf);
10182                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10183                     e_len = 0;
10184                     e_spec[0] = 0;
10185                 }
10186             }
10187         }
10188
10189         /* Drop NULL extensions on UNIX file specification */
10190         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10191             e_len = 0;
10192             e_spec[0] = '\0';
10193         }
10194     }
10195
10196     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10197     dd->entry.d_name[n_len + e_len] = '\0';
10198     dd->entry.d_namlen = n_len + e_len;
10199
10200     /* Convert the filename to UNIX format if needed */
10201     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10202
10203         /* Translate the encoded characters. */
10204         /* Fixme: Unicode handling could result in embedded 0 characters */
10205         if (strchr(dd->entry.d_name, '^') != NULL) {
10206             char new_name[256];
10207             char * q;
10208             p = dd->entry.d_name;
10209             q = new_name;
10210             while (*p != 0) {
10211                 int inchars_read, outchars_added;
10212                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10213                 p += inchars_read;
10214                 q += outchars_added;
10215                 /* fix-me */
10216                 /* if outchars_added > 1, then this is a wide file specification */
10217                 /* Wide file specifications need to be passed in Perl */
10218                 /* counted strings apparently with a Unicode flag */
10219             }
10220             *q = 0;
10221             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10222         }
10223     }
10224
10225     dd->entry.vms_verscount = 0;
10226     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10227     Safefree(buff);
10228     return &dd->entry;
10229
10230 }  /* end of readdir() */
10231 /*}}}*/
10232
10233 /*
10234  *  Read the next entry from the directory -- thread-safe version.
10235  */
10236 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10237 int
10238 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10239 {
10240     int retval;
10241
10242     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10243
10244     entry = readdir(dd);
10245     *result = entry;
10246     retval = ( *result == NULL ? errno : 0 );
10247
10248     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10249
10250     return retval;
10251
10252 }  /* end of readdir_r() */
10253 /*}}}*/
10254
10255 /*
10256  *  Return something that can be used in a seekdir later.
10257  */
10258 /*{{{ long telldir(DIR *dd)*/
10259 long
10260 Perl_telldir(DIR *dd)
10261 {
10262     return dd->count;
10263 }
10264 /*}}}*/
10265
10266 /*
10267  *  Return to a spot where we used to be.  Brute force.
10268  */
10269 /*{{{ void seekdir(DIR *dd,long count)*/
10270 void
10271 Perl_seekdir(pTHX_ DIR *dd, long count)
10272 {
10273     int old_flags;
10274
10275     /* If we haven't done anything yet... */
10276     if (dd->count == 0)
10277         return;
10278
10279     /* Remember some state, and clear it. */
10280     old_flags = dd->flags;
10281     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10282     _ckvmssts(lib$find_file_end(&dd->context));
10283     dd->context = 0;
10284
10285     /* The increment is in readdir(). */
10286     for (dd->count = 0; dd->count < count; )
10287         readdir(dd);
10288
10289     dd->flags = old_flags;
10290
10291 }  /* end of seekdir() */
10292 /*}}}*/
10293
10294 /* VMS subprocess management
10295  *
10296  * my_vfork() - just a vfork(), after setting a flag to record that
10297  * the current script is trying a Unix-style fork/exec.
10298  *
10299  * vms_do_aexec() and vms_do_exec() are called in response to the
10300  * perl 'exec' function.  If this follows a vfork call, then they
10301  * call out the regular perl routines in doio.c which do an
10302  * execvp (for those who really want to try this under VMS).
10303  * Otherwise, they do exactly what the perl docs say exec should
10304  * do - terminate the current script and invoke a new command
10305  * (See below for notes on command syntax.)
10306  *
10307  * do_aspawn() and do_spawn() implement the VMS side of the perl
10308  * 'system' function.
10309  *
10310  * Note on command arguments to perl 'exec' and 'system': When handled
10311  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10312  * are concatenated to form a DCL command string.  If the first non-numeric
10313  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10314  * the command string is handed off to DCL directly.  Otherwise,
10315  * the first token of the command is taken as the filespec of an image
10316  * to run.  The filespec is expanded using a default type of '.EXE' and
10317  * the process defaults for device, directory, etc., and if found, the resultant
10318  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10319  * the command string as parameters.  This is perhaps a bit complicated,
10320  * but I hope it will form a happy medium between what VMS folks expect
10321  * from lib$spawn and what Unix folks expect from exec.
10322  */
10323
10324 static int vfork_called;
10325
10326 /*{{{int my_vfork(void)*/
10327 int
10328 my_vfork(void)
10329 {
10330   vfork_called++;
10331   return vfork();
10332 }
10333 /*}}}*/
10334
10335
10336 static void
10337 vms_execfree(struct dsc$descriptor_s *vmscmd)
10338 {
10339   if (vmscmd) {
10340       if (vmscmd->dsc$a_pointer) {
10341           PerlMem_free(vmscmd->dsc$a_pointer);
10342       }
10343       PerlMem_free(vmscmd);
10344   }
10345 }
10346
10347 static char *
10348 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10349 {
10350   char *junk, *tmps = NULL;
10351   size_t cmdlen = 0;
10352   size_t rlen;
10353   SV **idx;
10354   STRLEN n_a;
10355
10356   idx = mark;
10357   if (really) {
10358     tmps = SvPV(really,rlen);
10359     if (*tmps) {
10360       cmdlen += rlen + 1;
10361       idx++;
10362     }
10363   }
10364
10365   for (idx++; idx <= sp; idx++) {
10366     if (*idx) {
10367       junk = SvPVx(*idx,rlen);
10368       cmdlen += rlen ? rlen + 1 : 0;
10369     }
10370   }
10371   Newx(PL_Cmd, cmdlen+1, char);
10372
10373   if (tmps && *tmps) {
10374     my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10375     mark++;
10376   }
10377   else *PL_Cmd = '\0';
10378   while (++mark <= sp) {
10379     if (*mark) {
10380       char *s = SvPVx(*mark,n_a);
10381       if (!*s) continue;
10382       if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10383       my_strlcat(PL_Cmd, s, cmdlen+1);
10384     }
10385   }
10386   return PL_Cmd;
10387
10388 }  /* end of setup_argstr() */
10389
10390
10391 static unsigned long int
10392 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10393                    struct dsc$descriptor_s **pvmscmd)
10394 {
10395   char * vmsspec;
10396   char * resspec;
10397   char image_name[NAM$C_MAXRSS+1];
10398   char image_argv[NAM$C_MAXRSS+1];
10399   $DESCRIPTOR(defdsc,".EXE");
10400   $DESCRIPTOR(defdsc2,".");
10401   struct dsc$descriptor_s resdsc;
10402   struct dsc$descriptor_s *vmscmd;
10403   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10404   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10405   char *s, *rest, *cp, *wordbreak;
10406   char * cmd;
10407   int cmdlen;
10408   int isdcl;
10409
10410   vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10411   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10412
10413   /* vmsspec is a DCL command buffer, not just a filename */
10414   vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10415   if (vmsspec == NULL)
10416       _ckvmssts_noperl(SS$_INSFMEM);
10417
10418   resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10419   if (resspec == NULL)
10420       _ckvmssts_noperl(SS$_INSFMEM);
10421
10422   /* Make a copy for modification */
10423   cmdlen = strlen(incmd);
10424   cmd = (char *)PerlMem_malloc(cmdlen+1);
10425   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10426   my_strlcpy(cmd, incmd, cmdlen + 1);
10427   image_name[0] = 0;
10428   image_argv[0] = 0;
10429
10430   resdsc.dsc$a_pointer = resspec;
10431   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10432   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10433   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10434
10435   vmscmd->dsc$a_pointer = NULL;
10436   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10437   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10438   vmscmd->dsc$w_length = 0;
10439   if (pvmscmd) *pvmscmd = vmscmd;
10440
10441   if (suggest_quote) *suggest_quote = 0;
10442
10443   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10444     PerlMem_free(cmd);
10445     PerlMem_free(vmsspec);
10446     PerlMem_free(resspec);
10447     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10448   }
10449
10450   s = cmd;
10451
10452   while (*s && isspace(*s)) s++;
10453
10454   if (*s == '@' || *s == '$') {
10455     vmsspec[0] = *s;  rest = s + 1;
10456     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10457   }
10458   else { cp = vmsspec; rest = s; }
10459
10460   /* If the first word is quoted, then we need to unquote it and
10461    * escape spaces within it.  We'll expand into the resspec buffer,
10462    * then copy back into the cmd buffer, expanding the latter if
10463    * necessary.
10464    */
10465   if (*rest == '"') {
10466     char *cp2;
10467     char *r = rest;
10468     bool in_quote = 0;
10469     int clen = cmdlen;
10470     int soff = s - cmd;
10471
10472     for (cp2 = resspec;
10473          *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10474          rest++) {
10475
10476       if (*rest == ' ') {    /* Escape ' ' to '^_'. */
10477         *cp2 = '^';
10478         *(++cp2) = '_';
10479         cp2++;
10480         clen++;
10481       }
10482       else if (*rest == '"') {
10483         clen--;
10484         if (in_quote) {     /* Must be closing quote. */
10485           rest++;
10486           break;
10487         }
10488         in_quote = 1;
10489       }
10490       else {
10491         *cp2 = *rest;
10492         cp2++;
10493       }
10494     }
10495     *cp2 = '\0';
10496
10497     /* Expand the command buffer if necessary. */
10498     if (clen > cmdlen) {
10499       cmd = (char *)PerlMem_realloc(cmd, clen);
10500       if (cmd == NULL)
10501         _ckvmssts_noperl(SS$_INSFMEM);
10502       /* Where we are may have changed, so recompute offsets */
10503       r = cmd + (r - s - soff);
10504       rest = cmd + (rest - s - soff);
10505       s = cmd + soff;
10506     }
10507
10508     /* Shift the non-verb portion of the command (if any) up or
10509      * down as necessary.
10510      */
10511     if (*rest)
10512       memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10513
10514     /* Copy the unquoted and escaped command verb into place. */
10515     memcpy(r, resspec, cp2 - resspec);
10516     cmd[clen] = '\0';
10517     cmdlen = clen;
10518     rest = r;         /* Rewind for subsequent operations. */
10519   }
10520
10521   if (*rest == '.' || *rest == '/') {
10522     char *cp2;
10523     for (cp2 = resspec;
10524          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10525          rest++, cp2++) *cp2 = *rest;
10526     *cp2 = '\0';
10527     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10528       s = vmsspec;
10529
10530       /* When a UNIX spec with no file type is translated to VMS, */
10531       /* A trailing '.' is appended under ODS-5 rules.            */
10532       /* Here we do not want that trailing "." as it prevents     */
10533       /* Looking for a implied ".exe" type. */
10534       if (decc_efs_charset) {
10535           int i;
10536           i = strlen(vmsspec);
10537           if (vmsspec[i-1] == '.') {
10538               vmsspec[i-1] = '\0';
10539           }
10540       }
10541
10542       if (*rest) {
10543         for (cp2 = vmsspec + strlen(vmsspec);
10544              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10545              rest++, cp2++) *cp2 = *rest;
10546         *cp2 = '\0';
10547       }
10548     }
10549   }
10550   /* Intuit whether verb (first word of cmd) is a DCL command:
10551    *   - if first nonspace char is '@', it's a DCL indirection
10552    * otherwise
10553    *   - if verb contains a filespec separator, it's not a DCL command
10554    *   - if it doesn't, caller tells us whether to default to a DCL
10555    *     command, or to a local image unless told it's DCL (by leading '$')
10556    */
10557   if (*s == '@') {
10558       isdcl = 1;
10559       if (suggest_quote) *suggest_quote = 1;
10560   } else {
10561     char *filespec = strpbrk(s,":<[.;");
10562     rest = wordbreak = strpbrk(s," \"\t/");
10563     if (!wordbreak) wordbreak = s + strlen(s);
10564     if (*s == '$') check_img = 0;
10565     if (filespec && (filespec < wordbreak)) isdcl = 0;
10566     else isdcl = !check_img;
10567   }
10568
10569   if (!isdcl) {
10570     int rsts;
10571     imgdsc.dsc$a_pointer = s;
10572     imgdsc.dsc$w_length = wordbreak - s;
10573     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10574     if (!(retsts&1)) {
10575         _ckvmssts_noperl(lib$find_file_end(&cxt));
10576         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10577       if (!(retsts & 1) && *s == '$') {
10578         _ckvmssts_noperl(lib$find_file_end(&cxt));
10579         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10580         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10581         if (!(retsts&1)) {
10582           _ckvmssts_noperl(lib$find_file_end(&cxt));
10583           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10584         }
10585       }
10586     }
10587     _ckvmssts_noperl(lib$find_file_end(&cxt));
10588
10589     if (retsts & 1) {
10590       FILE *fp;
10591       s = resspec;
10592       while (*s && !isspace(*s)) s++;
10593       *s = '\0';
10594
10595       /* check that it's really not DCL with no file extension */
10596       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10597       if (fp) {
10598         char b[256] = {0,0,0,0};
10599         read(fileno(fp), b, 256);
10600         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10601         if (isdcl) {
10602           int shebang_len;
10603
10604           /* Check for script */
10605           shebang_len = 0;
10606           if ((b[0] == '#') && (b[1] == '!'))
10607              shebang_len = 2;
10608 #ifdef ALTERNATE_SHEBANG
10609           else {
10610             shebang_len = strlen(ALTERNATE_SHEBANG);
10611             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10612               char * perlstr;
10613                 perlstr = strstr("perl",b);
10614                 if (perlstr == NULL)
10615                   shebang_len = 0;
10616             }
10617             else
10618               shebang_len = 0;
10619           }
10620 #endif
10621
10622           if (shebang_len > 0) {
10623           int i;
10624           int j;
10625           char tmpspec[NAM$C_MAXRSS + 1];
10626
10627             i = shebang_len;
10628              /* Image is following after white space */
10629             /*--------------------------------------*/
10630             while (isprint(b[i]) && isspace(b[i]))
10631                 i++;
10632
10633             j = 0;
10634             while (isprint(b[i]) && !isspace(b[i])) {
10635                 tmpspec[j++] = b[i++];
10636                 if (j >= NAM$C_MAXRSS)
10637                    break;
10638             }
10639             tmpspec[j] = '\0';
10640
10641              /* There may be some default parameters to the image */
10642             /*---------------------------------------------------*/
10643             j = 0;
10644             while (isprint(b[i])) {
10645                 image_argv[j++] = b[i++];
10646                 if (j >= NAM$C_MAXRSS)
10647                    break;
10648             }
10649             while ((j > 0) && !isprint(image_argv[j-1]))
10650                 j--;
10651             image_argv[j] = 0;
10652
10653             /* It will need to be converted to VMS format and validated */
10654             if (tmpspec[0] != '\0') {
10655               char * iname;
10656
10657                /* Try to find the exact program requested to be run */
10658               /*---------------------------------------------------*/
10659               iname = int_rmsexpand
10660                  (tmpspec, image_name, ".exe",
10661                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10662               if (iname != NULL) {
10663                 if (cando_by_name_int
10664                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10665                   /* MCR prefix needed */
10666                   isdcl = 0;
10667                 }
10668                 else {
10669                    /* Try again with a null type */
10670                   /*----------------------------*/
10671                   iname = int_rmsexpand
10672                     (tmpspec, image_name, ".",
10673                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10674                   if (iname != NULL) {
10675                     if (cando_by_name_int
10676                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10677                       /* MCR prefix needed */
10678                       isdcl = 0;
10679                     }
10680                   }
10681                 }
10682
10683                  /* Did we find the image to run the script? */
10684                 /*------------------------------------------*/
10685                 if (isdcl) {
10686                   char *tchr;
10687
10688                    /* Assume DCL or foreign command exists */
10689                   /*--------------------------------------*/
10690                   tchr = strrchr(tmpspec, '/');
10691                   if (tchr != NULL) {
10692                     tchr++;
10693                   }
10694                   else {
10695                     tchr = tmpspec;
10696                   }
10697                   my_strlcpy(image_name, tchr, sizeof(image_name));
10698                 }
10699               }
10700             }
10701           }
10702         }
10703         fclose(fp);
10704       }
10705       if (check_img && isdcl) {
10706           PerlMem_free(cmd);
10707           PerlMem_free(resspec);
10708           PerlMem_free(vmsspec);
10709           return RMS$_FNF;
10710       }
10711
10712       if (cando_by_name(S_IXUSR,0,resspec)) {
10713         vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10714         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10715         if (!isdcl) {
10716             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10717             if (image_name[0] != 0) {
10718                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10719                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10720             }
10721         } else if (image_name[0] != 0) {
10722             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10723             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10724         } else {
10725             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10726         }
10727         if (suggest_quote) *suggest_quote = 1;
10728
10729         /* If there is an image name, use original command */
10730         if (image_name[0] == 0)
10731             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10732         else {
10733             rest = cmd;
10734             while (*rest && isspace(*rest)) rest++;
10735         }
10736
10737         if (image_argv[0] != 0) {
10738           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10739           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10740         }
10741         if (rest) {
10742            int rest_len;
10743            int vmscmd_len;
10744
10745            rest_len = strlen(rest);
10746            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10747            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10748               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10749            else
10750              retsts = CLI$_BUFOVF;
10751         }
10752         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10753         PerlMem_free(cmd);
10754         PerlMem_free(vmsspec);
10755         PerlMem_free(resspec);
10756         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10757       }
10758       else
10759         retsts = RMS$_PRV;
10760     }
10761   }
10762   /* It's either a DCL command or we couldn't find a suitable image */
10763   vmscmd->dsc$w_length = strlen(cmd);
10764
10765   vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10766   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10767
10768   PerlMem_free(cmd);
10769   PerlMem_free(resspec);
10770   PerlMem_free(vmsspec);
10771
10772   /* check if it's a symbol (for quoting purposes) */
10773   if (suggest_quote && !*suggest_quote) {
10774     int iss;
10775     char equiv[LNM$C_NAMLENGTH];
10776     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10777     eqvdsc.dsc$a_pointer = equiv;
10778
10779     iss = lib$get_symbol(vmscmd,&eqvdsc);
10780     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10781   }
10782   if (!(retsts & 1)) {
10783     /* just hand off status values likely to be due to user error */
10784     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10785         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10786        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10787     else { _ckvmssts_noperl(retsts); }
10788   }
10789
10790   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10791
10792 }  /* end of setup_cmddsc() */
10793
10794
10795 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10796 bool
10797 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10798 {
10799 bool exec_sts;
10800 char * cmd;
10801
10802   if (sp > mark) {
10803     if (vfork_called) {           /* this follows a vfork - act Unixish */
10804       vfork_called--;
10805       if (vfork_called < 0) {
10806         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10807         vfork_called = 0;
10808       }
10809       else return do_aexec(really,mark,sp);
10810     }
10811                                            /* no vfork - act VMSish */
10812     cmd = setup_argstr(aTHX_ really,mark,sp);
10813     exec_sts = vms_do_exec(cmd);
10814     Safefree(cmd);  /* Clean up from setup_argstr() */
10815     return exec_sts;
10816   }
10817
10818   return FALSE;
10819 }  /* end of vms_do_aexec() */
10820 /*}}}*/
10821
10822 /* {{{bool vms_do_exec(char *cmd) */
10823 bool
10824 Perl_vms_do_exec(pTHX_ const char *cmd)
10825 {
10826   struct dsc$descriptor_s *vmscmd;
10827
10828   if (vfork_called) {             /* this follows a vfork - act Unixish */
10829     vfork_called--;
10830     if (vfork_called < 0) {
10831       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10832       vfork_called = 0;
10833     }
10834     else return do_exec(cmd);
10835   }
10836
10837   {                               /* no vfork - act VMSish */
10838     unsigned long int retsts;
10839
10840     TAINT_ENV();
10841     TAINT_PROPER("exec");
10842     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10843       retsts = lib$do_command(vmscmd);
10844
10845     switch (retsts) {
10846       case RMS$_FNF: case RMS$_DNF:
10847         set_errno(ENOENT); break;
10848       case RMS$_DIR:
10849         set_errno(ENOTDIR); break;
10850       case RMS$_DEV:
10851         set_errno(ENODEV); break;
10852       case RMS$_PRV:
10853         set_errno(EACCES); break;
10854       case RMS$_SYN:
10855         set_errno(EINVAL); break;
10856       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10857         set_errno(E2BIG); break;
10858       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10859         _ckvmssts_noperl(retsts); /* fall through */
10860       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10861         set_errno(EVMSERR);
10862     }
10863     set_vaxc_errno(retsts);
10864     if (ckWARN(WARN_EXEC)) {
10865       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10866              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10867     }
10868     vms_execfree(vmscmd);
10869   }
10870
10871   return FALSE;
10872
10873 }  /* end of vms_do_exec() */
10874 /*}}}*/
10875
10876 int do_spawn2(pTHX_ const char *, int);
10877
10878 int
10879 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10880 {
10881 unsigned long int sts;
10882 char * cmd;
10883 int flags = 0;
10884
10885   if (sp > mark) {
10886
10887     /* We'll copy the (undocumented?) Win32 behavior and allow a
10888      * numeric first argument.  But the only value we'll support
10889      * through do_aspawn is a value of 1, which means spawn without
10890      * waiting for completion -- other values are ignored.
10891      */
10892     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10893         ++mark;
10894         flags = SvIVx(*mark);
10895     }
10896
10897     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10898         flags = CLI$M_NOWAIT;
10899     else
10900         flags = 0;
10901
10902     cmd = setup_argstr(aTHX_ really, mark, sp);
10903     sts = do_spawn2(aTHX_ cmd, flags);
10904     /* pp_sys will clean up cmd */
10905     return sts;
10906   }
10907   return SS$_ABORT;
10908 }  /* end of do_aspawn() */
10909 /*}}}*/
10910
10911
10912 /* {{{int do_spawn(char* cmd) */
10913 int
10914 Perl_do_spawn(pTHX_ char* cmd)
10915 {
10916     PERL_ARGS_ASSERT_DO_SPAWN;
10917
10918     return do_spawn2(aTHX_ cmd, 0);
10919 }
10920 /*}}}*/
10921
10922 /* {{{int do_spawn_nowait(char* cmd) */
10923 int
10924 Perl_do_spawn_nowait(pTHX_ char* cmd)
10925 {
10926     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10927
10928     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10929 }
10930 /*}}}*/
10931
10932 /* {{{int do_spawn2(char *cmd) */
10933 int
10934 do_spawn2(pTHX_ const char *cmd, int flags)
10935 {
10936   unsigned long int sts, substs;
10937
10938   /* The caller of this routine expects to Safefree(PL_Cmd) */
10939   Newx(PL_Cmd,10,char);
10940
10941   TAINT_ENV();
10942   TAINT_PROPER("spawn");
10943   if (!cmd || !*cmd) {
10944     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10945     if (!(sts & 1)) {
10946       switch (sts) {
10947         case RMS$_FNF:  case RMS$_DNF:
10948           set_errno(ENOENT); break;
10949         case RMS$_DIR:
10950           set_errno(ENOTDIR); break;
10951         case RMS$_DEV:
10952           set_errno(ENODEV); break;
10953         case RMS$_PRV:
10954           set_errno(EACCES); break;
10955         case RMS$_SYN:
10956           set_errno(EINVAL); break;
10957         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10958           set_errno(E2BIG); break;
10959         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10960           _ckvmssts_noperl(sts); /* fall through */
10961         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10962           set_errno(EVMSERR);
10963       }
10964       set_vaxc_errno(sts);
10965       if (ckWARN(WARN_EXEC)) {
10966         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10967                     Strerror(errno));
10968       }
10969     }
10970     sts = substs;
10971   }
10972   else {
10973     char mode[3];
10974     PerlIO * fp;
10975     if (flags & CLI$M_NOWAIT)
10976         strcpy(mode, "n");
10977     else
10978         strcpy(mode, "nW");
10979
10980     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10981     if (fp != NULL)
10982       my_pclose(fp);
10983     /* sts will be the pid in the nowait case */
10984   }
10985   return sts;
10986 }  /* end of do_spawn2() */
10987 /*}}}*/
10988
10989
10990 static unsigned int *sockflags, sockflagsize;
10991
10992 /*
10993  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10994  * routines found in some versions of the CRTL can't deal with sockets.
10995  * We don't shim the other file open routines since a socket isn't
10996  * likely to be opened by a name.
10997  */
10998 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10999 FILE *my_fdopen(int fd, const char *mode)
11000 {
11001   FILE *fp = fdopen(fd, mode);
11002
11003   if (fp) {
11004     unsigned int fdoff = fd / sizeof(unsigned int);
11005     Stat_t sbuf; /* native stat; we don't need flex_stat */
11006     if (!sockflagsize || fdoff > sockflagsize) {
11007       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11008       else           Newx  (sockflags,fdoff+2,unsigned int);
11009       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11010       sockflagsize = fdoff + 2;
11011     }
11012     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11013       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11014   }
11015   return fp;
11016
11017 }
11018 /*}}}*/
11019
11020
11021 /*
11022  * Clear the corresponding bit when the (possibly) socket stream is closed.
11023  * There still a small hole: we miss an implicit close which might occur
11024  * via freopen().  >> Todo
11025  */
11026 /*{{{ int my_fclose(FILE *fp)*/
11027 int my_fclose(FILE *fp) {
11028   if (fp) {
11029     unsigned int fd = fileno(fp);
11030     unsigned int fdoff = fd / sizeof(unsigned int);
11031
11032     if (sockflagsize && fdoff < sockflagsize)
11033       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11034   }
11035   return fclose(fp);
11036 }
11037 /*}}}*/
11038
11039
11040 /*
11041  * A simple fwrite replacement which outputs itmsz*nitm chars without
11042  * introducing record boundaries every itmsz chars.
11043  * We are using fputs, which depends on a terminating null.  We may
11044  * well be writing binary data, so we need to accommodate not only
11045  * data with nulls sprinkled in the middle but also data with no null
11046  * byte at the end.
11047  */
11048 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11049 int
11050 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11051 {
11052   char *cp, *end, *cpd;
11053   char *data;
11054   unsigned int fd = fileno(dest);
11055   unsigned int fdoff = fd / sizeof(unsigned int);
11056   int retval;
11057   int bufsize = itmsz * nitm + 1;
11058
11059   if (fdoff < sockflagsize &&
11060       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11061     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11062     return nitm;
11063   }
11064
11065   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11066   memcpy( data, src, itmsz*nitm );
11067   data[itmsz*nitm] = '\0';
11068
11069   end = data + itmsz * nitm;
11070   retval = (int) nitm; /* on success return # items written */
11071
11072   cpd = data;
11073   while (cpd <= end) {
11074     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11075     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11076     if (cp < end)
11077       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11078     cpd = cp + 1;
11079   }
11080
11081   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11082   return retval;
11083
11084 }  /* end of my_fwrite() */
11085 /*}}}*/
11086
11087 /*{{{ int my_flush(FILE *fp)*/
11088 int
11089 Perl_my_flush(pTHX_ FILE *fp)
11090 {
11091     int res;
11092     if ((res = fflush(fp)) == 0 && fp) {
11093 #ifdef VMS_DO_SOCKETS
11094         Stat_t s;
11095         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11096 #endif
11097             res = fsync(fileno(fp));
11098     }
11099 /*
11100  * If the flush succeeded but set end-of-file, we need to clear
11101  * the error because our caller may check ferror().  BTW, this
11102  * probably means we just flushed an empty file.
11103  */
11104     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11105
11106     return res;
11107 }
11108 /*}}}*/
11109
11110 /* fgetname() is not returning the correct file specifications when
11111  * decc_filename_unix_report mode is active.  So we have to have it
11112  * aways return filenames in VMS mode and convert it ourselves.
11113  */
11114
11115 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11116 char *
11117 Perl_my_fgetname(FILE *fp, char * buf) {
11118     char * retname;
11119     char * vms_name;
11120
11121     retname = fgetname(fp, buf, 1);
11122
11123     /* If we are in VMS mode, then we are done */
11124     if (!decc_filename_unix_report || (retname == NULL)) {
11125        return retname;
11126     }
11127
11128     /* Convert this to Unix format */
11129     vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11130     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11131     retname = int_tounixspec(vms_name, buf, NULL);
11132     PerlMem_free(vms_name);
11133
11134     return retname;
11135 }
11136 /*}}}*/
11137
11138 /*
11139  * Here are replacements for the following Unix routines in the VMS environment:
11140  *      getpwuid    Get information for a particular UIC or UID
11141  *      getpwnam    Get information for a named user
11142  *      getpwent    Get information for each user in the rights database
11143  *      setpwent    Reset search to the start of the rights database
11144  *      endpwent    Finish searching for users in the rights database
11145  *
11146  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11147  * (defined in pwd.h), which contains the following fields:-
11148  *      struct passwd {
11149  *              char        *pw_name;    Username (in lower case)
11150  *              char        *pw_passwd;  Hashed password
11151  *              unsigned int pw_uid;     UIC
11152  *              unsigned int pw_gid;     UIC group  number
11153  *              char        *pw_unixdir; Default device/directory (VMS-style)
11154  *              char        *pw_gecos;   Owner name
11155  *              char        *pw_dir;     Default device/directory (Unix-style)
11156  *              char        *pw_shell;   Default CLI name (eg. DCL)
11157  *      };
11158  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11159  *
11160  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11161  * not the UIC member number (eg. what's returned by getuid()),
11162  * getpwuid() can accept either as input (if uid is specified, the caller's
11163  * UIC group is used), though it won't recognise gid=0.
11164  *
11165  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11166  * information about other users in your group or in other groups, respectively.
11167  * If the required privilege is not available, then these routines fill only
11168  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11169  * string).
11170  *
11171  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11172  */
11173
11174 /* sizes of various UAF record fields */
11175 #define UAI$S_USERNAME 12
11176 #define UAI$S_IDENT    31
11177 #define UAI$S_OWNER    31
11178 #define UAI$S_DEFDEV   31
11179 #define UAI$S_DEFDIR   63
11180 #define UAI$S_DEFCLI   31
11181 #define UAI$S_PWD       8
11182
11183 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11184                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11185                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11186
11187 static char __empty[]= "";
11188 static struct passwd __passwd_empty=
11189     {(char *) __empty, (char *) __empty, 0, 0,
11190      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11191 static int contxt= 0;
11192 static struct passwd __pwdcache;
11193 static char __pw_namecache[UAI$S_IDENT+1];
11194
11195 /*
11196  * This routine does most of the work extracting the user information.
11197  */
11198 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11199 {
11200     static struct {
11201         unsigned char length;
11202         char pw_gecos[UAI$S_OWNER+1];
11203     } owner;
11204     static union uicdef uic;
11205     static struct {
11206         unsigned char length;
11207         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11208     } defdev;
11209     static struct {
11210         unsigned char length;
11211         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11212     } defdir;
11213     static struct {
11214         unsigned char length;
11215         char pw_shell[UAI$S_DEFCLI+1];
11216     } defcli;
11217     static char pw_passwd[UAI$S_PWD+1];
11218
11219     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11220     struct dsc$descriptor_s name_desc;
11221     unsigned long int sts;
11222
11223     static struct itmlst_3 itmlst[]= {
11224         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11225         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11226         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11227         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11228         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11229         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11230         {0,                0,           NULL,    NULL}};
11231
11232     name_desc.dsc$w_length=  strlen(name);
11233     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11234     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11235     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11236
11237 /*  Note that sys$getuai returns many fields as counted strings. */
11238     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11239     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11240       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11241     }
11242     else { _ckvmssts(sts); }
11243     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11244
11245     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11246     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11247     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11248     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11249     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11250     owner.pw_gecos[lowner]=            '\0';
11251     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11252     defcli.pw_shell[ldefcli]=          '\0';
11253     if (valid_uic(uic)) {
11254         pwd->pw_uid= uic.uic$l_uic;
11255         pwd->pw_gid= uic.uic$v_group;
11256     }
11257     else
11258       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11259     pwd->pw_passwd=  pw_passwd;
11260     pwd->pw_gecos=   owner.pw_gecos;
11261     pwd->pw_dir=     defdev.pw_dir;
11262     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11263     pwd->pw_shell=   defcli.pw_shell;
11264     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11265         int ldir;
11266         ldir= strlen(pwd->pw_unixdir) - 1;
11267         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11268     }
11269     else
11270         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11271     if (!decc_efs_case_preserve)
11272         __mystrtolower(pwd->pw_unixdir);
11273     return 1;
11274 }
11275
11276 /*
11277  * Get information for a named user.
11278 */
11279 /*{{{struct passwd *getpwnam(char *name)*/
11280 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11281 {
11282     struct dsc$descriptor_s name_desc;
11283     union uicdef uic;
11284     unsigned long int sts;
11285
11286     __pwdcache = __passwd_empty;
11287     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11288       /* We still may be able to determine pw_uid and pw_gid */
11289       name_desc.dsc$w_length=  strlen(name);
11290       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11291       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11292       name_desc.dsc$a_pointer= (char *) name;
11293       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11294         __pwdcache.pw_uid= uic.uic$l_uic;
11295         __pwdcache.pw_gid= uic.uic$v_group;
11296       }
11297       else {
11298         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11299           set_vaxc_errno(sts);
11300           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11301           return NULL;
11302         }
11303         else { _ckvmssts(sts); }
11304       }
11305     }
11306     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11307     __pwdcache.pw_name= __pw_namecache;
11308     return &__pwdcache;
11309 }  /* end of my_getpwnam() */
11310 /*}}}*/
11311
11312 /*
11313  * Get information for a particular UIC or UID.
11314  * Called by my_getpwent with uid=-1 to list all users.
11315 */
11316 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11317 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11318 {
11319     const $DESCRIPTOR(name_desc,__pw_namecache);
11320     unsigned short lname;
11321     union uicdef uic;
11322     unsigned long int status;
11323
11324     if (uid == (unsigned int) -1) {
11325       do {
11326         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11327         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11328           set_vaxc_errno(status);
11329           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11330           my_endpwent();
11331           return NULL;
11332         }
11333         else { _ckvmssts(status); }
11334       } while (!valid_uic (uic));
11335     }
11336     else {
11337       uic.uic$l_uic= uid;
11338       if (!uic.uic$v_group)
11339         uic.uic$v_group= PerlProc_getgid();
11340       if (valid_uic(uic))
11341         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11342       else status = SS$_IVIDENT;
11343       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11344           status == RMS$_PRV) {
11345         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11346         return NULL;
11347       }
11348       else { _ckvmssts(status); }
11349     }
11350     __pw_namecache[lname]= '\0';
11351     __mystrtolower(__pw_namecache);
11352
11353     __pwdcache = __passwd_empty;
11354     __pwdcache.pw_name = __pw_namecache;
11355
11356 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11357     The identifier's value is usually the UIC, but it doesn't have to be,
11358     so if we can, we let fillpasswd update this. */
11359     __pwdcache.pw_uid =  uic.uic$l_uic;
11360     __pwdcache.pw_gid =  uic.uic$v_group;
11361
11362     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11363     return &__pwdcache;
11364
11365 }  /* end of my_getpwuid() */
11366 /*}}}*/
11367
11368 /*
11369  * Get information for next user.
11370 */
11371 /*{{{struct passwd *my_getpwent()*/
11372 struct passwd *Perl_my_getpwent(pTHX)
11373 {
11374     return (my_getpwuid((unsigned int) -1));
11375 }
11376 /*}}}*/
11377
11378 /*
11379  * Finish searching rights database for users.
11380 */
11381 /*{{{void my_endpwent()*/
11382 void Perl_my_endpwent(pTHX)
11383 {
11384     if (contxt) {
11385       _ckvmssts(sys$finish_rdb(&contxt));
11386       contxt= 0;
11387     }
11388 }
11389 /*}}}*/
11390
11391 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11392  * my_utime(), and flex_stat(), all of which operate on UTC unless
11393  * VMSISH_TIMES is true.
11394  */
11395 /* method used to handle UTC conversions:
11396  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11397  */
11398 static int gmtime_emulation_type;
11399 /* number of secs to add to UTC POSIX-style time to get local time */
11400 static long int utc_offset_secs;
11401
11402 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11403  * in vmsish.h.  #undef them here so we can call the CRTL routines
11404  * directly.
11405  */
11406 #undef gmtime
11407 #undef localtime
11408 #undef time
11409
11410
11411 static time_t toutc_dst(time_t loc) {
11412   struct tm *rsltmp;
11413
11414   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11415   loc -= utc_offset_secs;
11416   if (rsltmp->tm_isdst) loc -= 3600;
11417   return loc;
11418 }
11419 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11420        ((gmtime_emulation_type || my_time(NULL)), \
11421        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11422        ((secs) - utc_offset_secs))))
11423
11424 static time_t toloc_dst(time_t utc) {
11425   struct tm *rsltmp;
11426
11427   utc += utc_offset_secs;
11428   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11429   if (rsltmp->tm_isdst) utc += 3600;
11430   return utc;
11431 }
11432 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11433        ((gmtime_emulation_type || my_time(NULL)), \
11434        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11435        ((secs) + utc_offset_secs))))
11436
11437 /* my_time(), my_localtime(), my_gmtime()
11438  * By default traffic in UTC time values, using CRTL gmtime() or
11439  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11440  * Note: We need to use these functions even when the CRTL has working
11441  * UTC support, since they also handle C<use vmsish qw(times);>
11442  *
11443  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11444  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11445  */
11446
11447 /*{{{time_t my_time(time_t *timep)*/
11448 time_t Perl_my_time(pTHX_ time_t *timep)
11449 {
11450   time_t when;
11451   struct tm *tm_p;
11452
11453   if (gmtime_emulation_type == 0) {
11454     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11455                               /* results of calls to gmtime() and localtime() */
11456                               /* for same &base */
11457
11458     gmtime_emulation_type++;
11459     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11460       char off[LNM$C_NAMLENGTH+1];;
11461
11462       gmtime_emulation_type++;
11463       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11464         gmtime_emulation_type++;
11465         utc_offset_secs = 0;
11466         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11467       }
11468       else { utc_offset_secs = atol(off); }
11469     }
11470     else { /* We've got a working gmtime() */
11471       struct tm gmt, local;
11472
11473       gmt = *tm_p;
11474       tm_p = localtime(&base);
11475       local = *tm_p;
11476       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11477       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11478       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11479       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11480     }
11481   }
11482
11483   when = time(NULL);
11484 # ifdef VMSISH_TIME
11485   if (VMSISH_TIME) when = _toloc(when);
11486 # endif
11487   if (timep != NULL) *timep = when;
11488   return when;
11489
11490 }  /* end of my_time() */
11491 /*}}}*/
11492
11493
11494 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11495 struct tm *
11496 Perl_my_gmtime(pTHX_ const time_t *timep)
11497 {
11498   time_t when;
11499   struct tm *rsltmp;
11500
11501   if (timep == NULL) {
11502     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11503     return NULL;
11504   }
11505   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11506
11507   when = *timep;
11508 # ifdef VMSISH_TIME
11509   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11510 #  endif
11511   return gmtime(&when);
11512 }  /* end of my_gmtime() */
11513 /*}}}*/
11514
11515
11516 /*{{{struct tm *my_localtime(const time_t *timep)*/
11517 struct tm *
11518 Perl_my_localtime(pTHX_ const time_t *timep)
11519 {
11520   time_t when;
11521
11522   if (timep == NULL) {
11523     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11524     return NULL;
11525   }
11526   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11527   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11528
11529   when = *timep;
11530 # ifdef VMSISH_TIME
11531   if (VMSISH_TIME) when = _toutc(when);
11532 # endif
11533   /* CRTL localtime() wants UTC as input, does tz correction itself */
11534   return localtime(&when);
11535 } /*  end of my_localtime() */
11536 /*}}}*/
11537
11538 /* Reset definitions for later calls */
11539 #define gmtime(t)    my_gmtime(t)
11540 #define localtime(t) my_localtime(t)
11541 #define time(t)      my_time(t)
11542
11543
11544 /* my_utime - update modification/access time of a file
11545  *
11546  * VMS 7.3 and later implementation
11547  * Only the UTC translation is home-grown. The rest is handled by the
11548  * CRTL utime(), which will take into account the relevant feature
11549  * logicals and ODS-5 volume characteristics for true access times.
11550  *
11551  * pre VMS 7.3 implementation:
11552  * The calling sequence is identical to POSIX utime(), but under
11553  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11554  * not maintain access times.  Restrictions differ from the POSIX
11555  * definition in that the time can be changed as long as the
11556  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11557  * no separate checks are made to insure that the caller is the
11558  * owner of the file or has special privs enabled.
11559  * Code here is based on Joe Meadows' FILE utility.
11560  *
11561  */
11562
11563 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11564  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11565  * in 100 ns intervals.
11566  */
11567 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11568
11569 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11570 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11571 {
11572 #if __CRTL_VER >= 70300000
11573   struct utimbuf utc_utimes, *utc_utimesp;
11574
11575   if (utimes != NULL) {
11576     utc_utimes.actime = utimes->actime;
11577     utc_utimes.modtime = utimes->modtime;
11578 # ifdef VMSISH_TIME
11579     /* If input was local; convert to UTC for sys svc */
11580     if (VMSISH_TIME) {
11581       utc_utimes.actime = _toutc(utimes->actime);
11582       utc_utimes.modtime = _toutc(utimes->modtime);
11583     }
11584 # endif
11585     utc_utimesp = &utc_utimes;
11586   }
11587   else {
11588     utc_utimesp = NULL;
11589   }
11590
11591   return utime(file, utc_utimesp);
11592
11593 #else /* __CRTL_VER < 70300000 */
11594
11595   int i;
11596   int sts;
11597   long int bintime[2], len = 2, lowbit, unixtime,
11598            secscale = 10000000; /* seconds --> 100 ns intervals */
11599   unsigned long int chan, iosb[2], retsts;
11600   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11601   struct FAB myfab = cc$rms_fab;
11602   struct NAM mynam = cc$rms_nam;
11603 #if defined (__DECC) && defined (__VAX)
11604   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11605    * at least through VMS V6.1, which causes a type-conversion warning.
11606    */
11607 #  pragma message save
11608 #  pragma message disable cvtdiftypes
11609 #endif
11610   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11611   struct fibdef myfib;
11612 #if defined (__DECC) && defined (__VAX)
11613   /* This should be right after the declaration of myatr, but due
11614    * to a bug in VAX DEC C, this takes effect a statement early.
11615    */
11616 #  pragma message restore
11617 #endif
11618   /* cast ok for read only parameter */
11619   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11620                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11621                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11622
11623   if (file == NULL || *file == '\0') {
11624     SETERRNO(ENOENT, LIB$_INVARG);
11625     return -1;
11626   }
11627
11628   /* Convert to VMS format ensuring that it will fit in 255 characters */
11629   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11630       SETERRNO(ENOENT, LIB$_INVARG);
11631       return -1;
11632   }
11633   if (utimes != NULL) {
11634     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11635      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11636      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11637      * as input, we force the sign bit to be clear by shifting unixtime right
11638      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11639      */
11640     lowbit = (utimes->modtime & 1) ? secscale : 0;
11641     unixtime = (long int) utimes->modtime;
11642 #   ifdef VMSISH_TIME
11643     /* If input was UTC; convert to local for sys svc */
11644     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11645 #   endif
11646     unixtime >>= 1;  secscale <<= 1;
11647     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11648     if (!(retsts & 1)) {
11649       SETERRNO(EVMSERR, retsts);
11650       return -1;
11651     }
11652     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11653     if (!(retsts & 1)) {
11654       SETERRNO(EVMSERR, retsts);
11655       return -1;
11656     }
11657   }
11658   else {
11659     /* Just get the current time in VMS format directly */
11660     retsts = sys$gettim(bintime);
11661     if (!(retsts & 1)) {
11662       SETERRNO(EVMSERR, retsts);
11663       return -1;
11664     }
11665   }
11666
11667   myfab.fab$l_fna = vmsspec;
11668   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11669   myfab.fab$l_nam = &mynam;
11670   mynam.nam$l_esa = esa;
11671   mynam.nam$b_ess = (unsigned char) sizeof esa;
11672   mynam.nam$l_rsa = rsa;
11673   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11674   if (decc_efs_case_preserve)
11675       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11676
11677   /* Look for the file to be affected, letting RMS parse the file
11678    * specification for us as well.  I have set errno using only
11679    * values documented in the utime() man page for VMS POSIX.
11680    */
11681   retsts = sys$parse(&myfab,0,0);
11682   if (!(retsts & 1)) {
11683     set_vaxc_errno(retsts);
11684     if      (retsts == RMS$_PRV) set_errno(EACCES);
11685     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11686     else                         set_errno(EVMSERR);
11687     return -1;
11688   }
11689   retsts = sys$search(&myfab,0,0);
11690   if (!(retsts & 1)) {
11691     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11692     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11693     set_vaxc_errno(retsts);
11694     if      (retsts == RMS$_PRV) set_errno(EACCES);
11695     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11696     else                         set_errno(EVMSERR);
11697     return -1;
11698   }
11699
11700   devdsc.dsc$w_length = mynam.nam$b_dev;
11701   /* cast ok for read only parameter */
11702   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11703
11704   retsts = sys$assign(&devdsc,&chan,0,0);
11705   if (!(retsts & 1)) {
11706     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11707     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11708     set_vaxc_errno(retsts);
11709     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11710     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11711     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11712     else                               set_errno(EVMSERR);
11713     return -1;
11714   }
11715
11716   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11717   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11718
11719   memset((void *) &myfib, 0, sizeof myfib);
11720 #if defined(__DECC) || defined(__DECCXX)
11721   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11722   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11723   /* This prevents the revision time of the file being reset to the current
11724    * time as a result of our IO$_MODIFY $QIO. */
11725   myfib.fib$l_acctl = FIB$M_NORECORD;
11726 #else
11727   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11728   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11729   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11730 #endif
11731   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11732   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11733   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11734   _ckvmssts(sys$dassgn(chan));
11735   if (retsts & 1) retsts = iosb[0];
11736   if (!(retsts & 1)) {
11737     set_vaxc_errno(retsts);
11738     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11739     else                      set_errno(EVMSERR);
11740     return -1;
11741   }
11742
11743   return 0;
11744
11745 #endif /* #if __CRTL_VER >= 70300000 */
11746
11747 }  /* end of my_utime() */
11748 /*}}}*/
11749
11750 /*
11751  * flex_stat, flex_lstat, flex_fstat
11752  * basic stat, but gets it right when asked to stat
11753  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11754  */
11755
11756 #ifndef _USE_STD_STAT
11757 /* encode_dev packs a VMS device name string into an integer to allow
11758  * simple comparisons. This can be used, for example, to check whether two
11759  * files are located on the same device, by comparing their encoded device
11760  * names. Even a string comparison would not do, because stat() reuses the
11761  * device name buffer for each call; so without encode_dev, it would be
11762  * necessary to save the buffer and use strcmp (this would mean a number of
11763  * changes to the standard Perl code, to say nothing of what a Perl script
11764  * would have to do.
11765  *
11766  * The device lock id, if it exists, should be unique (unless perhaps compared
11767  * with lock ids transferred from other nodes). We have a lock id if the disk is
11768  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11769  * device names. Thus we use the lock id in preference, and only if that isn't
11770  * available, do we try to pack the device name into an integer (flagged by
11771  * the sign bit (LOCKID_MASK) being set).
11772  *
11773  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11774  * name and its encoded form, but it seems very unlikely that we will find
11775  * two files on different disks that share the same encoded device names,
11776  * and even more remote that they will share the same file id (if the test
11777  * is to check for the same file).
11778  *
11779  * A better method might be to use sys$device_scan on the first call, and to
11780  * search for the device, returning an index into the cached array.
11781  * The number returned would be more intelligible.
11782  * This is probably not worth it, and anyway would take quite a bit longer
11783  * on the first call.
11784  */
11785 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11786 static mydev_t encode_dev (pTHX_ const char *dev)
11787 {
11788   int i;
11789   unsigned long int f;
11790   mydev_t enc;
11791   char c;
11792   const char *q;
11793
11794   if (!dev || !dev[0]) return 0;
11795
11796 #if LOCKID_MASK
11797   {
11798     struct dsc$descriptor_s dev_desc;
11799     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11800
11801     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11802        can try that first. */
11803     dev_desc.dsc$w_length =  strlen (dev);
11804     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11805     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11806     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11807     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11808     if (!$VMS_STATUS_SUCCESS(status)) {
11809       switch (status) {
11810         case SS$_NOSUCHDEV:
11811           SETERRNO(ENODEV, status);
11812           return 0;
11813         default:
11814           _ckvmssts(status);
11815       }
11816     }
11817     if (lockid) return (lockid & ~LOCKID_MASK);
11818   }
11819 #endif
11820
11821   /* Otherwise we try to encode the device name */
11822   enc = 0;
11823   f = 1;
11824   i = 0;
11825   for (q = dev + strlen(dev); q--; q >= dev) {
11826     if (*q == ':')
11827         break;
11828     if (isdigit (*q))
11829       c= (*q) - '0';
11830     else if (isalpha (toupper (*q)))
11831       c= toupper (*q) - 'A' + (char)10;
11832     else
11833       continue; /* Skip '$'s */
11834     i++;
11835     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11836     if (i>1) f *= 36;
11837     enc += f * (unsigned long int) c;
11838   }
11839   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11840
11841 }  /* end of encode_dev() */
11842 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11843         device_no = encode_dev(aTHX_ devname)
11844 #else
11845 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11846         device_no = new_dev_no
11847 #endif
11848
11849 static int
11850 is_null_device(const char *name)
11851 {
11852   if (decc_bug_devnull != 0) {
11853     if (strncmp("/dev/null", name, 9) == 0)
11854       return 1;
11855   }
11856     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11857        The underscore prefix, controller letter, and unit number are
11858        independently optional; for our purposes, the colon punctuation
11859        is not.  The colon can be trailed by optional directory and/or
11860        filename, but two consecutive colons indicates a nodename rather
11861        than a device.  [pr]  */
11862   if (*name == '_') ++name;
11863   if (tolower(*name++) != 'n') return 0;
11864   if (tolower(*name++) != 'l') return 0;
11865   if (tolower(*name) == 'a') ++name;
11866   if (*name == '0') ++name;
11867   return (*name++ == ':') && (*name != ':');
11868 }
11869
11870 static int
11871 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11872
11873 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11874
11875 static I32
11876 Perl_cando_by_name_int
11877    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11878 {
11879   char usrname[L_cuserid];
11880   struct dsc$descriptor_s usrdsc =
11881          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11882   char *vmsname = NULL, *fileified = NULL;
11883   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11884   unsigned short int retlen, trnlnm_iter_count;
11885   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11886   union prvdef curprv;
11887   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11888          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11889          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11890   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11891          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11892          {0,0,0,0}};
11893   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11894          {0,0,0,0}};
11895   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11896   Stat_t st;
11897   static int profile_context = -1;
11898
11899   if (!fname || !*fname) return FALSE;
11900
11901   /* Make sure we expand logical names, since sys$check_access doesn't */
11902   fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11903   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11904   if (!strpbrk(fname,"/]>:")) {
11905       my_strlcpy(fileified, fname, VMS_MAXRSS);
11906       trnlnm_iter_count = 0;
11907       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11908         trnlnm_iter_count++;
11909         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11910       }
11911       fname = fileified;
11912   }
11913
11914   vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11915   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11916   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11917     /* Don't know if already in VMS format, so make sure */
11918     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11919       PerlMem_free(fileified);
11920       PerlMem_free(vmsname);
11921       return FALSE;
11922     }
11923   }
11924   else {
11925     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11926   }
11927
11928   /* sys$check_access needs a file spec, not a directory spec.
11929    * flex_stat now will handle a null thread context during startup.
11930    */
11931
11932   retlen = namdsc.dsc$w_length = strlen(vmsname);
11933   if (vmsname[retlen-1] == ']'
11934       || vmsname[retlen-1] == '>'
11935       || vmsname[retlen-1] == ':'
11936       || (!flex_stat_int(vmsname, &st, 1) &&
11937           S_ISDIR(st.st_mode))) {
11938
11939       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11940         PerlMem_free(fileified);
11941         PerlMem_free(vmsname);
11942         return FALSE;
11943       }
11944       fname = fileified;
11945   }
11946   else {
11947       fname = vmsname;
11948   }
11949
11950   retlen = namdsc.dsc$w_length = strlen(fname);
11951   namdsc.dsc$a_pointer = (char *)fname;
11952
11953   switch (bit) {
11954     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11955       access = ARM$M_EXECUTE;
11956       flags = CHP$M_READ;
11957       break;
11958     case S_IRUSR: case S_IRGRP: case S_IROTH:
11959       access = ARM$M_READ;
11960       flags = CHP$M_READ | CHP$M_USEREADALL;
11961       break;
11962     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11963       access = ARM$M_WRITE;
11964       flags = CHP$M_READ | CHP$M_WRITE;
11965       break;
11966     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11967       access = ARM$M_DELETE;
11968       flags = CHP$M_READ | CHP$M_WRITE;
11969       break;
11970     default:
11971       if (fileified != NULL)
11972         PerlMem_free(fileified);
11973       if (vmsname != NULL)
11974         PerlMem_free(vmsname);
11975       return FALSE;
11976   }
11977
11978   /* Before we call $check_access, create a user profile with the current
11979    * process privs since otherwise it just uses the default privs from the
11980    * UAF and might give false positives or negatives.  This only works on
11981    * VMS versions v6.0 and later since that's when sys$create_user_profile
11982    * became available.
11983    */
11984
11985   /* get current process privs and username */
11986   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11987   _ckvmssts_noperl(iosb[0]);
11988
11989   /* find out the space required for the profile */
11990   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11991                                     &usrprodsc.dsc$w_length,&profile_context));
11992
11993   /* allocate space for the profile and get it filled in */
11994   usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
11995   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11996   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11997                                     &usrprodsc.dsc$w_length,&profile_context));
11998
11999   /* use the profile to check access to the file; free profile & analyze results */
12000   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12001   PerlMem_free(usrprodsc.dsc$a_pointer);
12002   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12003
12004   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12005       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12006       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12007     set_vaxc_errno(retsts);
12008     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12009     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12010     else set_errno(ENOENT);
12011     if (fileified != NULL)
12012       PerlMem_free(fileified);
12013     if (vmsname != NULL)
12014       PerlMem_free(vmsname);
12015     return FALSE;
12016   }
12017   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12018     if (fileified != NULL)
12019       PerlMem_free(fileified);
12020     if (vmsname != NULL)
12021       PerlMem_free(vmsname);
12022     return TRUE;
12023   }
12024   _ckvmssts_noperl(retsts);
12025
12026   if (fileified != NULL)
12027     PerlMem_free(fileified);
12028   if (vmsname != NULL)
12029     PerlMem_free(vmsname);
12030   return FALSE;  /* Should never get here */
12031
12032 }
12033
12034 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12035 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12036  * subset of the applicable information.
12037  */
12038 bool
12039 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12040 {
12041   return cando_by_name_int
12042         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12043 }  /* end of cando() */
12044 /*}}}*/
12045
12046
12047 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12048 I32
12049 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12050 {
12051    return cando_by_name_int(bit, effective, fname, 0);
12052
12053 }  /* end of cando_by_name() */
12054 /*}}}*/
12055
12056
12057 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12058 int
12059 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12060 {
12061   if (!fstat(fd, &statbufp->crtl_stat)) {
12062     char *cptr;
12063     char *vms_filename;
12064     vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12065     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12066
12067     /* Save name for cando by name in VMS format */
12068     cptr = getname(fd, vms_filename, 1);
12069
12070     /* This should not happen, but just in case */
12071     if (cptr == NULL) {
12072         statbufp->st_devnam[0] = 0;
12073     }
12074     else {
12075         /* Make sure that the saved name fits in 255 characters */
12076         cptr = int_rmsexpand_vms
12077                        (vms_filename,
12078                         statbufp->st_devnam,
12079                         0);
12080         if (cptr == NULL)
12081             statbufp->st_devnam[0] = 0;
12082     }
12083     PerlMem_free(vms_filename);
12084
12085     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12086     VMS_DEVICE_ENCODE
12087         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12088
12089 #   ifdef VMSISH_TIME
12090     if (VMSISH_TIME) {
12091       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12092       statbufp->st_atime = _toloc(statbufp->st_atime);
12093       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12094     }
12095 #   endif
12096     return 0;
12097   }
12098   return -1;
12099
12100 }  /* end of flex_fstat() */
12101 /*}}}*/
12102
12103 static int
12104 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12105 {
12106     char *temp_fspec = NULL;
12107     char *fileified = NULL;
12108     const char *save_spec;
12109     char *ret_spec;
12110     int retval = -1;
12111     char efs_hack = 0;
12112     char already_fileified = 0;
12113     dSAVEDERRNO;
12114
12115     if (!fspec) {
12116         errno = EINVAL;
12117         return retval;
12118     }
12119
12120     if (decc_bug_devnull != 0) {
12121       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12122         memset(statbufp,0,sizeof *statbufp);
12123         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12124         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12125         statbufp->st_uid = 0x00010001;
12126         statbufp->st_gid = 0x0001;
12127         time((time_t *)&statbufp->st_mtime);
12128         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12129         return 0;
12130       }
12131     }
12132
12133     SAVE_ERRNO;
12134
12135 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12136   /*
12137    * If we are in POSIX filespec mode, accept the filename as is.
12138    */
12139   if (decc_posix_compliant_pathnames == 0) {
12140 #endif
12141
12142     /* Try for a simple stat first.  If fspec contains a filename without
12143      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12144      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12145      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12146      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12147      * the file with null type, specify this by calling flex_stat() with
12148      * a '.' at the end of fspec.
12149      */
12150
12151     if (lstat_flag == 0)
12152         retval = stat(fspec, &statbufp->crtl_stat);
12153     else
12154         retval = lstat(fspec, &statbufp->crtl_stat);
12155
12156     if (!retval) {
12157         save_spec = fspec;
12158     }
12159     else {
12160         /* In the odd case where we have write but not read access
12161          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12162          */
12163         fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12164         if (fileified == NULL)
12165               _ckvmssts_noperl(SS$_INSFMEM);
12166
12167         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12168         if (ret_spec != NULL) {
12169             if (lstat_flag == 0)
12170                 retval = stat(fileified, &statbufp->crtl_stat);
12171             else
12172                 retval = lstat(fileified, &statbufp->crtl_stat);
12173             save_spec = fileified;
12174             already_fileified = 1;
12175         }
12176     }
12177
12178     if (retval && vms_bug_stat_filename) {
12179
12180         temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12181         if (temp_fspec == NULL)
12182             _ckvmssts_noperl(SS$_INSFMEM);
12183
12184         /* We should try again as a vmsified file specification. */
12185
12186         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12187         if (ret_spec != NULL) {
12188             if (lstat_flag == 0)
12189                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12190             else
12191                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12192             save_spec = temp_fspec;
12193         }
12194     }
12195
12196     if (retval) {
12197         /* Last chance - allow multiple dots without EFS CHARSET */
12198         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12199          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12200          * enable it if it isn't already.
12201          */
12202 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12203         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12204             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12205 #endif
12206         if (lstat_flag == 0)
12207             retval = stat(fspec, &statbufp->crtl_stat);
12208         else
12209             retval = lstat(fspec, &statbufp->crtl_stat);
12210         save_spec = fspec;
12211 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12212         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12213             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12214             efs_hack = 1;
12215         }
12216 #endif
12217     }
12218
12219 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12220   } else {
12221     if (lstat_flag == 0)
12222       retval = stat(temp_fspec, &statbufp->crtl_stat);
12223     else
12224       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12225       save_spec = temp_fspec;
12226   }
12227 #endif
12228
12229 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12230   /* As you were... */
12231   if (!decc_efs_charset)
12232     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12233 #endif
12234
12235     if (!retval) {
12236       char *cptr;
12237       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12238
12239       /* If this is an lstat, do not follow the link */
12240       if (lstat_flag)
12241         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12242
12243 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12244       /* If we used the efs_hack above, we must also use it here for */
12245       /* perl_cando to work */
12246       if (efs_hack && (decc_efs_charset_index > 0)) {
12247           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12248       }
12249 #endif
12250
12251       /* If we've got a directory, save a fileified, expanded version of it
12252        * in st_devnam.  If not a directory, just an expanded version.
12253        */
12254       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12255           fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12256           if (fileified == NULL)
12257               _ckvmssts_noperl(SS$_INSFMEM);
12258
12259           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12260           if (cptr != NULL)
12261               save_spec = fileified;
12262       }
12263
12264       cptr = int_rmsexpand(save_spec,
12265                            statbufp->st_devnam,
12266                            NULL,
12267                            rmsex_flags,
12268                            0,
12269                            0);
12270
12271 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12272       if (efs_hack && (decc_efs_charset_index > 0)) {
12273           decc$feature_set_value(decc_efs_charset, 1, 0);
12274       }
12275 #endif
12276
12277       /* Fix me: If this is NULL then stat found a file, and we could */
12278       /* not convert the specification to VMS - Should never happen */
12279       if (cptr == NULL)
12280         statbufp->st_devnam[0] = 0;
12281
12282       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12283       VMS_DEVICE_ENCODE
12284         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12285 #     ifdef VMSISH_TIME
12286       if (VMSISH_TIME) {
12287         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12288         statbufp->st_atime = _toloc(statbufp->st_atime);
12289         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12290       }
12291 #     endif
12292     }
12293     /* If we were successful, leave errno where we found it */
12294     if (retval == 0) RESTORE_ERRNO;
12295     if (temp_fspec)
12296         PerlMem_free(temp_fspec);
12297     if (fileified)
12298         PerlMem_free(fileified);
12299     return retval;
12300
12301 }  /* end of flex_stat_int() */
12302
12303
12304 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12305 int
12306 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12307 {
12308    return flex_stat_int(fspec, statbufp, 0);
12309 }
12310 /*}}}*/
12311
12312 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12313 int
12314 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12315 {
12316    return flex_stat_int(fspec, statbufp, 1);
12317 }
12318 /*}}}*/
12319
12320
12321 /*{{{char *my_getlogin()*/
12322 /* VMS cuserid == Unix getlogin, except calling sequence */
12323 char *
12324 my_getlogin(void)
12325 {
12326     static char user[L_cuserid];
12327     return cuserid(user);
12328 }
12329 /*}}}*/
12330
12331
12332 /*  rmscopy - copy a file using VMS RMS routines
12333  *
12334  *  Copies contents and attributes of spec_in to spec_out, except owner
12335  *  and protection information.  Name and type of spec_in are used as
12336  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12337  *  should try to propagate timestamps from the input file to the output file.
12338  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12339  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12340  *  propagated to the output file at creation iff the output file specification
12341  *  did not contain an explicit name or type, and the revision date is always
12342  *  updated at the end of the copy operation.  If it is greater than 0, then
12343  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12344  *  other than the revision date should be propagated, and bit 1 indicates
12345  *  that the revision date should be propagated.
12346  *
12347  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12348  *
12349  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12350  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12351  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12352  * as part of the Perl standard distribution under the terms of the
12353  * GNU General Public License or the Perl Artistic License.  Copies
12354  * of each may be found in the Perl standard distribution.
12355  */ /* FIXME */
12356 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12357 int
12358 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12359 {
12360     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12361          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12362     unsigned long int sts;
12363     int dna_len;
12364     struct FAB fab_in, fab_out;
12365     struct RAB rab_in, rab_out;
12366     rms_setup_nam(nam);
12367     rms_setup_nam(nam_out);
12368     struct XABDAT xabdat;
12369     struct XABFHC xabfhc;
12370     struct XABRDT xabrdt;
12371     struct XABSUM xabsum;
12372
12373     vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12374     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12375     vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12376     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12377     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12378         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12379       PerlMem_free(vmsin);
12380       PerlMem_free(vmsout);
12381       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12382       return 0;
12383     }
12384
12385     esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12386     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12387     esal = NULL;
12388 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12389     esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12390     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12391 #endif
12392     fab_in = cc$rms_fab;
12393     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12394     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12395     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12396     fab_in.fab$l_fop = FAB$M_SQO;
12397     rms_bind_fab_nam(fab_in, nam);
12398     fab_in.fab$l_xab = (void *) &xabdat;
12399
12400     rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12401     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12402     rsal = NULL;
12403 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12404     rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12405     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12406 #endif
12407     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12408     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12409     rms_nam_esl(nam) = 0;
12410     rms_nam_rsl(nam) = 0;
12411     rms_nam_esll(nam) = 0;
12412     rms_nam_rsll(nam) = 0;
12413 #ifdef NAM$M_NO_SHORT_UPCASE
12414     if (decc_efs_case_preserve)
12415         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12416 #endif
12417
12418     xabdat = cc$rms_xabdat;        /* To get creation date */
12419     xabdat.xab$l_nxt = (void *) &xabfhc;
12420
12421     xabfhc = cc$rms_xabfhc;        /* To get record length */
12422     xabfhc.xab$l_nxt = (void *) &xabsum;
12423
12424     xabsum = cc$rms_xabsum;        /* To get key and area information */
12425
12426     if (!((sts = sys$open(&fab_in)) & 1)) {
12427       PerlMem_free(vmsin);
12428       PerlMem_free(vmsout);
12429       PerlMem_free(esa);
12430       if (esal != NULL)
12431         PerlMem_free(esal);
12432       PerlMem_free(rsa);
12433       if (rsal != NULL)
12434         PerlMem_free(rsal);
12435       set_vaxc_errno(sts);
12436       switch (sts) {
12437         case RMS$_FNF: case RMS$_DNF:
12438           set_errno(ENOENT); break;
12439         case RMS$_DIR:
12440           set_errno(ENOTDIR); break;
12441         case RMS$_DEV:
12442           set_errno(ENODEV); break;
12443         case RMS$_SYN:
12444           set_errno(EINVAL); break;
12445         case RMS$_PRV:
12446           set_errno(EACCES); break;
12447         default:
12448           set_errno(EVMSERR);
12449       }
12450       return 0;
12451     }
12452
12453     nam_out = nam;
12454     fab_out = fab_in;
12455     fab_out.fab$w_ifi = 0;
12456     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12457     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12458     fab_out.fab$l_fop = FAB$M_SQO;
12459     rms_bind_fab_nam(fab_out, nam_out);
12460     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12461     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12462     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12463     esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12464     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12465     rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12466     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12467     esal_out = NULL;
12468     rsal_out = NULL;
12469 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12470     esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12471     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12472     rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12473     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12474 #endif
12475     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12476     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12477
12478     if (preserve_dates == 0) {  /* Act like DCL COPY */
12479       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12480       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12481       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12482         PerlMem_free(vmsin);
12483         PerlMem_free(vmsout);
12484         PerlMem_free(esa);
12485         if (esal != NULL)
12486             PerlMem_free(esal);
12487         PerlMem_free(rsa);
12488         if (rsal != NULL)
12489             PerlMem_free(rsal);
12490         PerlMem_free(esa_out);
12491         if (esal_out != NULL)
12492             PerlMem_free(esal_out);
12493         PerlMem_free(rsa_out);
12494         if (rsal_out != NULL)
12495             PerlMem_free(rsal_out);
12496         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12497         set_vaxc_errno(sts);
12498         return 0;
12499       }
12500       fab_out.fab$l_xab = (void *) &xabdat;
12501       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12502         preserve_dates = 1;
12503     }
12504     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12505       preserve_dates =0;      /* bitmask from this point forward   */
12506
12507     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12508     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12509       PerlMem_free(vmsin);
12510       PerlMem_free(vmsout);
12511       PerlMem_free(esa);
12512       if (esal != NULL)
12513           PerlMem_free(esal);
12514       PerlMem_free(rsa);
12515       if (rsal != NULL)
12516           PerlMem_free(rsal);
12517       PerlMem_free(esa_out);
12518       if (esal_out != NULL)
12519           PerlMem_free(esal_out);
12520       PerlMem_free(rsa_out);
12521       if (rsal_out != NULL)
12522           PerlMem_free(rsal_out);
12523       set_vaxc_errno(sts);
12524       switch (sts) {
12525         case RMS$_DNF:
12526           set_errno(ENOENT); break;
12527         case RMS$_DIR:
12528           set_errno(ENOTDIR); break;
12529         case RMS$_DEV:
12530           set_errno(ENODEV); break;
12531         case RMS$_SYN:
12532           set_errno(EINVAL); break;
12533         case RMS$_PRV:
12534           set_errno(EACCES); break;
12535         default:
12536           set_errno(EVMSERR);
12537       }
12538       return 0;
12539     }
12540     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12541     if (preserve_dates & 2) {
12542       /* sys$close() will process xabrdt, not xabdat */
12543       xabrdt = cc$rms_xabrdt;
12544 #ifndef __GNUC__
12545       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12546 #else
12547       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12548        * is unsigned long[2], while DECC & VAXC use a struct */
12549       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12550 #endif
12551       fab_out.fab$l_xab = (void *) &xabrdt;
12552     }
12553
12554     ubf = (char *)PerlMem_malloc(32256);
12555     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12556     rab_in = cc$rms_rab;
12557     rab_in.rab$l_fab = &fab_in;
12558     rab_in.rab$l_rop = RAB$M_BIO;
12559     rab_in.rab$l_ubf = ubf;
12560     rab_in.rab$w_usz = 32256;
12561     if (!((sts = sys$connect(&rab_in)) & 1)) {
12562       sys$close(&fab_in); sys$close(&fab_out);
12563       PerlMem_free(vmsin);
12564       PerlMem_free(vmsout);
12565       PerlMem_free(ubf);
12566       PerlMem_free(esa);
12567       if (esal != NULL)
12568           PerlMem_free(esal);
12569       PerlMem_free(rsa);
12570       if (rsal != NULL)
12571           PerlMem_free(rsal);
12572       PerlMem_free(esa_out);
12573       if (esal_out != NULL)
12574           PerlMem_free(esal_out);
12575       PerlMem_free(rsa_out);
12576       if (rsal_out != NULL)
12577           PerlMem_free(rsal_out);
12578       set_errno(EVMSERR); set_vaxc_errno(sts);
12579       return 0;
12580     }
12581
12582     rab_out = cc$rms_rab;
12583     rab_out.rab$l_fab = &fab_out;
12584     rab_out.rab$l_rbf = ubf;
12585     if (!((sts = sys$connect(&rab_out)) & 1)) {
12586       sys$close(&fab_in); sys$close(&fab_out);
12587       PerlMem_free(vmsin);
12588       PerlMem_free(vmsout);
12589       PerlMem_free(ubf);
12590       PerlMem_free(esa);
12591       if (esal != NULL)
12592           PerlMem_free(esal);
12593       PerlMem_free(rsa);
12594       if (rsal != NULL)
12595           PerlMem_free(rsal);
12596       PerlMem_free(esa_out);
12597       if (esal_out != NULL)
12598           PerlMem_free(esal_out);
12599       PerlMem_free(rsa_out);
12600       if (rsal_out != NULL)
12601           PerlMem_free(rsal_out);
12602       set_errno(EVMSERR); set_vaxc_errno(sts);
12603       return 0;
12604     }
12605
12606     while ((sts = sys$read(&rab_in))) {  /* always true  */
12607       if (sts == RMS$_EOF) break;
12608       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12609       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12610         sys$close(&fab_in); sys$close(&fab_out);
12611         PerlMem_free(vmsin);
12612         PerlMem_free(vmsout);
12613         PerlMem_free(ubf);
12614         PerlMem_free(esa);
12615         if (esal != NULL)
12616             PerlMem_free(esal);
12617         PerlMem_free(rsa);
12618         if (rsal != NULL)
12619             PerlMem_free(rsal);
12620         PerlMem_free(esa_out);
12621         if (esal_out != NULL)
12622             PerlMem_free(esal_out);
12623         PerlMem_free(rsa_out);
12624         if (rsal_out != NULL)
12625             PerlMem_free(rsal_out);
12626         set_errno(EVMSERR); set_vaxc_errno(sts);
12627         return 0;
12628       }
12629     }
12630
12631
12632     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12633     sys$close(&fab_in);  sys$close(&fab_out);
12634     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12635
12636     PerlMem_free(vmsin);
12637     PerlMem_free(vmsout);
12638     PerlMem_free(ubf);
12639     PerlMem_free(esa);
12640     if (esal != NULL)
12641         PerlMem_free(esal);
12642     PerlMem_free(rsa);
12643     if (rsal != NULL)
12644         PerlMem_free(rsal);
12645     PerlMem_free(esa_out);
12646     if (esal_out != NULL)
12647         PerlMem_free(esal_out);
12648     PerlMem_free(rsa_out);
12649     if (rsal_out != NULL)
12650         PerlMem_free(rsal_out);
12651
12652     if (!(sts & 1)) {
12653       set_errno(EVMSERR); set_vaxc_errno(sts);
12654       return 0;
12655     }
12656
12657     return 1;
12658
12659 }  /* end of rmscopy() */
12660 /*}}}*/
12661
12662
12663 /***  The following glue provides 'hooks' to make some of the routines
12664  * from this file available from Perl.  These routines are sufficiently
12665  * basic, and are required sufficiently early in the build process,
12666  * that's it's nice to have them available to miniperl as well as the
12667  * full Perl, so they're set up here instead of in an extension.  The
12668  * Perl code which handles importation of these names into a given
12669  * package lives in [.VMS]Filespec.pm in @INC.
12670  */
12671
12672 void
12673 rmsexpand_fromperl(pTHX_ CV *cv)
12674 {
12675   dXSARGS;
12676   char *fspec, *defspec = NULL, *rslt;
12677   STRLEN n_a;
12678   int fs_utf8, dfs_utf8;
12679
12680   fs_utf8 = 0;
12681   dfs_utf8 = 0;
12682   if (!items || items > 2)
12683     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12684   fspec = SvPV(ST(0),n_a);
12685   fs_utf8 = SvUTF8(ST(0));
12686   if (!fspec || !*fspec) XSRETURN_UNDEF;
12687   if (items == 2) {
12688     defspec = SvPV(ST(1),n_a);
12689     dfs_utf8 = SvUTF8(ST(1));
12690   }
12691   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12692   ST(0) = sv_newmortal();
12693   if (rslt != NULL) {
12694     sv_usepvn(ST(0),rslt,strlen(rslt));
12695     if (fs_utf8) {
12696         SvUTF8_on(ST(0));
12697     }
12698   }
12699   XSRETURN(1);
12700 }
12701
12702 void
12703 vmsify_fromperl(pTHX_ CV *cv)
12704 {
12705   dXSARGS;
12706   char *vmsified;
12707   STRLEN n_a;
12708   int utf8_fl;
12709
12710   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12711   utf8_fl = SvUTF8(ST(0));
12712   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12713   ST(0) = sv_newmortal();
12714   if (vmsified != NULL) {
12715     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12716     if (utf8_fl) {
12717         SvUTF8_on(ST(0));
12718     }
12719   }
12720   XSRETURN(1);
12721 }
12722
12723 void
12724 unixify_fromperl(pTHX_ CV *cv)
12725 {
12726   dXSARGS;
12727   char *unixified;
12728   STRLEN n_a;
12729   int utf8_fl;
12730
12731   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12732   utf8_fl = SvUTF8(ST(0));
12733   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12734   ST(0) = sv_newmortal();
12735   if (unixified != NULL) {
12736     sv_usepvn(ST(0),unixified,strlen(unixified));
12737     if (utf8_fl) {
12738         SvUTF8_on(ST(0));
12739     }
12740   }
12741   XSRETURN(1);
12742 }
12743
12744 void
12745 fileify_fromperl(pTHX_ CV *cv)
12746 {
12747   dXSARGS;
12748   char *fileified;
12749   STRLEN n_a;
12750   int utf8_fl;
12751
12752   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12753   utf8_fl = SvUTF8(ST(0));
12754   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12755   ST(0) = sv_newmortal();
12756   if (fileified != NULL) {
12757     sv_usepvn(ST(0),fileified,strlen(fileified));
12758     if (utf8_fl) {
12759         SvUTF8_on(ST(0));
12760     }
12761   }
12762   XSRETURN(1);
12763 }
12764
12765 void
12766 pathify_fromperl(pTHX_ CV *cv)
12767 {
12768   dXSARGS;
12769   char *pathified;
12770   STRLEN n_a;
12771   int utf8_fl;
12772
12773   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12774   utf8_fl = SvUTF8(ST(0));
12775   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12776   ST(0) = sv_newmortal();
12777   if (pathified != NULL) {
12778     sv_usepvn(ST(0),pathified,strlen(pathified));
12779     if (utf8_fl) {
12780         SvUTF8_on(ST(0));
12781     }
12782   }
12783   XSRETURN(1);
12784 }
12785
12786 void
12787 vmspath_fromperl(pTHX_ CV *cv)
12788 {
12789   dXSARGS;
12790   char *vmspath;
12791   STRLEN n_a;
12792   int utf8_fl;
12793
12794   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12795   utf8_fl = SvUTF8(ST(0));
12796   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12797   ST(0) = sv_newmortal();
12798   if (vmspath != NULL) {
12799     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12800     if (utf8_fl) {
12801         SvUTF8_on(ST(0));
12802     }
12803   }
12804   XSRETURN(1);
12805 }
12806
12807 void
12808 unixpath_fromperl(pTHX_ CV *cv)
12809 {
12810   dXSARGS;
12811   char *unixpath;
12812   STRLEN n_a;
12813   int utf8_fl;
12814
12815   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12816   utf8_fl = SvUTF8(ST(0));
12817   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12818   ST(0) = sv_newmortal();
12819   if (unixpath != NULL) {
12820     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12821     if (utf8_fl) {
12822         SvUTF8_on(ST(0));
12823     }
12824   }
12825   XSRETURN(1);
12826 }
12827
12828 void
12829 candelete_fromperl(pTHX_ CV *cv)
12830 {
12831   dXSARGS;
12832   char *fspec, *fsp;
12833   SV *mysv;
12834   IO *io;
12835   STRLEN n_a;
12836
12837   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12838
12839   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12840   Newx(fspec, VMS_MAXRSS, char);
12841   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12842   if (isGV_with_GP(mysv)) {
12843     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12844       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12845       ST(0) = &PL_sv_no;
12846       Safefree(fspec);
12847       XSRETURN(1);
12848     }
12849     fsp = fspec;
12850   }
12851   else {
12852     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12853       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12854       ST(0) = &PL_sv_no;
12855       Safefree(fspec);
12856       XSRETURN(1);
12857     }
12858   }
12859
12860   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12861   Safefree(fspec);
12862   XSRETURN(1);
12863 }
12864
12865 void
12866 rmscopy_fromperl(pTHX_ CV *cv)
12867 {
12868   dXSARGS;
12869   char *inspec, *outspec, *inp, *outp;
12870   int date_flag;
12871   SV *mysv;
12872   IO *io;
12873   STRLEN n_a;
12874
12875   if (items < 2 || items > 3)
12876     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12877
12878   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12879   Newx(inspec, VMS_MAXRSS, char);
12880   if (isGV_with_GP(mysv)) {
12881     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12882       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12883       ST(0) = sv_2mortal(newSViv(0));
12884       Safefree(inspec);
12885       XSRETURN(1);
12886     }
12887     inp = inspec;
12888   }
12889   else {
12890     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12891       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12892       ST(0) = sv_2mortal(newSViv(0));
12893       Safefree(inspec);
12894       XSRETURN(1);
12895     }
12896   }
12897   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12898   Newx(outspec, VMS_MAXRSS, char);
12899   if (isGV_with_GP(mysv)) {
12900     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12901       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12902       ST(0) = sv_2mortal(newSViv(0));
12903       Safefree(inspec);
12904       Safefree(outspec);
12905       XSRETURN(1);
12906     }
12907     outp = outspec;
12908   }
12909   else {
12910     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12911       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12912       ST(0) = sv_2mortal(newSViv(0));
12913       Safefree(inspec);
12914       Safefree(outspec);
12915       XSRETURN(1);
12916     }
12917   }
12918   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12919
12920   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12921   Safefree(inspec);
12922   Safefree(outspec);
12923   XSRETURN(1);
12924 }
12925
12926 /* The mod2fname is limited to shorter filenames by design, so it should
12927  * not be modified to support longer EFS pathnames
12928  */
12929 void
12930 mod2fname(pTHX_ CV *cv)
12931 {
12932   dXSARGS;
12933   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12934        workbuff[NAM$C_MAXRSS*1 + 1];
12935   int counter, num_entries;
12936   /* ODS-5 ups this, but we want to be consistent, so... */
12937   int max_name_len = 39;
12938   AV *in_array = (AV *)SvRV(ST(0));
12939
12940   num_entries = av_len(in_array);
12941
12942   /* All the names start with PL_. */
12943   strcpy(ultimate_name, "PL_");
12944
12945   /* Clean up our working buffer */
12946   Zero(work_name, sizeof(work_name), char);
12947
12948   /* Run through the entries and build up a working name */
12949   for(counter = 0; counter <= num_entries; counter++) {
12950     /* If it's not the first name then tack on a __ */
12951     if (counter) {
12952       my_strlcat(work_name, "__", sizeof(work_name));
12953     }
12954     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12955   }
12956
12957   /* Check to see if we actually have to bother...*/
12958   if (strlen(work_name) + 3 <= max_name_len) {
12959     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12960   } else {
12961     /* It's too darned big, so we need to go strip. We use the same */
12962     /* algorithm as xsubpp does. First, strip out doubled __ */
12963     char *source, *dest, last;
12964     dest = workbuff;
12965     last = 0;
12966     for (source = work_name; *source; source++) {
12967       if (last == *source && last == '_') {
12968         continue;
12969       }
12970       *dest++ = *source;
12971       last = *source;
12972     }
12973     /* Go put it back */
12974     my_strlcpy(work_name, workbuff, sizeof(work_name));
12975     /* Is it still too big? */
12976     if (strlen(work_name) + 3 > max_name_len) {
12977       /* Strip duplicate letters */
12978       last = 0;
12979       dest = workbuff;
12980       for (source = work_name; *source; source++) {
12981         if (last == toupper(*source)) {
12982         continue;
12983         }
12984         *dest++ = *source;
12985         last = toupper(*source);
12986       }
12987       my_strlcpy(work_name, workbuff, sizeof(work_name));
12988     }
12989
12990     /* Is it *still* too big? */
12991     if (strlen(work_name) + 3 > max_name_len) {
12992       /* Too bad, we truncate */
12993       work_name[max_name_len - 2] = 0;
12994     }
12995     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12996   }
12997
12998   /* Okay, return it */
12999   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13000   XSRETURN(1);
13001 }
13002
13003 void
13004 hushexit_fromperl(pTHX_ CV *cv)
13005 {
13006     dXSARGS;
13007
13008     if (items > 0) {
13009         VMSISH_HUSHED = SvTRUE(ST(0));
13010     }
13011     ST(0) = boolSV(VMSISH_HUSHED);
13012     XSRETURN(1);
13013 }
13014
13015
13016 PerlIO *
13017 Perl_vms_start_glob
13018    (pTHX_ SV *tmpglob,
13019     IO *io)
13020 {
13021     PerlIO *fp;
13022     struct vs_str_st *rslt;
13023     char *vmsspec;
13024     char *rstr;
13025     char *begin, *cp;
13026     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13027     PerlIO *tmpfp;
13028     STRLEN i;
13029     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13030     struct dsc$descriptor_vs rsdsc;
13031     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13032     unsigned long hasver = 0, isunix = 0;
13033     unsigned long int lff_flags = 0;
13034     int rms_sts;
13035     int vms_old_glob = 1;
13036
13037     if (!SvOK(tmpglob)) {
13038         SETERRNO(ENOENT,RMS$_FNF);
13039         return NULL;
13040     }
13041
13042     vms_old_glob = !decc_filename_unix_report;
13043
13044 #ifdef VMS_LONGNAME_SUPPORT
13045     lff_flags = LIB$M_FIL_LONG_NAMES;
13046 #endif
13047     /* The Newx macro will not allow me to assign a smaller array
13048      * to the rslt pointer, so we will assign it to the begin char pointer
13049      * and then copy the value into the rslt pointer.
13050      */
13051     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13052     rslt = (struct vs_str_st *)begin;
13053     rslt->length = 0;
13054     rstr = &rslt->str[0];
13055     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13056     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13057     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13058     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13059
13060     Newx(vmsspec, VMS_MAXRSS, char);
13061
13062         /* We could find out if there's an explicit dev/dir or version
13063            by peeking into lib$find_file's internal context at
13064            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13065            but that's unsupported, so I don't want to do it now and
13066            have it bite someone in the future. */
13067         /* Fix-me: vms_split_path() is the only way to do this, the
13068            existing method will fail with many legal EFS or UNIX specifications
13069          */
13070
13071     cp = SvPV(tmpglob,i);
13072
13073     for (; i; i--) {
13074         if (cp[i] == ';') hasver = 1;
13075         if (cp[i] == '.') {
13076             if (sts) hasver = 1;
13077             else sts = 1;
13078         }
13079         if (cp[i] == '/') {
13080             hasdir = isunix = 1;
13081             break;
13082         }
13083         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13084             hasdir = 1;
13085             break;
13086         }
13087     }
13088
13089     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13090     if ((hasdir == 0) && decc_filename_unix_report) {
13091         isunix = 1;
13092     }
13093
13094     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13095         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13096         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13097         int wildstar = 0;
13098         int wildquery = 0;
13099         int found = 0;
13100         Stat_t st;
13101         int stat_sts;
13102         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13103         if (!stat_sts && S_ISDIR(st.st_mode)) {
13104             char * vms_dir;
13105             const char * fname;
13106             STRLEN fname_len;
13107
13108             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13109             /* path delimiter of ':>]', if so, then the old behavior has */
13110             /* obviously been specifically requested */
13111
13112             fname = SvPVX_const(tmpglob);
13113             fname_len = strlen(fname);
13114             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13115             if (vms_old_glob || (vms_dir != NULL)) {
13116                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13117                                             SvPVX(tmpglob),vmsspec,NULL);
13118                 ok = (wilddsc.dsc$a_pointer != NULL);
13119                 /* maybe passed 'foo' rather than '[.foo]', thus not
13120                    detected above */
13121                 hasdir = 1;
13122             } else {
13123                 /* Operate just on the directory, the special stat/fstat for */
13124                 /* leaves the fileified  specification in the st_devnam */
13125                 /* member. */
13126                 wilddsc.dsc$a_pointer = st.st_devnam;
13127                 ok = 1;
13128             }
13129         }
13130         else {
13131             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13132             ok = (wilddsc.dsc$a_pointer != NULL);
13133         }
13134         if (ok)
13135             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13136
13137         /* If not extended character set, replace ? with % */
13138         /* With extended character set, ? is a wildcard single character */
13139         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13140             if (*cp == '?') {
13141                 wildquery = 1;
13142                 if (!decc_efs_charset)
13143                     *cp = '%';
13144             } else if (*cp == '%') {
13145                 wildquery = 1;
13146             } else if (*cp == '*') {
13147                 wildstar = 1;
13148             }
13149         }
13150
13151         if (ok) {
13152             wv_sts = vms_split_path(
13153                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13154                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13155                 &wvs_spec, &wvs_len);
13156         } else {
13157             wn_spec = NULL;
13158             wn_len = 0;
13159             we_spec = NULL;
13160             we_len = 0;
13161         }
13162
13163         sts = SS$_NORMAL;
13164         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13165          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13166          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13167          int valid_find;
13168
13169             valid_find = 0;
13170             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13171                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13172             if (!$VMS_STATUS_SUCCESS(sts))
13173                 break;
13174
13175             /* with varying string, 1st word of buffer contains result length */
13176             rstr[rslt->length] = '\0';
13177
13178              /* Find where all the components are */
13179              v_sts = vms_split_path
13180                        (rstr,
13181                         &v_spec,
13182                         &v_len,
13183                         &r_spec,
13184                         &r_len,
13185                         &d_spec,
13186                         &d_len,
13187                         &n_spec,
13188                         &n_len,
13189                         &e_spec,
13190                         &e_len,
13191                         &vs_spec,
13192                         &vs_len);
13193
13194             /* If no version on input, truncate the version on output */
13195             if (!hasver && (vs_len > 0)) {
13196                 *vs_spec = '\0';
13197                 vs_len = 0;
13198             }
13199
13200             if (isunix) {
13201
13202                 /* In Unix report mode, remove the ".dir;1" from the name */
13203                 /* if it is a real directory */
13204                 if (decc_filename_unix_report && decc_efs_charset) {
13205                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13206                         Stat_t statbuf;
13207                         int ret_sts;
13208
13209                         ret_sts = flex_lstat(rstr, &statbuf);
13210                         if ((ret_sts == 0) &&
13211                             S_ISDIR(statbuf.st_mode)) {
13212                             e_len = 0;
13213                             e_spec[0] = 0;
13214                         }
13215                     }
13216                 }
13217
13218                 /* No version & a null extension on UNIX handling */
13219                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13220                     e_len = 0;
13221                     *e_spec = '\0';
13222                 }
13223             }
13224
13225             if (!decc_efs_case_preserve) {
13226                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13227             }
13228
13229             /* Find File treats a Null extension as return all extensions */
13230             /* This is contrary to Perl expectations */
13231
13232             if (wildstar || wildquery || vms_old_glob) {
13233                 /* really need to see if the returned file name matched */
13234                 /* but for now will assume that it matches */
13235                 valid_find = 1;
13236             } else {
13237                 /* Exact Match requested */
13238                 /* How are directories handled? - like a file */
13239                 if ((e_len == we_len) && (n_len == wn_len)) {
13240                     int t1;
13241                     t1 = e_len;
13242                     if (t1 > 0)
13243                         t1 = strncmp(e_spec, we_spec, e_len);
13244                     if (t1 == 0) {
13245                        t1 = n_len;
13246                        if (t1 > 0)
13247                            t1 = strncmp(n_spec, we_spec, n_len);
13248                        if (t1 == 0)
13249                            valid_find = 1;
13250                     }
13251                 }
13252             }
13253
13254             if (valid_find) {
13255                 found++;
13256
13257                 if (hasdir) {
13258                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13259                     begin = rstr;
13260                 }
13261                 else {
13262                     /* Start with the name */
13263                     begin = n_spec;
13264                 }
13265                 strcat(begin,"\n");
13266                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13267             }
13268         }
13269         if (cxt) (void)lib$find_file_end(&cxt);
13270
13271         if (!found) {
13272             /* Be POSIXish: return the input pattern when no matches */
13273             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13274             strcat(rstr,"\n");
13275             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13276         }
13277
13278         if (ok && sts != RMS$_NMF &&
13279             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13280         if (!ok) {
13281             if (!(sts & 1)) {
13282                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13283             }
13284             PerlIO_close(tmpfp);
13285             fp = NULL;
13286         }
13287         else {
13288             PerlIO_rewind(tmpfp);
13289             IoTYPE(io) = IoTYPE_RDONLY;
13290             IoIFP(io) = fp = tmpfp;
13291             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13292         }
13293     }
13294     Safefree(vmsspec);
13295     Safefree(rslt);
13296     return fp;
13297 }
13298
13299
13300 static char *
13301 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13302                    int *utf8_fl);
13303
13304 void
13305 unixrealpath_fromperl(pTHX_ CV *cv)
13306 {
13307     dXSARGS;
13308     char *fspec, *rslt_spec, *rslt;
13309     STRLEN n_a;
13310
13311     if (!items || items != 1)
13312         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13313
13314     fspec = SvPV(ST(0),n_a);
13315     if (!fspec || !*fspec) XSRETURN_UNDEF;
13316
13317     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13318     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13319
13320     ST(0) = sv_newmortal();
13321     if (rslt != NULL)
13322         sv_usepvn(ST(0),rslt,strlen(rslt));
13323     else
13324         Safefree(rslt_spec);
13325         XSRETURN(1);
13326 }
13327
13328 static char *
13329 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13330                    int *utf8_fl);
13331
13332 void
13333 vmsrealpath_fromperl(pTHX_ CV *cv)
13334 {
13335     dXSARGS;
13336     char *fspec, *rslt_spec, *rslt;
13337     STRLEN n_a;
13338
13339     if (!items || items != 1)
13340         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13341
13342     fspec = SvPV(ST(0),n_a);
13343     if (!fspec || !*fspec) XSRETURN_UNDEF;
13344
13345     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13346     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13347
13348     ST(0) = sv_newmortal();
13349     if (rslt != NULL)
13350         sv_usepvn(ST(0),rslt,strlen(rslt));
13351     else
13352         Safefree(rslt_spec);
13353         XSRETURN(1);
13354 }
13355
13356 #ifdef HAS_SYMLINK
13357 /*
13358  * A thin wrapper around decc$symlink to make sure we follow the
13359  * standard and do not create a symlink with a zero-length name,
13360  * and convert the target to Unix format, as the CRTL can't handle
13361  * targets in VMS format.
13362  */
13363 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13364 int
13365 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13366 {
13367     int sts;
13368     char * utarget;
13369
13370     if (!link_name || !*link_name) {
13371       SETERRNO(ENOENT, SS$_NOSUCHFILE);
13372       return -1;
13373     }
13374
13375     utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13376     /* An untranslatable filename should be passed through. */
13377     (void) int_tounixspec(contents, utarget, NULL);
13378     sts = symlink(utarget, link_name);
13379     PerlMem_free(utarget);
13380     return sts;
13381 }
13382 /*}}}*/
13383
13384 #endif /* HAS_SYMLINK */
13385
13386 int do_vms_case_tolerant(void);
13387
13388 void
13389 case_tolerant_process_fromperl(pTHX_ CV *cv)
13390 {
13391   dXSARGS;
13392   ST(0) = boolSV(do_vms_case_tolerant());
13393   XSRETURN(1);
13394 }
13395
13396 #ifdef USE_ITHREADS
13397
13398 void
13399 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13400                           struct interp_intern *dst)
13401 {
13402     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13403
13404     memcpy(dst,src,sizeof(struct interp_intern));
13405 }
13406
13407 #endif
13408
13409 void
13410 Perl_sys_intern_clear(pTHX)
13411 {
13412 }
13413
13414 void
13415 Perl_sys_intern_init(pTHX)
13416 {
13417     unsigned int ix = RAND_MAX;
13418     double x;
13419
13420     VMSISH_HUSHED = 0;
13421
13422     MY_POSIX_EXIT = vms_posix_exit;
13423
13424     x = (float)ix;
13425     MY_INV_RAND_MAX = 1./x;
13426 }
13427
13428 void
13429 init_os_extras(void)
13430 {
13431   dTHX;
13432   char* file = __FILE__;
13433   if (decc_disable_to_vms_logname_translation) {
13434     no_translate_barewords = TRUE;
13435   } else {
13436     no_translate_barewords = FALSE;
13437   }
13438
13439   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13440   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13441   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13442   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13443   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13444   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13445   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13446   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13447   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13448   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13449   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13450   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13451   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13452   newXSproto("VMS::Filespec::case_tolerant_process",
13453       case_tolerant_process_fromperl,file,"");
13454
13455   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13456
13457   return;
13458 }
13459
13460 #if __CRTL_VER == 80200000
13461 /* This missed getting in to the DECC SDK for 8.2 */
13462 char *realpath(const char *file_name, char * resolved_name, ...);
13463 #endif
13464
13465 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13466 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13467  * The perl fallback routine to provide realpath() is not as efficient
13468  * on OpenVMS.
13469  */
13470
13471 #ifdef __cplusplus
13472 extern "C" {
13473 #endif
13474
13475 /* Hack, use old stat() as fastest way of getting ino_t and device */
13476 int decc$stat(const char *name, void * statbuf);
13477 #if !defined(__VAX) && __CRTL_VER >= 80200000
13478 int decc$lstat(const char *name, void * statbuf);
13479 #else
13480 #define decc$lstat decc$stat
13481 #endif
13482
13483 #ifdef __cplusplus
13484 }
13485 #endif
13486
13487
13488 /* Realpath is fragile.  In 8.3 it does not work if the feature
13489  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13490  * links are implemented in RMS, not the CRTL. It also can fail if the
13491  * user does not have read/execute access to some of the directories.
13492  * So in order for Do What I Mean mode to work, if realpath() fails,
13493  * fall back to looking up the filename by the device name and FID.
13494  */
13495
13496 int vms_fid_to_name(char * outname, int outlen,
13497                     const char * name, int lstat_flag, mode_t * mode)
13498 {
13499 #pragma message save
13500 #pragma message disable MISALGNDSTRCT
13501 #pragma message disable MISALGNDMEM
13502 #pragma member_alignment save
13503 #pragma nomember_alignment
13504 struct statbuf_t {
13505     char           * st_dev;
13506     unsigned short st_ino[3];
13507     unsigned short old_st_mode;
13508     unsigned long  padl[30];  /* plenty of room */
13509 } statbuf;
13510 #pragma message restore
13511 #pragma member_alignment restore
13512
13513     int sts;
13514     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13515     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13516     char *fileified;
13517     char *temp_fspec;
13518     char *ret_spec;
13519
13520     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13521      * unexpected answers
13522      */
13523
13524     fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13525     if (fileified == NULL)
13526         _ckvmssts_noperl(SS$_INSFMEM);
13527
13528     temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13529     if (temp_fspec == NULL)
13530         _ckvmssts_noperl(SS$_INSFMEM);
13531
13532     sts = -1;
13533     /* First need to try as a directory */
13534     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13535     if (ret_spec != NULL) {
13536         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13537         if (ret_spec != NULL) {
13538             if (lstat_flag == 0)
13539                 sts = decc$stat(fileified, &statbuf);
13540             else
13541                 sts = decc$lstat(fileified, &statbuf);
13542         }
13543     }
13544
13545     /* Then as a VMS file spec */
13546     if (sts != 0) {
13547         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13548         if (ret_spec != NULL) {
13549             if (lstat_flag == 0) {
13550                 sts = decc$stat(temp_fspec, &statbuf);
13551             } else {
13552                 sts = decc$lstat(temp_fspec, &statbuf);
13553             }
13554         }
13555     }
13556
13557     if (sts) {
13558         /* Next try - allow multiple dots with out EFS CHARSET */
13559         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13560          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13561          * enable it if it isn't already.
13562          */
13563 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13564         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13565             decc$feature_set_value(decc_efs_charset_index, 1, 1);
13566 #endif
13567         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13568         if (lstat_flag == 0) {
13569             sts = decc$stat(name, &statbuf);
13570         } else {
13571             sts = decc$lstat(name, &statbuf);
13572         }
13573 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13574         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13575             decc$feature_set_value(decc_efs_charset_index, 1, 0);
13576 #endif
13577     }
13578
13579
13580     /* and then because the Perl Unix to VMS conversion is not perfect */
13581     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13582     /* characters from filenames so we need to try it as-is */
13583     if (sts) {
13584         if (lstat_flag == 0) {
13585             sts = decc$stat(name, &statbuf);
13586         } else {
13587             sts = decc$lstat(name, &statbuf);
13588         }
13589     }
13590
13591     if (sts == 0) {
13592         int vms_sts;
13593
13594         dvidsc.dsc$a_pointer=statbuf.st_dev;
13595         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13596
13597         specdsc.dsc$a_pointer = outname;
13598         specdsc.dsc$w_length = outlen-1;
13599
13600         vms_sts = lib$fid_to_name
13601             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13602         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13603             outname[specdsc.dsc$w_length] = 0;
13604
13605             /* Return the mode */
13606             if (mode) {
13607                 *mode = statbuf.old_st_mode;
13608             }
13609         }
13610     }
13611     PerlMem_free(temp_fspec);
13612     PerlMem_free(fileified);
13613     return sts;
13614 }
13615
13616
13617
13618 static char *
13619 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13620                    int *utf8_fl)
13621 {
13622     char * rslt = NULL;
13623
13624 #ifdef HAS_SYMLINK
13625     if (decc_posix_compliant_pathnames > 0 ) {
13626         /* realpath currently only works if posix compliant pathnames are
13627          * enabled.  It may start working when they are not, but in that
13628          * case we still want the fallback behavior for backwards compatibility
13629          */
13630         rslt = realpath(filespec, outbuf);
13631     }
13632 #endif
13633
13634     if (rslt == NULL) {
13635         char * vms_spec;
13636         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13637         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13638         mode_t my_mode;
13639
13640         /* Fall back to fid_to_name */
13641
13642         Newx(vms_spec, VMS_MAXRSS + 1, char);
13643
13644         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13645         if (sts == 0) {
13646
13647
13648             /* Now need to trim the version off */
13649             sts = vms_split_path
13650                   (vms_spec,
13651                    &v_spec,
13652                    &v_len,
13653                    &r_spec,
13654                    &r_len,
13655                    &d_spec,
13656                    &d_len,
13657                    &n_spec,
13658                    &n_len,
13659                    &e_spec,
13660                    &e_len,
13661                    &vs_spec,
13662                    &vs_len);
13663
13664
13665                 if (sts == 0) {
13666                     int haslower = 0;
13667                     const char *cp;
13668
13669                     /* Trim off the version */
13670                     int file_len = v_len + r_len + d_len + n_len + e_len;
13671                     vms_spec[file_len] = 0;
13672
13673                     /* Trim off the .DIR if this is a directory */
13674                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13675                         if (S_ISDIR(my_mode)) {
13676                             e_len = 0;
13677                             e_spec[0] = 0;
13678                         }
13679                     }
13680
13681                     /* Drop NULL extensions on UNIX file specification */
13682                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
13683                         e_len = 0;
13684                         e_spec[0] = '\0';
13685                     }
13686
13687                     /* The result is expected to be in UNIX format */
13688                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13689
13690                     /* Downcase if input had any lower case letters and
13691                      * case preservation is not in effect.
13692                      */
13693                     if (!decc_efs_case_preserve) {
13694                         for (cp = filespec; *cp; cp++)
13695                             if (islower(*cp)) { haslower = 1; break; }
13696
13697                         if (haslower) __mystrtolower(rslt);
13698                     }
13699                 }
13700         } else {
13701
13702             /* Now for some hacks to deal with backwards and forward */
13703             /* compatibility */
13704             if (!decc_efs_charset) {
13705
13706                 /* 1. ODS-2 mode wants to do a syntax only translation */
13707                 rslt = int_rmsexpand(filespec, outbuf,
13708                                     NULL, 0, NULL, utf8_fl);
13709
13710             } else {
13711                 if (decc_filename_unix_report) {
13712                     char * dir_name;
13713                     char * vms_dir_name;
13714                     char * file_name;
13715
13716                     /* 2. ODS-5 / UNIX report mode should return a failure */
13717                     /*    if the parent directory also does not exist */
13718                     /*    Otherwise, get the real path for the parent */
13719                     /*    and add the child to it. */
13720
13721                     /* basename / dirname only available for VMS 7.0+ */
13722                     /* So we may need to implement them as common routines */
13723
13724                     Newx(dir_name, VMS_MAXRSS + 1, char);
13725                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13726                     dir_name[0] = '\0';
13727                     file_name = NULL;
13728
13729                     /* First try a VMS parse */
13730                     sts = vms_split_path
13731                           (filespec,
13732                            &v_spec,
13733                            &v_len,
13734                            &r_spec,
13735                            &r_len,
13736                            &d_spec,
13737                            &d_len,
13738                            &n_spec,
13739                            &n_len,
13740                            &e_spec,
13741                            &e_len,
13742                            &vs_spec,
13743                            &vs_len);
13744
13745                     if (sts == 0) {
13746                         /* This is VMS */
13747
13748                         int dir_len = v_len + r_len + d_len + n_len;
13749                         if (dir_len > 0) {
13750                            memcpy(dir_name, filespec, dir_len);
13751                            dir_name[dir_len] = '\0';
13752                            file_name = (char *)&filespec[dir_len + 1];
13753                         }
13754                     } else {
13755                         /* This must be UNIX */
13756                         char * tchar;
13757
13758                         tchar = strrchr(filespec, '/');
13759
13760                         if (tchar != NULL) {
13761                             int dir_len = tchar - filespec;
13762                             memcpy(dir_name, filespec, dir_len);
13763                             dir_name[dir_len] = '\0';
13764                             file_name = (char *) &filespec[dir_len + 1];
13765                         }
13766                     }
13767
13768                     /* Dir name is defaulted */
13769                     if (dir_name[0] == 0) {
13770                         dir_name[0] = '.';
13771                         dir_name[1] = '\0';
13772                     }
13773
13774                     /* Need realpath for the directory */
13775                     sts = vms_fid_to_name(vms_dir_name,
13776                                           VMS_MAXRSS + 1,
13777                                           dir_name, 0, NULL);
13778
13779                     if (sts == 0) {
13780                         /* Now need to pathify it. */
13781                         char *tdir = int_pathify_dirspec(vms_dir_name,
13782                                                          outbuf);
13783
13784                         /* And now add the original filespec to it */
13785                         if (file_name != NULL) {
13786                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13787                         }
13788                         return outbuf;
13789                     }
13790                     Safefree(vms_dir_name);
13791                     Safefree(dir_name);
13792                 }
13793             }
13794         }
13795         Safefree(vms_spec);
13796     }
13797     return rslt;
13798 }
13799
13800 static char *
13801 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13802                    int *utf8_fl)
13803 {
13804     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13805     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13806
13807     /* Fall back to fid_to_name */
13808
13809     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13810     if (sts != 0) {
13811         return NULL;
13812     }
13813     else {
13814
13815
13816         /* Now need to trim the version off */
13817         sts = vms_split_path
13818                   (outbuf,
13819                    &v_spec,
13820                    &v_len,
13821                    &r_spec,
13822                    &r_len,
13823                    &d_spec,
13824                    &d_len,
13825                    &n_spec,
13826                    &n_len,
13827                    &e_spec,
13828                    &e_len,
13829                    &vs_spec,
13830                    &vs_len);
13831
13832
13833         if (sts == 0) {
13834             int haslower = 0;
13835             const char *cp;
13836
13837             /* Trim off the version */
13838             int file_len = v_len + r_len + d_len + n_len + e_len;
13839             outbuf[file_len] = 0;
13840
13841             /* Downcase if input had any lower case letters and
13842              * case preservation is not in effect.
13843              */
13844             if (!decc_efs_case_preserve) {
13845                 for (cp = filespec; *cp; cp++)
13846                     if (islower(*cp)) { haslower = 1; break; }
13847
13848                 if (haslower) __mystrtolower(outbuf);
13849             }
13850         }
13851     }
13852     return outbuf;
13853 }
13854
13855
13856 /*}}}*/
13857 /* External entry points */
13858 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13859 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13860
13861 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13862 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13863
13864 /* case_tolerant */
13865
13866 /*{{{int do_vms_case_tolerant(void)*/
13867 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13868  * controlled by a process setting.
13869  */
13870 int do_vms_case_tolerant(void)
13871 {
13872     return vms_process_case_tolerant;
13873 }
13874 /*}}}*/
13875 /* External entry points */
13876 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13877 int Perl_vms_case_tolerant(void)
13878 { return do_vms_case_tolerant(); }
13879 #else
13880 int Perl_vms_case_tolerant(void)
13881 { return vms_process_case_tolerant; }
13882 #endif
13883
13884
13885  /* Start of DECC RTL Feature handling */
13886
13887 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13888
13889 static int
13890 set_feature_default(const char *name, int value)
13891 {
13892     int status;
13893     int index;
13894
13895     index = decc$feature_get_index(name);
13896
13897     status = decc$feature_set_value(index, 1, value);
13898     if (index == -1 || (status == -1)) {
13899       return -1;
13900     }
13901
13902     status = decc$feature_get_value(index, 1);
13903     if (status != value) {
13904       return -1;
13905     }
13906
13907     /* Various things may check for an environment setting
13908      * rather than the feature directly, so set that too.
13909      */
13910     vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13911
13912     return 0;
13913 }
13914 #endif
13915
13916
13917 /* C RTL Feature settings */
13918
13919 #if defined(__DECC) || defined(__DECCXX)
13920
13921 #ifdef __cplusplus
13922 extern "C" {
13923 #endif
13924
13925 extern void
13926 vmsperl_set_features(void)
13927 {
13928     int status;
13929     int s;
13930     char val_str[10];
13931 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13932     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13933     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13934     unsigned long case_perm;
13935     unsigned long case_image;
13936 #endif
13937
13938     /* Allow an exception to bring Perl into the VMS debugger */
13939     vms_debug_on_exception = 0;
13940     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13941     if ($VMS_STATUS_SUCCESS(status)) {
13942        val_str[0] = _toupper(val_str[0]);
13943        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13944          vms_debug_on_exception = 1;
13945        else
13946          vms_debug_on_exception = 0;
13947     }
13948
13949     /* Debug unix/vms file translation routines */
13950     vms_debug_fileify = 0;
13951     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13952     if ($VMS_STATUS_SUCCESS(status)) {
13953         val_str[0] = _toupper(val_str[0]);
13954         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13955             vms_debug_fileify = 1;
13956         else
13957             vms_debug_fileify = 0;
13958     }
13959
13960
13961     /* Historically PERL has been doing vmsify / stat differently than */
13962     /* the CRTL.  In particular, under some conditions the CRTL will   */
13963     /* remove some illegal characters like spaces from filenames       */
13964     /* resulting in some differences.  The stat()/lstat() wrapper has  */
13965     /* been reporting such file names as invalid and fails to stat them */
13966     /* fixing this bug so that stat()/lstat() accept these like the     */
13967     /* CRTL does will result in several tests failing.                  */
13968     /* This should really be fixed, but for now, set up a feature to    */
13969     /* enable it so that the impact can be studied.                     */
13970     vms_bug_stat_filename = 0;
13971     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13972     if ($VMS_STATUS_SUCCESS(status)) {
13973         val_str[0] = _toupper(val_str[0]);
13974         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13975             vms_bug_stat_filename = 1;
13976         else
13977             vms_bug_stat_filename = 0;
13978     }
13979
13980
13981     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13982     vms_vtf7_filenames = 0;
13983     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13984     if ($VMS_STATUS_SUCCESS(status)) {
13985        val_str[0] = _toupper(val_str[0]);
13986        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13987          vms_vtf7_filenames = 1;
13988        else
13989          vms_vtf7_filenames = 0;
13990     }
13991
13992     /* unlink all versions on unlink() or rename() */
13993     vms_unlink_all_versions = 0;
13994     status = simple_trnlnm
13995         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13996     if ($VMS_STATUS_SUCCESS(status)) {
13997        val_str[0] = _toupper(val_str[0]);
13998        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13999          vms_unlink_all_versions = 1;
14000        else
14001          vms_unlink_all_versions = 0;
14002     }
14003
14004 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14005     /* Detect running under GNV Bash or other UNIX like shell */
14006     gnv_unix_shell = 0;
14007     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14008     if ($VMS_STATUS_SUCCESS(status)) {
14009          gnv_unix_shell = 1;
14010          set_feature_default("DECC$EFS_CHARSET", 1);
14011          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14012          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14013          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14014          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14015          vms_unlink_all_versions = 1;
14016          vms_posix_exit = 1;
14017     }
14018     /* Some reasonable defaults that are not CRTL defaults */
14019     set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14020     set_feature_default("DECC$ARGV_PARSE_STYLE", 1);     /* Requires extended parse. */
14021 #endif
14022
14023     /* hacks to see if known bugs are still present for testing */
14024
14025     /* PCP mode requires creating /dev/null special device file */
14026     decc_bug_devnull = 0;
14027     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14028     if ($VMS_STATUS_SUCCESS(status)) {
14029        val_str[0] = _toupper(val_str[0]);
14030        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14031           decc_bug_devnull = 1;
14032        else
14033           decc_bug_devnull = 0;
14034     }
14035
14036     /* UNIX directory names with no paths are broken in a lot of places */
14037     decc_dir_barename = 1;
14038     status = simple_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14039     if ($VMS_STATUS_SUCCESS(status)) {
14040       val_str[0] = _toupper(val_str[0]);
14041       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14042         decc_dir_barename = 1;
14043       else
14044         decc_dir_barename = 0;
14045     }
14046
14047 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14048     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14049     if (s >= 0) {
14050         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14051         if (decc_disable_to_vms_logname_translation < 0)
14052             decc_disable_to_vms_logname_translation = 0;
14053     }
14054
14055     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14056     if (s >= 0) {
14057         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14058         if (decc_efs_case_preserve < 0)
14059             decc_efs_case_preserve = 0;
14060     }
14061
14062     s = decc$feature_get_index("DECC$EFS_CHARSET");
14063     decc_efs_charset_index = s;
14064     if (s >= 0) {
14065         decc_efs_charset = decc$feature_get_value(s, 1);
14066         if (decc_efs_charset < 0)
14067             decc_efs_charset = 0;
14068     }
14069
14070     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14071     if (s >= 0) {
14072         decc_filename_unix_report = decc$feature_get_value(s, 1);
14073         if (decc_filename_unix_report > 0) {
14074             decc_filename_unix_report = 1;
14075             vms_posix_exit = 1;
14076         }
14077         else
14078             decc_filename_unix_report = 0;
14079     }
14080
14081     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14082     if (s >= 0) {
14083         decc_filename_unix_only = decc$feature_get_value(s, 1);
14084         if (decc_filename_unix_only > 0) {
14085             decc_filename_unix_only = 1;
14086         }
14087         else {
14088             decc_filename_unix_only = 0;
14089         }
14090     }
14091
14092     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14093     if (s >= 0) {
14094         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14095         if (decc_filename_unix_no_version < 0)
14096             decc_filename_unix_no_version = 0;
14097     }
14098
14099     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14100     if (s >= 0) {
14101         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14102         if (decc_readdir_dropdotnotype < 0)
14103             decc_readdir_dropdotnotype = 0;
14104     }
14105
14106 #if __CRTL_VER >= 80200000
14107     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14108     if (s >= 0) {
14109         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14110         if (decc_posix_compliant_pathnames < 0)
14111             decc_posix_compliant_pathnames = 0;
14112         if (decc_posix_compliant_pathnames > 4)
14113             decc_posix_compliant_pathnames = 0;
14114     }
14115
14116 #endif
14117 #else
14118     status = simple_trnlnm
14119         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14120     if ($VMS_STATUS_SUCCESS(status)) {
14121         val_str[0] = _toupper(val_str[0]);
14122         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14123            decc_disable_to_vms_logname_translation = 1;
14124         }
14125     }
14126
14127 #ifndef __VAX
14128     status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14129     if ($VMS_STATUS_SUCCESS(status)) {
14130         val_str[0] = _toupper(val_str[0]);
14131         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14132            decc_efs_case_preserve = 1;
14133         }
14134     }
14135 #endif
14136
14137     status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14138     if ($VMS_STATUS_SUCCESS(status)) {
14139         val_str[0] = _toupper(val_str[0]);
14140         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14141            decc_filename_unix_report = 1;
14142         }
14143     }
14144     status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14145     if ($VMS_STATUS_SUCCESS(status)) {
14146         val_str[0] = _toupper(val_str[0]);
14147         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14148            decc_filename_unix_only = 1;
14149            decc_filename_unix_report = 1;
14150         }
14151     }
14152     status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14153     if ($VMS_STATUS_SUCCESS(status)) {
14154         val_str[0] = _toupper(val_str[0]);
14155         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14156            decc_filename_unix_no_version = 1;
14157         }
14158     }
14159     status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14160     if ($VMS_STATUS_SUCCESS(status)) {
14161         val_str[0] = _toupper(val_str[0]);
14162         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14163            decc_readdir_dropdotnotype = 1;
14164         }
14165     }
14166 #endif
14167
14168 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14169
14170      /* Report true case tolerance */
14171     /*----------------------------*/
14172     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14173     if (!$VMS_STATUS_SUCCESS(status))
14174         case_perm = PPROP$K_CASE_BLIND;
14175     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14176     if (!$VMS_STATUS_SUCCESS(status))
14177         case_image = PPROP$K_CASE_BLIND;
14178     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14179         (case_image == PPROP$K_CASE_SENSITIVE))
14180         vms_process_case_tolerant = 0;
14181
14182 #endif
14183
14184     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14185     /* for strict backward compatibility */
14186     status = simple_trnlnm
14187         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14188     if ($VMS_STATUS_SUCCESS(status)) {
14189        val_str[0] = _toupper(val_str[0]);
14190        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14191          vms_posix_exit = 1;
14192        else
14193          vms_posix_exit = 0;
14194     }
14195 }
14196
14197 /* Use 32-bit pointers because that's what the image activator
14198  * assumes for the LIB$INITIALZE psect.
14199  */
14200 #if __INITIAL_POINTER_SIZE
14201 #pragma pointer_size save
14202 #pragma pointer_size 32
14203 #endif
14204
14205 /* Create a reference to the LIB$INITIALIZE function. */
14206 extern void LIB$INITIALIZE(void);
14207 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14208
14209 /* Create an array of pointers to the init functions in the special
14210  * LIB$INITIALIZE section. In our case, the array only has one entry.
14211  */
14212 #pragma extern_model save
14213 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
14214 extern void (* const vmsperl_unused_global_2[])() =
14215 {
14216    vmsperl_set_features,
14217 };
14218 #pragma extern_model restore
14219
14220 #if __INITIAL_POINTER_SIZE
14221 #pragma pointer_size restore
14222 #endif
14223
14224 #ifdef __cplusplus
14225 }
14226 #endif
14227
14228 #endif /* defined(__DECC) || defined(__DECCXX) */
14229 /*  End of vms.c */