vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993-2013 by Charles Bailey and others.
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  */
  10
  11 /*
  12  *   Yet small as was their hunted band
  13  *   still fell and fearless was each hand,
  14  *   and strong deeds they wrought yet oft,
  15  *   and loved the woods, whose ways more soft
  16  *   them seemed than thralls of that black throne
  17  *   to live and languish in halls of stone.
  18  *        "The Lay of Leithian", Canto II, lines 135-40
  19  *
  20  *     [p.162 of _The Lays of Beleriand_]
  21  */
  22
  23 #include <acedef.h>
  24 #include <acldef.h>
  25 #include <armdef.h>
  26 #if __CRTL_VER < 70300000
  27 /* needed for home-rolled utime() */
  28 #include <atrdef.h>
  29 #include <fibdef.h>
  30 #endif
  31 #include <chpdef.h>
  32 #include <clidef.h>
  33 #include <climsgdef.h>
  34 #include <dcdef.h>
  35 #include <descrip.h>
  36 #include <devdef.h>
  37 #include <dvidef.h>
  38 #include <float.h>
  39 #include <fscndef.h>
  40 #include <iodef.h>
  41 #include <jpidef.h>
  42 #include <kgbdef.h>
  43 #include <libclidef.h>
  44 #include <libdef.h>
  45 #include <lib$routines.h>
  46 #include <lnmdef.h>
  47 #include <ossdef.h>
  48 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  49 #include <ppropdef.h>
  50 #endif
  51 #include <prvdef.h>
  52 #include <psldef.h>
  53 #include <rms.h>
  54 #include <shrdef.h>
  55 #include <ssdef.h>
  56 #include <starlet.h>
  57 #include <strdef.h>
  58 #include <str$routines.h>
  59 #include <syidef.h>
  60 #include <uaidef.h>
  61 #include <uicdef.h>
  62 #include <stsdef.h>
  63 #include <efndef.h>
  64 #define NO_EFN EFN$C_ENF
  65
  66 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  67 int   decc$feature_get_index(const char *name);
  68 char* decc$feature_get_name(int index);
  69 int   decc$feature_get_value(int index, int mode);
  70 int   decc$feature_set_value(int index, int mode, int value);
  71 #else
  72 #include <unixlib.h>
  73 #endif
  74
  75 #pragma member_alignment save
  76 #pragma nomember_alignment longword
  77 struct item_list_3 {
  78         unsigned short len;
  79         unsigned short code;
  80         void * bufadr;
  81         unsigned short * retadr;
  82 };
  83 #pragma member_alignment restore
  84
  85 /* Older versions of ssdef.h don't have these */
  86 #ifndef SS$_INVFILFOROP
  87 #  define SS$_INVFILFOROP 3930
  88 #endif
  89 #ifndef SS$_NOSUCHOBJECT
  90 #  define SS$_NOSUCHOBJECT 2696
  91 #endif
  92
  93 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
  94 #define PERLIO_NOT_STDIO 0
  95
  96 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
  97  * code below needs to get to the underlying CRTL routines. */
  98 #define DONT_MASK_RTL_CALLS
  99 #include "EXTERN.h"
 100 #include "perl.h"
 101 #include "XSUB.h"
 102 /* Anticipating future expansion in lexical warnings . . . */
 103 #ifndef WARN_INTERNAL
 104 #  define WARN_INTERNAL WARN_MISC
 105 #endif
 106
 107 #ifdef VMS_LONGNAME_SUPPORT
 108 #include <libfildef.h>
 109 #endif
 110
 111 #if !defined(__VAX) && __CRTL_VER >= 80200000
 112 #ifdef lstat
 113 #undef lstat
 114 #endif
 115 #else
 116 #ifdef lstat
 117 #undef lstat
 118 #endif
 119 #define lstat(_x, _y) stat(_x, _y)
 120 #endif
 121
 122 /* Routine to create a decterm for use with the Perl debugger */
 123 /* No headers, this information was found in the Programming Concepts Manual */
 124
 125 static int (*decw_term_port)
 126    (const struct dsc$descriptor_s * display,
 127     const struct dsc$descriptor_s * setup_file,
 128     const struct dsc$descriptor_s * customization,
 129     struct dsc$descriptor_s * result_device_name,
 130     unsigned short * result_device_name_length,
 131     void * controller,
 132     void * char_buffer,
 133     void * char_change_buffer) = 0;
 134
 135 /* gcc's header files don't #define direct access macros
 136  * corresponding to VAXC's variant structs */
 137 #ifdef __GNUC__
 138 #  define uic$v_format uic$r_uic_form.uic$v_format
 139 #  define uic$v_group uic$r_uic_form.uic$v_group
 140 #  define uic$v_member uic$r_uic_form.uic$v_member
 141 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 142 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 143 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 144 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 145 #endif
 146
 147 #if defined(NEED_AN_H_ERRNO)
 148 dEXT int h_errno;
 149 #endif
 150
 151 #if defined(__DECC) || defined(__DECCXX)
 152 #pragma member_alignment save
 153 #pragma nomember_alignment longword
 154 #pragma message save
 155 #pragma message disable misalgndmem
 156 #endif
 157 struct itmlst_3 {
 158   unsigned short int buflen;
 159   unsigned short int itmcode;
 160   void *bufadr;
 161   unsigned short int *retlen;
 162 };
 163
 164 struct filescan_itmlst_2 {
 165     unsigned short length;
 166     unsigned short itmcode;
 167     char * component;
 168 };
 169
 170 struct vs_str_st {
 171     unsigned short length;
 172     char str[VMS_MAXRSS];
 173     unsigned short pad; /* for longword struct alignment */
 174 };
 175
 176 #if defined(__DECC) || defined(__DECCXX)
 177 #pragma message restore
 178 #pragma member_alignment restore
 179 #endif
 180
 181 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 182 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 183 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 184 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 185 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 186 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 187 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 188 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 189 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 190 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 191 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 192 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 193
 194 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 195 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 196 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 197 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 198
 199 static char *  int_rmsexpand_vms(
 200     const char * filespec, char * outbuf, unsigned opts);
 201 static char * int_rmsexpand_tovms(
 202     const char * filespec, char * outbuf, unsigned opts);
 203 static char *int_tovmsspec
 204    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 205 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 206 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 207 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 208
 209 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 210 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 211
 212 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 213  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 214  * the Perl facility.
 215  */
 216 #define PERL_LNM_MAX_ITER 10
 217
 218   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 219 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 220 #define MAX_DCL_SYMBOL          (8192)
 221 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 222 #else
 223 #define MAX_DCL_SYMBOL          (1024)
 224 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 225 #endif
 226
 227 static char *__mystrtolower(char *str)
 228 {
 229   if (str) for (; *str; ++str) *str= tolower(*str);
 230   return str;
 231 }
 232
 233 static struct dsc$descriptor_s fildevdsc =
 234   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 235 static struct dsc$descriptor_s crtlenvdsc =
 236   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 237 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 238 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 239 static struct dsc$descriptor_s **env_tables = defenv;
 240 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 241
 242 /* True if we shouldn't treat barewords as logicals during directory */
 243 /* munching */
 244 static int no_translate_barewords;
 245
 246 /* DECC Features that may need to affect how Perl interprets
 247  * displays filename information
 248  */
 249 static int decc_disable_to_vms_logname_translation = 1;
 250 static int decc_disable_posix_root = 1;
 251 int decc_efs_case_preserve = 0;
 252 static int decc_efs_charset = 0;
 253 static int decc_efs_charset_index = -1;
 254 static int decc_filename_unix_no_version = 0;
 255 static int decc_filename_unix_only = 0;
 256 int decc_filename_unix_report = 0;
 257 int decc_posix_compliant_pathnames = 0;
 258 int decc_readdir_dropdotnotype = 0;
 259 static int vms_process_case_tolerant = 1;
 260 int vms_vtf7_filenames = 0;
 261 int gnv_unix_shell = 0;
 262 static int vms_unlink_all_versions = 0;
 263 static int vms_posix_exit = 0;
 264
 265 /* bug workarounds if needed */
 266 int decc_bug_devnull = 1;
 267 int vms_bug_stat_filename = 0;
 268
 269 static int vms_debug_on_exception = 0;
 270 static int vms_debug_fileify = 0;
 271
 272 /* Simple logical name translation */
 273 static int simple_trnlnm
 274    (const char * logname,
 275     char * value,
 276     int value_len)
 277 {
 278     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 279     const unsigned long attr = LNM$M_CASE_BLIND;
 280     struct dsc$descriptor_s name_dsc;
 281     int status;
 282     unsigned short result;
 283     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 284                                 {0, 0, 0, 0}};
 285
 286     name_dsc.dsc$w_length = strlen(logname);
 287     name_dsc.dsc$a_pointer = (char *)logname;
 288     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 289     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 290
 291     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 292
 293     if ($VMS_STATUS_SUCCESS(status)) {
 294
 295          /* Null terminate and return the string */
 296         /*--------------------------------------*/
 297         value[result] = 0;
 298         return result;
 299     }
 300
 301     return 0;
 302 }
 303
 304
 305 /* Is this a UNIX file specification?
 306  *   No longer a simple check with EFS file specs
 307  *   For now, not a full check, but need to
 308  *   handle POSIX ^UP^ specifications
 309  *   Fixing to handle ^/ cases would require
 310  *   changes to many other conversion routines.
 311  */
 312
 313 static int is_unix_filespec(const char *path)
 314 {
 315 int ret_val;
 316 const char * pch1;
 317
 318     ret_val = 0;
 319     if (strncmp(path,"\"^UP^",5) != 0) {
 320         pch1 = strchr(path, '/');
 321         if (pch1 != NULL)
 322             ret_val = 1;
 323         else {
 324
 325             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 326             if (decc_filename_unix_report || decc_filename_unix_only) {
 327             if (strcmp(path,".") == 0)
 328                 ret_val = 1;
 329             }
 330         }
 331     }
 332     return ret_val;
 333 }
 334
 335 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 336  */
 337
 338 static void ucs2_to_vtf7
 339    (char *outspec,
 340     unsigned long ucs2_char,
 341     int * output_cnt)
 342 {
 343 unsigned char * ucs_ptr;
 344 int hex;
 345
 346     ucs_ptr = (unsigned char *)&ucs2_char;
 347
 348     outspec[0] = '^';
 349     outspec[1] = 'U';
 350     hex = (ucs_ptr[1] >> 4) & 0xf;
 351     if (hex < 0xA)
 352         outspec[2] = hex + '0';
 353     else
 354         outspec[2] = (hex - 9) + 'A';
 355     hex = ucs_ptr[1] & 0xF;
 356     if (hex < 0xA)
 357         outspec[3] = hex + '0';
 358     else {
 359         outspec[3] = (hex - 9) + 'A';
 360     }
 361     hex = (ucs_ptr[0] >> 4) & 0xf;
 362     if (hex < 0xA)
 363         outspec[4] = hex + '0';
 364     else
 365         outspec[4] = (hex - 9) + 'A';
 366     hex = ucs_ptr[1] & 0xF;
 367     if (hex < 0xA)
 368         outspec[5] = hex + '0';
 369     else {
 370         outspec[5] = (hex - 9) + 'A';
 371     }
 372     *output_cnt = 6;
 373 }
 374
 375
 376 /* This handles the conversion of a UNIX extended character set to a ^
 377  * escaped VMS character.
 378  * in a UNIX file specification.
 379  *
 380  * The output count variable contains the number of characters added
 381  * to the output string.
 382  *
 383  * The return value is the number of characters read from the input string
 384  */
 385 static int copy_expand_unix_filename_escape
 386   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 387 {
 388 int count;
 389 int utf8_flag;
 390
 391     utf8_flag = 0;
 392     if (utf8_fl)
 393       utf8_flag = *utf8_fl;
 394
 395     count = 0;
 396     *output_cnt = 0;
 397     if (*inspec >= 0x80) {
 398         if (utf8_fl && vms_vtf7_filenames) {
 399         unsigned long ucs_char;
 400
 401             ucs_char = 0;
 402
 403             if ((*inspec & 0xE0) == 0xC0) {
 404                 /* 2 byte Unicode */
 405                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 406                 if (ucs_char >= 0x80) {
 407                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 408                     return 2;
 409                 }
 410             } else if ((*inspec & 0xF0) == 0xE0) {
 411                 /* 3 byte Unicode */
 412                 ucs_char = ((inspec[0] & 0xF) << 12) +
 413                    ((inspec[1] & 0x3f) << 6) +
 414                    (inspec[2] & 0x3f);
 415                 if (ucs_char >= 0x800) {
 416                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 417                     return 3;
 418                 }
 419
 420 #if 0 /* I do not see longer sequences supported by OpenVMS */
 421       /* Maybe some one can fix this later */
 422             } else if ((*inspec & 0xF8) == 0xF0) {
 423                 /* 4 byte Unicode */
 424                 /* UCS-4 to UCS-2 */
 425             } else if ((*inspec & 0xFC) == 0xF8) {
 426                 /* 5 byte Unicode */
 427                 /* UCS-4 to UCS-2 */
 428             } else if ((*inspec & 0xFE) == 0xFC) {
 429                 /* 6 byte Unicode */
 430                 /* UCS-4 to UCS-2 */
 431 #endif
 432             }
 433         }
 434
 435         /* High bit set, but not a Unicode character! */
 436
 437         /* Non printing DECMCS or ISO Latin-1 character? */
 438         if ((unsigned char)*inspec <= 0x9F) {
 439             int hex;
 440             outspec[0] = '^';
 441             outspec++;
 442             hex = (*inspec >> 4) & 0xF;
 443             if (hex < 0xA)
 444                 outspec[1] = hex + '0';
 445             else {
 446                 outspec[1] = (hex - 9) + 'A';
 447             }
 448             hex = *inspec & 0xF;
 449             if (hex < 0xA)
 450                 outspec[2] = hex + '0';
 451             else {
 452                 outspec[2] = (hex - 9) + 'A';
 453             }
 454             *output_cnt = 3;
 455             return 1;
 456         } else if ((unsigned char)*inspec == 0xA0) {
 457             outspec[0] = '^';
 458             outspec[1] = 'A';
 459             outspec[2] = '0';
 460             *output_cnt = 3;
 461             return 1;
 462         } else if ((unsigned char)*inspec == 0xFF) {
 463             outspec[0] = '^';
 464             outspec[1] = 'F';
 465             outspec[2] = 'F';
 466             *output_cnt = 3;
 467             return 1;
 468         }
 469         *outspec = *inspec;
 470         *output_cnt = 1;
 471         return 1;
 472     }
 473
 474     /* Is this a macro that needs to be passed through?
 475      * Macros start with $( and an alpha character, followed
 476      * by a string of alpha numeric characters ending with a )
 477      * If this does not match, then encode it as ODS-5.
 478      */
 479     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 480     int tcnt;
 481
 482         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 483             tcnt = 3;
 484             outspec[0] = inspec[0];
 485             outspec[1] = inspec[1];
 486             outspec[2] = inspec[2];
 487
 488             while(isalnum(inspec[tcnt]) ||
 489                   (inspec[2] == '.') || (inspec[2] == '_')) {
 490                 outspec[tcnt] = inspec[tcnt];
 491                 tcnt++;
 492             }
 493             if (inspec[tcnt] == ')') {
 494                 outspec[tcnt] = inspec[tcnt];
 495                 tcnt++;
 496                 *output_cnt = tcnt;
 497                 return tcnt;
 498             }
 499         }
 500     }
 501
 502     switch (*inspec) {
 503     case 0x7f:
 504         outspec[0] = '^';
 505         outspec[1] = '7';
 506         outspec[2] = 'F';
 507         *output_cnt = 3;
 508         return 1;
 509         break;
 510     case '?':
 511         if (decc_efs_charset == 0)
 512           outspec[0] = '%';
 513         else
 514           outspec[0] = '?';
 515         *output_cnt = 1;
 516         return 1;
 517         break;
 518     case '.':
 519     case '~':
 520     case '!':
 521     case '#':
 522     case '&':
 523     case '\'':
 524     case '`':
 525     case '(':
 526     case ')':
 527     case '+':
 528     case '@':
 529     case '{':
 530     case '}':
 531     case ',':
 532     case ';':
 533     case '[':
 534     case ']':
 535     case '%':
 536     case '^':
 537     case '\\':
 538         /* Don't escape again if following character is
 539          * already something we escape.
 540          */
 541         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 542             *outspec = *inspec;
 543             *output_cnt = 1;
 544             return 1;
 545             break;
 546         }
 547         /* But otherwise fall through and escape it. */
 548     case '=':
 549         /* Assume that this is to be escaped */
 550         outspec[0] = '^';
 551         outspec[1] = *inspec;
 552         *output_cnt = 2;
 553         return 1;
 554         break;
 555     case ' ': /* space */
 556         /* Assume that this is to be escaped */
 557         outspec[0] = '^';
 558         outspec[1] = '_';
 559         *output_cnt = 2;
 560         return 1;
 561         break;
 562     default:
 563         *outspec = *inspec;
 564         *output_cnt = 1;
 565         return 1;
 566         break;
 567     }
 568     return 0;
 569 }
 570
 571
 572 /* This handles the expansion of a '^' prefix to the proper character
 573  * in a UNIX file specification.
 574  *
 575  * The output count variable contains the number of characters added
 576  * to the output string.
 577  *
 578  * The return value is the number of characters read from the input
 579  * string
 580  */
 581 static int copy_expand_vms_filename_escape
 582   (char *outspec, const char *inspec, int *output_cnt)
 583 {
 584 int count;
 585 int scnt;
 586
 587     count = 0;
 588     *output_cnt = 0;
 589     if (*inspec == '^') {
 590         inspec++;
 591         switch (*inspec) {
 592         /* Spaces and non-trailing dots should just be passed through,
 593          * but eat the escape character.
 594          */
 595         case '.':
 596             *outspec = *inspec;
 597             count += 2;
 598             (*output_cnt)++;
 599             break;
 600         case '_': /* space */
 601             *outspec = ' ';
 602             count += 2;
 603             (*output_cnt)++;
 604             break;
 605         case '^':
 606             /* Hmm.  Better leave the escape escaped. */
 607             outspec[0] = '^';
 608             outspec[1] = '^';
 609             count += 2;
 610             (*output_cnt) += 2;
 611             break;
 612         case 'U': /* Unicode - FIX-ME this is wrong. */
 613             inspec++;
 614             count++;
 615             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 616             if (scnt == 4) {
 617                 unsigned int c1, c2;
 618                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 619                 outspec[0] = c1 & 0xff;
 620                 outspec[1] = c2 & 0xff;
 621                 if (scnt > 1) {
 622                     (*output_cnt) += 2;
 623                     count += 4;
 624                 }
 625             }
 626             else {
 627                 /* Error - do best we can to continue */
 628                 *outspec = 'U';
 629                 outspec++;
 630                 (*output_cnt++);
 631                 *outspec = *inspec;
 632                 count++;
 633                 (*output_cnt++);
 634             }
 635             break;
 636         default:
 637             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 638             if (scnt == 2) {
 639                 /* Hex encoded */
 640                 unsigned int c1;
 641                 scnt = sscanf(inspec, "%2x", &c1);
 642                 outspec[0] = c1 & 0xff;
 643                 if (scnt > 0) {
 644                     (*output_cnt++);
 645                     count += 2;
 646                 }
 647             }
 648             else {
 649                 *outspec = *inspec;
 650                 count++;
 651                 (*output_cnt++);
 652             }
 653         }
 654     }
 655     else {
 656         *outspec = *inspec;
 657         count++;
 658         (*output_cnt)++;
 659     }
 660     return count;
 661 }
 662
 663 /* vms_split_path - Verify that the input file specification is a
 664  * VMS format file specification, and provide pointers to the components of
 665  * it.  With EFS format filenames, this is virtually the only way to
 666  * parse a VMS path specification into components.
 667  *
 668  * If the sum of the components do not add up to the length of the
 669  * string, then the passed file specification is probably a UNIX style
 670  * path.
 671  */
 672 static int vms_split_path
 673    (const char * path,
 674     char * * volume,
 675     int * vol_len,
 676     char * * root,
 677     int * root_len,
 678     char * * dir,
 679     int * dir_len,
 680     char * * name,
 681     int * name_len,
 682     char * * ext,
 683     int * ext_len,
 684     char * * version,
 685     int * ver_len)
 686 {
 687 struct dsc$descriptor path_desc;
 688 int status;
 689 unsigned long flags;
 690 int ret_stat;
 691 struct filescan_itmlst_2 item_list[9];
 692 const int filespec = 0;
 693 const int nodespec = 1;
 694 const int devspec = 2;
 695 const int rootspec = 3;
 696 const int dirspec = 4;
 697 const int namespec = 5;
 698 const int typespec = 6;
 699 const int verspec = 7;
 700
 701     /* Assume the worst for an easy exit */
 702     ret_stat = -1;
 703     *volume = NULL;
 704     *vol_len = 0;
 705     *root = NULL;
 706     *root_len = 0;
 707     *dir = NULL;
 708     *name = NULL;
 709     *name_len = 0;
 710     *ext = NULL;
 711     *ext_len = 0;
 712     *version = NULL;
 713     *ver_len = 0;
 714
 715     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 716     path_desc.dsc$w_length = strlen(path);
 717     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 718     path_desc.dsc$b_class = DSC$K_CLASS_S;
 719
 720     /* Get the total length, if it is shorter than the string passed
 721      * then this was probably not a VMS formatted file specification
 722      */
 723     item_list[filespec].itmcode = FSCN$_FILESPEC;
 724     item_list[filespec].length = 0;
 725     item_list[filespec].component = NULL;
 726
 727     /* If the node is present, then it gets considered as part of the
 728      * volume name to hopefully make things simple.
 729      */
 730     item_list[nodespec].itmcode = FSCN$_NODE;
 731     item_list[nodespec].length = 0;
 732     item_list[nodespec].component = NULL;
 733
 734     item_list[devspec].itmcode = FSCN$_DEVICE;
 735     item_list[devspec].length = 0;
 736     item_list[devspec].component = NULL;
 737
 738     /* root is a special case,  adding it to either the directory or
 739      * the device components will probably complicate things for the
 740      * callers of this routine, so leave it separate.
 741      */
 742     item_list[rootspec].itmcode = FSCN$_ROOT;
 743     item_list[rootspec].length = 0;
 744     item_list[rootspec].component = NULL;
 745
 746     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 747     item_list[dirspec].length = 0;
 748     item_list[dirspec].component = NULL;
 749
 750     item_list[namespec].itmcode = FSCN$_NAME;
 751     item_list[namespec].length = 0;
 752     item_list[namespec].component = NULL;
 753
 754     item_list[typespec].itmcode = FSCN$_TYPE;
 755     item_list[typespec].length = 0;
 756     item_list[typespec].component = NULL;
 757
 758     item_list[verspec].itmcode = FSCN$_VERSION;
 759     item_list[verspec].length = 0;
 760     item_list[verspec].component = NULL;
 761
 762     item_list[8].itmcode = 0;
 763     item_list[8].length = 0;
 764     item_list[8].component = NULL;
 765
 766     status = sys$filescan
 767        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 768         &flags, NULL, NULL);
 769     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 770
 771     /* If we parsed it successfully these two lengths should be the same */
 772     if (path_desc.dsc$w_length != item_list[filespec].length)
 773         return ret_stat;
 774
 775     /* If we got here, then it is a VMS file specification */
 776     ret_stat = 0;
 777
 778     /* set the volume name */
 779     if (item_list[nodespec].length > 0) {
 780         *volume = item_list[nodespec].component;
 781         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 782     }
 783     else {
 784         *volume = item_list[devspec].component;
 785         *vol_len = item_list[devspec].length;
 786     }
 787
 788     *root = item_list[rootspec].component;
 789     *root_len = item_list[rootspec].length;
 790
 791     *dir = item_list[dirspec].component;
 792     *dir_len = item_list[dirspec].length;
 793
 794     /* Now fun with versions and EFS file specifications
 795      * The parser can not tell the difference when a "." is a version
 796      * delimiter or a part of the file specification.
 797      */
 798     if ((decc_efs_charset) &&
 799         (item_list[verspec].length > 0) &&
 800         (item_list[verspec].component[0] == '.')) {
 801         *name = item_list[namespec].component;
 802         *name_len = item_list[namespec].length + item_list[typespec].length;
 803         *ext = item_list[verspec].component;
 804         *ext_len = item_list[verspec].length;
 805         *version = NULL;
 806         *ver_len = 0;
 807     }
 808     else {
 809         *name = item_list[namespec].component;
 810         *name_len = item_list[namespec].length;
 811         *ext = item_list[typespec].component;
 812         *ext_len = item_list[typespec].length;
 813         *version = item_list[verspec].component;
 814         *ver_len = item_list[verspec].length;
 815     }
 816     return ret_stat;
 817 }
 818
 819 /* Routine to determine if the file specification ends with .dir */
 820 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 821
 822     /* e_len must be 4, and version must be <= 2 characters */
 823     if (e_len != 4 || vs_len > 2)
 824         return 0;
 825
 826     /* If a version number is present, it needs to be one */
 827     if ((vs_len == 2) && (vs_spec[1] != '1'))
 828         return 0;
 829
 830     /* Look for the DIR on the extension */
 831     if (vms_process_case_tolerant) {
 832         if ((toupper(e_spec[1]) == 'D') &&
 833             (toupper(e_spec[2]) == 'I') &&
 834             (toupper(e_spec[3]) == 'R')) {
 835             return 1;
 836         }
 837     } else {
 838         /* Directory extensions are supposed to be in upper case only */
 839         /* I would not be surprised if this rule can not be enforced */
 840         /* if and when someone fully debugs the case sensitive mode */
 841         if ((e_spec[1] == 'D') &&
 842             (e_spec[2] == 'I') &&
 843             (e_spec[3] == 'R')) {
 844             return 1;
 845         }
 846     }
 847     return 0;
 848 }
 849
 850
 851 /* my_maxidx
 852  * Routine to retrieve the maximum equivalence index for an input
 853  * logical name.  Some calls to this routine have no knowledge if
 854  * the variable is a logical or not.  So on error we return a max
 855  * index of zero.
 856  */
 857 /*{{{int my_maxidx(const char *lnm) */
 858 static int
 859 my_maxidx(const char *lnm)
 860 {
 861     int status;
 862     int midx;
 863     int attr = LNM$M_CASE_BLIND;
 864     struct dsc$descriptor lnmdsc;
 865     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 866                                 {0, 0, 0, 0}};
 867
 868     lnmdsc.dsc$w_length = strlen(lnm);
 869     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 870     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 871     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 872
 873     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 874     if ((status & 1) == 0)
 875        midx = 0;
 876
 877     return (midx);
 878 }
 879 /*}}}*/
 880
 881 /* Routine to remove the 2-byte prefix from the translation of a
 882  * process-permanent file (PPF).
 883  */
 884 static inline unsigned short int
 885 S_remove_ppf_prefix(const char *lnm, char *eqv, unsigned short int eqvlen)
 886 {
 887     if (*((int *)lnm) == *((int *)"SYS$")                    &&
 888         eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00      &&
 889         ( (lnm[4] == 'O' && !strcmp(lnm,"SYS$OUTPUT"))  ||
 890           (lnm[4] == 'I' && !strcmp(lnm,"SYS$INPUT"))   ||
 891           (lnm[4] == 'E' && !strcmp(lnm,"SYS$ERROR"))   ||
 892           (lnm[4] == 'C' && !strcmp(lnm,"SYS$COMMAND")) )  ) {
 893
 894         memmove(eqv, eqv+4, eqvlen-4);
 895         eqvlen -= 4;
 896     }
 897     return eqvlen;
 898 }
 899
 900 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 901 int
 902 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 903   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 904 {
 905     const char *cp1;
 906     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 907     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 908     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 909     int midx;
 910     unsigned char acmode;
 911     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 912                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 913     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 914                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 915                                  {0, 0, 0, 0}};
 916     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 917 #if defined(PERL_IMPLICIT_CONTEXT)
 918     pTHX = NULL;
 919     if (PL_curinterp) {
 920       aTHX = PERL_GET_INTERP;
 921     } else {
 922       aTHX = NULL;
 923     }
 924 #endif
 925
 926     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 927       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 928     }
 929     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 930       *cp2 = _toupper(*cp1);
 931       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 932         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 933         return 0;
 934       }
 935     }
 936     lnmdsc.dsc$w_length = cp1 - lnm;
 937     lnmdsc.dsc$a_pointer = uplnm;
 938     uplnm[lnmdsc.dsc$w_length] = '\0';
 939     secure = flags & PERL__TRNENV_SECURE;
 940     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 941     if (!tabvec || !*tabvec) tabvec = env_tables;
 942
 943     for (curtab = 0; tabvec[curtab]; curtab++) {
 944       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 945         if (!ivenv && !secure) {
 946           char *eq;
 947           int i;
 948           if (!environ) {
 949             ivenv = 1;
 950 #if defined(PERL_IMPLICIT_CONTEXT)
 951             if (aTHX == NULL) {
 952                 fprintf(stderr,
 953                     "Can't read CRTL environ\n");
 954             } else
 955 #endif
 956                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 957             continue;
 958           }
 959           retsts = SS$_NOLOGNAM;
 960           for (i = 0; environ[i]; i++) {
 961             if ((eq = strchr(environ[i],'=')) &&
 962                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 963                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 964               eq++;
 965               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 966               if (!eqvlen) continue;
 967               retsts = SS$_NORMAL;
 968               break;
 969             }
 970           }
 971           if (retsts != SS$_NOLOGNAM) break;
 972         }
 973       }
 974       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 975                !str$case_blind_compare(&tmpdsc,&clisym)) {
 976         if (!ivsym && !secure) {
 977           unsigned short int deflen = LNM$C_NAMLENGTH;
 978           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 979           /* dynamic dsc to accommodate possible long value */
 980           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 981           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 982           if (retsts & 1) {
 983             if (eqvlen > MAX_DCL_SYMBOL) {
 984               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 985               eqvlen = MAX_DCL_SYMBOL;
 986               /* Special hack--we might be called before the interpreter's */
 987               /* fully initialized, in which case either thr or PL_curcop */
 988               /* might be bogus. We have to check, since ckWARN needs them */
 989               /* both to be valid if running threaded */
 990 #if defined(PERL_IMPLICIT_CONTEXT)
 991               if (aTHX == NULL) {
 992                   fprintf(stderr,
 993                      "Value of CLI symbol \"%s\" too long",lnm);
 994               } else
 995 #endif
 996                 if (ckWARN(WARN_MISC)) {
 997                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 998                 }
 999             }
1000             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1001           }
1002           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1003           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1004           if (retsts == LIB$_NOSUCHSYM) continue;
1005           break;
1006         }
1007       }
1008       else if (!ivlnm) {
1009         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1010           midx = my_maxidx(lnm);
1011           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1012             lnmlst[1].bufadr = cp2;
1013             eqvlen = 0;
1014             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1015             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1016             if (retsts == SS$_NOLOGNAM) break;
1017             eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
1018             cp2 += eqvlen;
1019             *cp2 = '\0';
1020           }
1021           if ((retsts == SS$_IVLOGNAM) ||
1022               (retsts == SS$_NOLOGNAM)) { continue; }
1023           eqvlen = strlen(eqv);
1024         }
1025         else {
1026           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1027           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1028           if (retsts == SS$_NOLOGNAM) continue;
1029           eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
1030           eqv[eqvlen] = '\0';
1031         }
1032         break;
1033       }
1034     }
1035     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1036     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1037              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1038              retsts == SS$_NOLOGNAM) {
1039       set_errno(EINVAL);  set_vaxc_errno(retsts);
1040     }
1041     else _ckvmssts_noperl(retsts);
1042     return 0;
1043 }  /* end of vmstrnenv */
1044 /*}}}*/
1045
1046 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1047 /* Define as a function so we can access statics. */
1048 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1049 {
1050     int flags = 0;
1051
1052 #if defined(PERL_IMPLICIT_CONTEXT)
1053     if (aTHX != NULL)
1054 #endif
1055 #ifdef SECURE_INTERNAL_GETENV
1056         flags = (PL_curinterp ? TAINTING_get : will_taint) ?
1057                  PERL__TRNENV_SECURE : 0;
1058 #endif
1059
1060     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1061 }
1062 /*}}}*/
1063
1064 /* my_getenv
1065  * Note: Uses Perl temp to store result so char * can be returned to
1066  * caller; this pointer will be invalidated at next Perl statement
1067  * transition.
1068  * We define this as a function rather than a macro in terms of my_getenv_len()
1069  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1070  * allocate SVs).
1071  */
1072 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1073 char *
1074 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1075 {
1076     const char *cp1;
1077     static char *__my_getenv_eqv = NULL;
1078     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1079     unsigned long int idx = 0;
1080     int success, secure, saverr, savvmserr;
1081     int midx, flags;
1082     SV *tmpsv;
1083
1084     midx = my_maxidx(lnm) + 1;
1085
1086     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1087       /* Set up a temporary buffer for the return value; Perl will
1088        * clean it up at the next statement transition */
1089       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1090       if (!tmpsv) return NULL;
1091       eqv = SvPVX(tmpsv);
1092     }
1093     else {
1094       /* Assume no interpreter ==> single thread */
1095       if (__my_getenv_eqv != NULL) {
1096         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1097       }
1098       else {
1099         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1100       }
1101       eqv = __my_getenv_eqv;
1102     }
1103
1104     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1105     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1106       int len;
1107       getcwd(eqv,LNM$C_NAMLENGTH);
1108
1109       len = strlen(eqv);
1110
1111       /* Get rid of "000000/ in rooted filespecs */
1112       if (len > 7) {
1113         char * zeros;
1114         zeros = strstr(eqv, "/000000/");
1115         if (zeros != NULL) {
1116           int mlen;
1117           mlen = len - (zeros - eqv) - 7;
1118           memmove(zeros, &zeros[7], mlen);
1119           len = len - 7;
1120           eqv[len] = '\0';
1121         }
1122       }
1123       return eqv;
1124     }
1125     else {
1126       /* Impose security constraints only if tainting */
1127       if (sys) {
1128         /* Impose security constraints only if tainting */
1129         secure = PL_curinterp ? TAINTING_get : will_taint;
1130         saverr = errno;  savvmserr = vaxc$errno;
1131       }
1132       else {
1133         secure = 0;
1134       }
1135
1136       flags =
1137 #ifdef SECURE_INTERNAL_GETENV
1138               secure ? PERL__TRNENV_SECURE : 0
1139 #else
1140               0
1141 #endif
1142       ;
1143
1144       /* For the getenv interface we combine all the equivalence names
1145        * of a search list logical into one value to acquire a maximum
1146        * value length of 255*128 (assuming %ENV is using logicals).
1147        */
1148       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1149
1150       /* If the name contains a semicolon-delimited index, parse it
1151        * off and make sure we only retrieve the equivalence name for
1152        * that index.  */
1153       if ((cp2 = strchr(lnm,';')) != NULL) {
1154         my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1155         idx = strtoul(cp2+1,NULL,0);
1156         lnm = uplnm;
1157         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1158       }
1159
1160       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1161
1162       /* Discard NOLOGNAM on internal calls since we're often looking
1163        * for an optional name, and this "error" often shows up as the
1164        * (bogus) exit status for a die() call later on.  */
1165       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1166       return success ? eqv : NULL;
1167     }
1168
1169 }  /* end of my_getenv() */
1170 /*}}}*/
1171
1172
1173 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1174 char *
1175 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1176 {
1177     const char *cp1;
1178     char *buf, *cp2;
1179     unsigned long idx = 0;
1180     int midx, flags;
1181     static char *__my_getenv_len_eqv = NULL;
1182     int secure, saverr, savvmserr;
1183     SV *tmpsv;
1184
1185     midx = my_maxidx(lnm) + 1;
1186
1187     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1188       /* Set up a temporary buffer for the return value; Perl will
1189        * clean it up at the next statement transition */
1190       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1191       if (!tmpsv) return NULL;
1192       buf = SvPVX(tmpsv);
1193     }
1194     else {
1195       /* Assume no interpreter ==> single thread */
1196       if (__my_getenv_len_eqv != NULL) {
1197         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1198       }
1199       else {
1200         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1201       }
1202       buf = __my_getenv_len_eqv;
1203     }
1204
1205     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1206     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1207     char * zeros;
1208
1209       getcwd(buf,LNM$C_NAMLENGTH);
1210       *len = strlen(buf);
1211
1212       /* Get rid of "000000/ in rooted filespecs */
1213       if (*len > 7) {
1214       zeros = strstr(buf, "/000000/");
1215       if (zeros != NULL) {
1216         int mlen;
1217         mlen = *len - (zeros - buf) - 7;
1218         memmove(zeros, &zeros[7], mlen);
1219         *len = *len - 7;
1220         buf[*len] = '\0';
1221         }
1222       }
1223       return buf;
1224     }
1225     else {
1226       if (sys) {
1227         /* Impose security constraints only if tainting */
1228         secure = PL_curinterp ? TAINTING_get : will_taint;
1229         saverr = errno;  savvmserr = vaxc$errno;
1230       }
1231       else {
1232         secure = 0;
1233       }
1234
1235       flags =
1236 #ifdef SECURE_INTERNAL_GETENV
1237               secure ? PERL__TRNENV_SECURE : 0
1238 #else
1239               0
1240 #endif
1241       ;
1242
1243       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1244
1245       if ((cp2 = strchr(lnm,';')) != NULL) {
1246         my_strlcpy(buf, lnm, cp2 - lnm + 1);
1247         idx = strtoul(cp2+1,NULL,0);
1248         lnm = buf;
1249         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1250       }
1251
1252       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1253
1254       /* Get rid of "000000/ in rooted filespecs */
1255       if (*len > 7) {
1256       char * zeros;
1257         zeros = strstr(buf, "/000000/");
1258         if (zeros != NULL) {
1259           int mlen;
1260           mlen = *len - (zeros - buf) - 7;
1261           memmove(zeros, &zeros[7], mlen);
1262           *len = *len - 7;
1263           buf[*len] = '\0';
1264         }
1265       }
1266
1267       /* Discard NOLOGNAM on internal calls since we're often looking
1268        * for an optional name, and this "error" often shows up as the
1269        * (bogus) exit status for a die() call later on.  */
1270       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1271       return *len ? buf : NULL;
1272     }
1273
1274 }  /* end of my_getenv_len() */
1275 /*}}}*/
1276
1277 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1278
1279 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1280
1281 /*{{{ void prime_env_iter() */
1282 void
1283 prime_env_iter(void)
1284 /* Fill the %ENV associative array with all logical names we can
1285  * find, in preparation for iterating over it.
1286  */
1287 {
1288   static int primed = 0;
1289   HV *seenhv = NULL, *envhv;
1290   SV *sv = NULL;
1291   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1292   unsigned short int chan;
1293 #ifndef CLI$M_TRUSTED
1294 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1295 #endif
1296   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1297   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1298   long int i;
1299   bool have_sym = FALSE, have_lnm = FALSE;
1300   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1301   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1302   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1303   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1304   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1305 #if defined(PERL_IMPLICIT_CONTEXT)
1306   pTHX;
1307 #endif
1308 #if defined(USE_ITHREADS)
1309   static perl_mutex primenv_mutex;
1310   MUTEX_INIT(&primenv_mutex);
1311 #endif
1312
1313 #if defined(PERL_IMPLICIT_CONTEXT)
1314     /* We jump through these hoops because we can be called at */
1315     /* platform-specific initialization time, which is before anything is */
1316     /* set up--we can't even do a plain dTHX since that relies on the */
1317     /* interpreter structure to be initialized */
1318     if (PL_curinterp) {
1319       aTHX = PERL_GET_INTERP;
1320     } else {
1321       /* we never get here because the NULL pointer will cause the */
1322       /* several of the routines called by this routine to access violate */
1323
1324       /* This routine is only called by hv.c/hv_iterinit which has a */
1325       /* context, so the real fix may be to pass it through instead of */
1326       /* the hoops above */
1327       aTHX = NULL;
1328     }
1329 #endif
1330
1331   if (primed || !PL_envgv) return;
1332   MUTEX_LOCK(&primenv_mutex);
1333   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1334   envhv = GvHVn(PL_envgv);
1335   /* Perform a dummy fetch as an lval to insure that the hash table is
1336    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1337   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1338
1339   for (i = 0; env_tables[i]; i++) {
1340      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1341          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1342      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1343   }
1344   if (have_sym || have_lnm) {
1345     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1346     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1347     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1348     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1349   }
1350
1351   for (i--; i >= 0; i--) {
1352     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1353       char *start;
1354       int j;
1355       for (j = 0; environ[j]; j++) {
1356         if (!(start = strchr(environ[j],'='))) {
1357           if (ckWARN(WARN_INTERNAL))
1358             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1359         }
1360         else {
1361           start++;
1362           sv = newSVpv(start,0);
1363           SvTAINTED_on(sv);
1364           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1365         }
1366       }
1367       continue;
1368     }
1369     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1370              !str$case_blind_compare(&tmpdsc,&clisym)) {
1371       my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1372       cmddsc.dsc$w_length = 20;
1373       if (env_tables[i]->dsc$w_length == 12 &&
1374           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1375           !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local  *", sizeof(cmd)-12);
1376       flags = defflags | CLI$M_NOLOGNAM;
1377     }
1378     else {
1379       my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1380       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1381         my_strlcat(cmd," /Table=", sizeof(cmd));
1382         cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, sizeof(cmd));
1383       }
1384       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1385       flags = defflags | CLI$M_NOCLISYM;
1386     }
1387
1388     /* Create a new subprocess to execute each command, to exclude the
1389      * remote possibility that someone could subvert a mbx or file used
1390      * to write multiple commands to a single subprocess.
1391      */
1392     do {
1393       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1394                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1395       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1396       defflags &= ~CLI$M_TRUSTED;
1397     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1398     _ckvmssts(retsts);
1399     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1400     if (seenhv) SvREFCNT_dec(seenhv);
1401     seenhv = newHV();
1402     while (1) {
1403       char *cp1, *cp2, *key;
1404       unsigned long int sts, iosb[2], retlen, keylen;
1405       U32 hash;
1406
1407       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1408       if (sts & 1) sts = iosb[0] & 0xffff;
1409       if (sts == SS$_ENDOFFILE) {
1410         int wakect = 0;
1411         while (substs == 0) { sys$hiber(); wakect++;}
1412         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1413         _ckvmssts(substs);
1414         break;
1415       }
1416       _ckvmssts(sts);
1417       retlen = iosb[0] >> 16;
1418       if (!retlen) continue;  /* blank line */
1419       buf[retlen] = '\0';
1420       if (iosb[1] != subpid) {
1421         if (iosb[1]) {
1422           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1423         }
1424         continue;
1425       }
1426       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1427         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1428
1429       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1430       if (*cp1 == '(' || /* Logical name table name */
1431           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1432       if (*cp1 == '"') cp1++;
1433       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1434       key = cp1;  keylen = cp2 - cp1;
1435       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1436       while (*cp2 && *cp2 != '=') cp2++;
1437       while (*cp2 && *cp2 == '=') cp2++;
1438       while (*cp2 && *cp2 == ' ') cp2++;
1439       if (*cp2 == '"') {  /* String translation; may embed "" */
1440         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1441         cp2++;  cp1--; /* Skip "" surrounding translation */
1442       }
1443       else {  /* Numeric translation */
1444         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1445         cp1--;  /* stop on last non-space char */
1446       }
1447       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1448         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1449         continue;
1450       }
1451       PERL_HASH(hash,key,keylen);
1452
1453       if (cp1 == cp2 && *cp2 == '.') {
1454         /* A single dot usually means an unprintable character, such as a null
1455          * to indicate a zero-length value.  Get the actual value to make sure.
1456          */
1457         char lnm[LNM$C_NAMLENGTH+1];
1458         char eqv[MAX_DCL_SYMBOL+1];
1459         int trnlen;
1460         strncpy(lnm, key, keylen);
1461         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1462         sv = newSVpvn(eqv, strlen(eqv));
1463       }
1464       else {
1465         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1466       }
1467
1468       SvTAINTED_on(sv);
1469       hv_store(envhv,key,keylen,sv,hash);
1470       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1471     }
1472     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1473       /* get the PPFs for this process, not the subprocess */
1474       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1475       char eqv[LNM$C_NAMLENGTH+1];
1476       int trnlen, i;
1477       for (i = 0; ppfs[i]; i++) {
1478         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1479         sv = newSVpv(eqv,trnlen);
1480         SvTAINTED_on(sv);
1481         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1482       }
1483     }
1484   }
1485   primed = 1;
1486   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1487   if (buf) Safefree(buf);
1488   if (seenhv) SvREFCNT_dec(seenhv);
1489   MUTEX_UNLOCK(&primenv_mutex);
1490   return;
1491
1492 }  /* end of prime_env_iter */
1493 /*}}}*/
1494
1495
1496 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1497 /* Define or delete an element in the same "environment" as
1498  * vmstrnenv().  If an element is to be deleted, it's removed from
1499  * the first place it's found.  If it's to be set, it's set in the
1500  * place designated by the first element of the table vector.
1501  * Like setenv() returns 0 for success, non-zero on error.
1502  */
1503 int
1504 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1505 {
1506     const char *cp1;
1507     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1508     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1509     int nseg = 0, j;
1510     unsigned long int retsts, usermode = PSL$C_USER;
1511     struct itmlst_3 *ile, *ilist;
1512     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1513                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1514                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1515     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1516     $DESCRIPTOR(local,"_LOCAL");
1517
1518     if (!lnm) {
1519         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1520         return SS$_IVLOGNAM;
1521     }
1522
1523     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1524       *cp2 = _toupper(*cp1);
1525       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1526         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1527         return SS$_IVLOGNAM;
1528       }
1529     }
1530     lnmdsc.dsc$w_length = cp1 - lnm;
1531     if (!tabvec || !*tabvec) tabvec = env_tables;
1532
1533     if (!eqv) {  /* we're deleting n element */
1534       for (curtab = 0; tabvec[curtab]; curtab++) {
1535         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1536         int i;
1537           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1538             if ((cp1 = strchr(environ[i],'=')) &&
1539                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1540                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1541 #ifdef HAS_SETENV
1542               return setenv(lnm,"",1) ? vaxc$errno : 0;
1543             }
1544           }
1545           ivenv = 1; retsts = SS$_NOLOGNAM;
1546 #else
1547               if (ckWARN(WARN_INTERNAL))
1548                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1549               ivenv = 1; retsts = SS$_NOSUCHPGM;
1550               break;
1551             }
1552           }
1553 #endif
1554         }
1555         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1556                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1557           unsigned int symtype;
1558           if (tabvec[curtab]->dsc$w_length == 12 &&
1559               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1560               !str$case_blind_compare(&tmpdsc,&local))
1561             symtype = LIB$K_CLI_LOCAL_SYM;
1562           else symtype = LIB$K_CLI_GLOBAL_SYM;
1563           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1564           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1565           if (retsts == LIB$_NOSUCHSYM) continue;
1566           break;
1567         }
1568         else if (!ivlnm) {
1569           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1570           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1571           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1572           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1573           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1574         }
1575       }
1576     }
1577     else {  /* we're defining a value */
1578       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1579 #ifdef HAS_SETENV
1580         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1581 #else
1582         if (ckWARN(WARN_INTERNAL))
1583           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1584         retsts = SS$_NOSUCHPGM;
1585 #endif
1586       }
1587       else {
1588         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1589         eqvdsc.dsc$w_length  = strlen(eqv);
1590         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1591             !str$case_blind_compare(&tmpdsc,&clisym)) {
1592           unsigned int symtype;
1593           if (tabvec[0]->dsc$w_length == 12 &&
1594               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1595                !str$case_blind_compare(&tmpdsc,&local))
1596             symtype = LIB$K_CLI_LOCAL_SYM;
1597           else symtype = LIB$K_CLI_GLOBAL_SYM;
1598           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1599         }
1600         else {
1601           if (!*eqv) eqvdsc.dsc$w_length = 1;
1602           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1603
1604             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1605             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1606               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1607                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1608               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1609               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1610             }
1611
1612             Newx(ilist,nseg+1,struct itmlst_3);
1613             ile = ilist;
1614             if (!ile) {
1615               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1616               return SS$_INSFMEM;
1617             }
1618             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1619
1620             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1621               ile->itmcode = LNM$_STRING;
1622               ile->bufadr = c;
1623               if ((j+1) == nseg) {
1624                 ile->buflen = strlen(c);
1625                 /* in case we are truncating one that's too long */
1626                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1627               }
1628               else {
1629                 ile->buflen = LNM$C_NAMLENGTH;
1630               }
1631             }
1632
1633             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1634             Safefree (ilist);
1635           }
1636           else {
1637             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1638           }
1639         }
1640       }
1641     }
1642     if (!(retsts & 1)) {
1643       switch (retsts) {
1644         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1645         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1646           set_errno(EVMSERR); break;
1647         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1648         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1649           set_errno(EINVAL); break;
1650         case SS$_NOPRIV:
1651           set_errno(EACCES); break;
1652         default:
1653           _ckvmssts(retsts);
1654           set_errno(EVMSERR);
1655        }
1656        set_vaxc_errno(retsts);
1657        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1658     }
1659     else {
1660       /* We reset error values on success because Perl does an hv_fetch()
1661        * before each hv_store(), and if the thing we're setting didn't
1662        * previously exist, we've got a leftover error message.  (Of course,
1663        * this fails in the face of
1664        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1665        * in that the error reported in $! isn't spurious,
1666        * but it's right more often than not.)
1667        */
1668       set_errno(0); set_vaxc_errno(retsts);
1669       return 0;
1670     }
1671
1672 }  /* end of vmssetenv() */
1673 /*}}}*/
1674
1675 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1676 /* This has to be a function since there's a prototype for it in proto.h */
1677 void
1678 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1679 {
1680     if (lnm && *lnm) {
1681       int len = strlen(lnm);
1682       if  (len == 7) {
1683         char uplnm[8];
1684         int i;
1685         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1686         if (!strcmp(uplnm,"DEFAULT")) {
1687           if (eqv && *eqv) my_chdir(eqv);
1688           return;
1689         }
1690     }
1691   }
1692   (void) vmssetenv(lnm,eqv,NULL);
1693 }
1694 /*}}}*/
1695
1696 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1697 /*  vmssetuserlnm
1698  *  sets a user-mode logical in the process logical name table
1699  *  used for redirection of sys$error
1700  */
1701 void
1702 Perl_vmssetuserlnm(const char *name, const char *eqv)
1703 {
1704     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1705     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1706     unsigned long int iss, attr = LNM$M_CONFINE;
1707     unsigned char acmode = PSL$C_USER;
1708     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1709                                  {0, 0, 0, 0}};
1710     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1711     d_name.dsc$w_length = strlen(name);
1712
1713     lnmlst[0].buflen = strlen(eqv);
1714     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1715
1716     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1717     if (!(iss&1)) lib$signal(iss);
1718 }
1719 /*}}}*/
1720
1721
1722 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1723 /* my_crypt - VMS password hashing
1724  * my_crypt() provides an interface compatible with the Unix crypt()
1725  * C library function, and uses sys$hash_password() to perform VMS
1726  * password hashing.  The quadword hashed password value is returned
1727  * as a NUL-terminated 8 character string.  my_crypt() does not change
1728  * the case of its string arguments; in order to match the behavior
1729  * of LOGINOUT et al., alphabetic characters in both arguments must
1730  *  be upcased by the caller.
1731  *
1732  * - fix me to call ACM services when available
1733  */
1734 char *
1735 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1736 {
1737 #   ifndef UAI$C_PREFERRED_ALGORITHM
1738 #     define UAI$C_PREFERRED_ALGORITHM 127
1739 #   endif
1740     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1741     unsigned short int salt = 0;
1742     unsigned long int sts;
1743     struct const_dsc {
1744         unsigned short int dsc$w_length;
1745         unsigned char      dsc$b_type;
1746         unsigned char      dsc$b_class;
1747         const char *       dsc$a_pointer;
1748     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1749        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1750     struct itmlst_3 uailst[3] = {
1751         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1752         { sizeof salt, UAI$_SALT,    &salt, 0},
1753         { 0,           0,            NULL,  NULL}};
1754     static char hash[9];
1755
1756     usrdsc.dsc$w_length = strlen(usrname);
1757     usrdsc.dsc$a_pointer = usrname;
1758     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1759       switch (sts) {
1760         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1761           set_errno(EACCES);
1762           break;
1763         case RMS$_RNF:
1764           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1765           break;
1766         default:
1767           set_errno(EVMSERR);
1768       }
1769       set_vaxc_errno(sts);
1770       if (sts != RMS$_RNF) return NULL;
1771     }
1772
1773     txtdsc.dsc$w_length = strlen(textpasswd);
1774     txtdsc.dsc$a_pointer = textpasswd;
1775     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1776       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1777     }
1778
1779     return (char *) hash;
1780
1781 }  /* end of my_crypt() */
1782 /*}}}*/
1783
1784
1785 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1786 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1787 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1788
1789 /* fixup barenames that are directories for internal use.
1790  * There have been problems with the consistent handling of UNIX
1791  * style directory names when routines are presented with a name that
1792  * has no directory delimiters at all.  So this routine will eventually
1793  * fix the issue.
1794  */
1795 static char * fixup_bare_dirnames(const char * name)
1796 {
1797   if (decc_disable_to_vms_logname_translation) {
1798 /* fix me */
1799   }
1800   return NULL;
1801 }
1802
1803 /* 8.3, remove() is now broken on symbolic links */
1804 static int rms_erase(const char * vmsname);
1805
1806
1807 /* mp_do_kill_file
1808  * A little hack to get around a bug in some implementation of remove()
1809  * that do not know how to delete a directory
1810  *
1811  * Delete any file to which user has control access, regardless of whether
1812  * delete access is explicitly allowed.
1813  * Limitations: User must have write access to parent directory.
1814  *              Does not block signals or ASTs; if interrupted in midstream
1815  *              may leave file with an altered ACL.
1816  * HANDLE WITH CARE!
1817  */
1818 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1819 static int
1820 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1821 {
1822     char *vmsname;
1823     char *rslt;
1824     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1825     unsigned long int cxt = 0, aclsts, fndsts;
1826     int rmsts = -1;
1827     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1828     struct myacedef {
1829       unsigned char myace$b_length;
1830       unsigned char myace$b_type;
1831       unsigned short int myace$w_flags;
1832       unsigned long int myace$l_access;
1833       unsigned long int myace$l_ident;
1834     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1835                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1836       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1837      struct itmlst_3
1838        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1839                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1840        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1841        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1842        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1843        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1844
1845     /* Expand the input spec using RMS, since the CRTL remove() and
1846      * system services won't do this by themselves, so we may miss
1847      * a file "hiding" behind a logical name or search list. */
1848     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1849     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1850
1851     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1852     if (rslt == NULL) {
1853         PerlMem_free(vmsname);
1854         return -1;
1855       }
1856
1857     /* Erase the file */
1858     rmsts = rms_erase(vmsname);
1859
1860     /* Did it succeed */
1861     if ($VMS_STATUS_SUCCESS(rmsts)) {
1862         PerlMem_free(vmsname);
1863         return 0;
1864       }
1865
1866     /* If not, can changing protections help? */
1867     if (rmsts != RMS$_PRV) {
1868       set_vaxc_errno(rmsts);
1869       PerlMem_free(vmsname);
1870       return -1;
1871     }
1872
1873     /* No, so we get our own UIC to use as a rights identifier,
1874      * and the insert an ACE at the head of the ACL which allows us
1875      * to delete the file.
1876      */
1877     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1878     fildsc.dsc$w_length = strlen(vmsname);
1879     fildsc.dsc$a_pointer = vmsname;
1880     cxt = 0;
1881     newace.myace$l_ident = oldace.myace$l_ident;
1882     rmsts = -1;
1883     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1884       switch (aclsts) {
1885         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1886           set_errno(ENOENT); break;
1887         case RMS$_DIR:
1888           set_errno(ENOTDIR); break;
1889         case RMS$_DEV:
1890           set_errno(ENODEV); break;
1891         case RMS$_SYN: case SS$_INVFILFOROP:
1892           set_errno(EINVAL); break;
1893         case RMS$_PRV:
1894           set_errno(EACCES); break;
1895         default:
1896           _ckvmssts_noperl(aclsts);
1897       }
1898       set_vaxc_errno(aclsts);
1899       PerlMem_free(vmsname);
1900       return -1;
1901     }
1902     /* Grab any existing ACEs with this identifier in case we fail */
1903     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1904     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1905                     || fndsts == SS$_NOMOREACE ) {
1906       /* Add the new ACE . . . */
1907       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1908         goto yourroom;
1909
1910       rmsts = rms_erase(vmsname);
1911       if ($VMS_STATUS_SUCCESS(rmsts)) {
1912         rmsts = 0;
1913         }
1914         else {
1915         rmsts = -1;
1916         /* We blew it - dir with files in it, no write priv for
1917          * parent directory, etc.  Put things back the way they were. */
1918         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1919           goto yourroom;
1920         if (fndsts & 1) {
1921           addlst[0].bufadr = &oldace;
1922           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1923             goto yourroom;
1924         }
1925       }
1926     }
1927
1928     yourroom:
1929     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1930     /* We just deleted it, so of course it's not there.  Some versions of
1931      * VMS seem to return success on the unlock operation anyhow (after all
1932      * the unlock is successful), but others don't.
1933      */
1934     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1935     if (aclsts & 1) aclsts = fndsts;
1936     if (!(aclsts & 1)) {
1937       set_errno(EVMSERR);
1938       set_vaxc_errno(aclsts);
1939     }
1940
1941     PerlMem_free(vmsname);
1942     return rmsts;
1943
1944 }  /* end of kill_file() */
1945 /*}}}*/
1946
1947
1948 /*{{{int do_rmdir(char *name)*/
1949 int
1950 Perl_do_rmdir(pTHX_ const char *name)
1951 {
1952     char * dirfile;
1953     int retval;
1954     Stat_t st;
1955
1956     /* lstat returns a VMS fileified specification of the name */
1957     /* that is looked up, and also lets verifies that this is a directory */
1958
1959     retval = flex_lstat(name, &st);
1960     if (retval != 0) {
1961         char * ret_spec;
1962
1963         /* Due to a historical feature, flex_stat/lstat can not see some */
1964         /* Unix format file names that the rest of the CRTL can see */
1965         /* Fixing that feature will cause some perl tests to fail */
1966         /* So try this one more time. */
1967
1968         retval = lstat(name, &st.crtl_stat);
1969         if (retval != 0)
1970             return -1;
1971
1972         /* force it to a file spec for the kill file to work. */
1973         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1974         if (ret_spec == NULL) {
1975             errno = EIO;
1976             return -1;
1977         }
1978     }
1979
1980     if (!S_ISDIR(st.st_mode)) {
1981         errno = ENOTDIR;
1982         retval = -1;
1983     }
1984     else {
1985         dirfile = st.st_devnam;
1986
1987         /* It may be possible for flex_stat to find a file and vmsify() to */
1988         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
1989         /* with that case, so fail it */
1990         if (dirfile[0] == 0) {
1991             errno = EIO;
1992             return -1;
1993         }
1994
1995         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1996     }
1997
1998     return retval;
1999
2000 }  /* end of do_rmdir */
2001 /*}}}*/
2002
2003 /* kill_file
2004  * Delete any file to which user has control access, regardless of whether
2005  * delete access is explicitly allowed.
2006  * Limitations: User must have write access to parent directory.
2007  *              Does not block signals or ASTs; if interrupted in midstream
2008  *              may leave file with an altered ACL.
2009  * HANDLE WITH CARE!
2010  */
2011 /*{{{int kill_file(char *name)*/
2012 int
2013 Perl_kill_file(pTHX_ const char *name)
2014 {
2015     char * vmsfile;
2016     Stat_t st;
2017     int rmsts;
2018
2019     /* Convert the filename to VMS format and see if it is a directory */
2020     /* flex_lstat returns a vmsified file specification */
2021     rmsts = flex_lstat(name, &st);
2022     if (rmsts != 0) {
2023
2024         /* Due to a historical feature, flex_stat/lstat can not see some */
2025         /* Unix format file names that the rest of the CRTL can see when */
2026         /* ODS-2 file specifications are in use. */
2027         /* Fixing that feature will cause some perl tests to fail */
2028         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2029         st.st_mode = 0;
2030         vmsfile = (char *) name; /* cast ok */
2031
2032     } else {
2033         vmsfile = st.st_devnam;
2034         if (vmsfile[0] == 0) {
2035             /* It may be possible for flex_stat to find a file and vmsify() */
2036             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2037             /* deal with that case, so fail it */
2038             errno = EIO;
2039             return -1;
2040         }
2041     }
2042
2043     /* Remove() is allowed to delete directories, according to the X/Open
2044      * specifications.
2045      * This may need special handling to work with the ACL hacks.
2046      */
2047     if (S_ISDIR(st.st_mode)) {
2048         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2049         return rmsts;
2050     }
2051
2052     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2053
2054     /* Need to delete all versions ? */
2055     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2056         int i = 0;
2057
2058         /* Just use lstat() here as do not need st_dev */
2059         /* and we know that the file is in VMS format or that */
2060         /* because of a historical bug, flex_stat can not see the file */
2061         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2062             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2063             if (rmsts != 0)
2064                 break;
2065             i++;
2066
2067             /* Make sure that we do not loop forever */
2068             if (i > 32767) {
2069                 errno = EIO;
2070                 rmsts = -1;
2071                 break;
2072             }
2073         }
2074     }
2075
2076     return rmsts;
2077
2078 }  /* end of kill_file() */
2079 /*}}}*/
2080
2081
2082 /*{{{int my_mkdir(char *,Mode_t)*/
2083 int
2084 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2085 {
2086   STRLEN dirlen = strlen(dir);
2087
2088   /* zero length string sometimes gives ACCVIO */
2089   if (dirlen == 0) return -1;
2090
2091   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2092    * null file name/type.  However, it's commonplace under Unix,
2093    * so we'll allow it for a gain in portability.
2094    */
2095   if (dir[dirlen-1] == '/') {
2096     char *newdir = savepvn(dir,dirlen-1);
2097     int ret = mkdir(newdir,mode);
2098     Safefree(newdir);
2099     return ret;
2100   }
2101   else return mkdir(dir,mode);
2102 }  /* end of my_mkdir */
2103 /*}}}*/
2104
2105 /*{{{int my_chdir(char *)*/
2106 int
2107 Perl_my_chdir(pTHX_ const char *dir)
2108 {
2109   STRLEN dirlen = strlen(dir);
2110   const char *dir1 = dir;
2111
2112   /* zero length string sometimes gives ACCVIO */
2113   if (dirlen == 0) {
2114     SETERRNO(EINVAL, SS$_BADPARAM);
2115     return -1;
2116   }
2117
2118   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2119    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2120    * so that existing scripts do not need to be changed.
2121    */
2122   while ((dirlen > 0) && (*dir1 == ' ')) {
2123     dir1++;
2124     dirlen--;
2125   }
2126
2127   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2128    * that implies
2129    * null file name/type.  However, it's commonplace under Unix,
2130    * so we'll allow it for a gain in portability.
2131    *
2132    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2133    */
2134   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2135       char *newdir;
2136       int ret;
2137       newdir = (char *)PerlMem_malloc(dirlen);
2138       if (newdir ==NULL)
2139           _ckvmssts_noperl(SS$_INSFMEM);
2140       memcpy(newdir, dir1, dirlen-1);
2141       newdir[dirlen-1] = '\0';
2142       ret = chdir(newdir);
2143       PerlMem_free(newdir);
2144       return ret;
2145   }
2146   else return chdir(dir1);
2147 }  /* end of my_chdir */
2148 /*}}}*/
2149
2150
2151 /*{{{int my_chmod(char *, mode_t)*/
2152 int
2153 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2154 {
2155   Stat_t st;
2156   int ret = -1;
2157   char * changefile;
2158   STRLEN speclen = strlen(file_spec);
2159
2160   /* zero length string sometimes gives ACCVIO */
2161   if (speclen == 0) return -1;
2162
2163   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2164    * that implies null file name/type.  However, it's commonplace under Unix,
2165    * so we'll allow it for a gain in portability.
2166    *
2167    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2168    * in VMS file.dir notation.
2169    */
2170   changefile = (char *) file_spec; /* cast ok */
2171   ret = flex_lstat(file_spec, &st);
2172   if (ret != 0) {
2173
2174         /* Due to a historical feature, flex_stat/lstat can not see some */
2175         /* Unix format file names that the rest of the CRTL can see when */
2176         /* ODS-2 file specifications are in use. */
2177         /* Fixing that feature will cause some perl tests to fail */
2178         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2179         st.st_mode = 0;
2180
2181   } else {
2182       /* It may be possible to get here with nothing in st_devname */
2183       /* chmod still may work though */
2184       if (st.st_devnam[0] != 0) {
2185           changefile = st.st_devnam;
2186       }
2187   }
2188   ret = chmod(changefile, mode);
2189   return ret;
2190 }  /* end of my_chmod */
2191 /*}}}*/
2192
2193
2194 /*{{{FILE *my_tmpfile()*/
2195 FILE *
2196 my_tmpfile(void)
2197 {
2198   FILE *fp;
2199   char *cp;
2200
2201   if ((fp = tmpfile())) return fp;
2202
2203   cp = (char *)PerlMem_malloc(L_tmpnam+24);
2204   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2205
2206   if (decc_filename_unix_only == 0)
2207     strcpy(cp,"Sys$Scratch:");
2208   else
2209     strcpy(cp,"/tmp/");
2210   tmpnam(cp+strlen(cp));
2211   strcat(cp,".Perltmp");
2212   fp = fopen(cp,"w+","fop=dlt");
2213   PerlMem_free(cp);
2214   return fp;
2215 }
2216 /*}}}*/
2217
2218
2219 /*
2220  * The C RTL's sigaction fails to check for invalid signal numbers so we
2221  * help it out a bit.  The docs are correct, but the actual routine doesn't
2222  * do what the docs say it will.
2223  */
2224 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2225 int
2226 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2227                    struct sigaction* oact)
2228 {
2229   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2230         SETERRNO(EINVAL, SS$_INVARG);
2231         return -1;
2232   }
2233   return sigaction(sig, act, oact);
2234 }
2235 /*}}}*/
2236
2237 #ifdef KILL_BY_SIGPRC
2238 #include <errnodef.h>
2239
2240 /* We implement our own kill() using the undocumented system service
2241    sys$sigprc for one of two reasons:
2242
2243    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2244    target process to do a sys$exit, which usually can't be handled
2245    gracefully...certainly not by Perl and the %SIG{} mechanism.
2246
2247    2.) If the kill() in the CRTL can't be called from a signal
2248    handler without disappearing into the ether, i.e., the signal
2249    it purportedly sends is never trapped. Still true as of VMS 7.3.
2250
2251    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2252    in the target process rather than calling sys$exit.
2253
2254    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2255    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2256    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2257    with condition codes C$_SIG0+nsig*8, catching the exception on the
2258    target process and resignaling with appropriate arguments.
2259
2260    But we don't have that VMS 7.0+ exception handler, so if you
2261    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2262
2263    Also note that SIGTERM is listed in the docs as being "unimplemented",
2264    yet always seems to be signaled with a VMS condition code of 4 (and
2265    correctly handled for that code).  So we hardwire it in.
2266
2267    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2268    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2269    than signalling with an unrecognized (and unhandled by CRTL) code.
2270 */
2271
2272 #define _MY_SIG_MAX 28
2273
2274 static unsigned int
2275 Perl_sig_to_vmscondition_int(int sig)
2276 {
2277     static unsigned int sig_code[_MY_SIG_MAX+1] =
2278     {
2279         0,                  /*  0 ZERO     */
2280         SS$_HANGUP,         /*  1 SIGHUP   */
2281         SS$_CONTROLC,       /*  2 SIGINT   */
2282         SS$_CONTROLY,       /*  3 SIGQUIT  */
2283         SS$_RADRMOD,        /*  4 SIGILL   */
2284         SS$_BREAK,          /*  5 SIGTRAP  */
2285         SS$_OPCCUS,         /*  6 SIGABRT  */
2286         SS$_COMPAT,         /*  7 SIGEMT   */
2287 #ifdef __VAX
2288         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2289 #else
2290         SS$_HPARITH,        /*  8 SIGFPE AXP */
2291 #endif
2292         SS$_ABORT,          /*  9 SIGKILL  */
2293         SS$_ACCVIO,         /* 10 SIGBUS   */
2294         SS$_ACCVIO,         /* 11 SIGSEGV  */
2295         SS$_BADPARAM,       /* 12 SIGSYS   */
2296         SS$_NOMBX,          /* 13 SIGPIPE  */
2297         SS$_ASTFLT,         /* 14 SIGALRM  */
2298         4,                  /* 15 SIGTERM  */
2299         0,                  /* 16 SIGUSR1  */
2300         0,                  /* 17 SIGUSR2  */
2301         0,                  /* 18 */
2302         0,                  /* 19 */
2303         0,                  /* 20 SIGCHLD  */
2304         0,                  /* 21 SIGCONT  */
2305         0,                  /* 22 SIGSTOP  */
2306         0,                  /* 23 SIGTSTP  */
2307         0,                  /* 24 SIGTTIN  */
2308         0,                  /* 25 SIGTTOU  */
2309         0,                  /* 26 */
2310         0,                  /* 27 */
2311         0                   /* 28 SIGWINCH  */
2312     };
2313
2314     static int initted = 0;
2315     if (!initted) {
2316         initted = 1;
2317         sig_code[16] = C$_SIGUSR1;
2318         sig_code[17] = C$_SIGUSR2;
2319         sig_code[20] = C$_SIGCHLD;
2320 #if __CRTL_VER >= 70300000
2321         sig_code[28] = C$_SIGWINCH;
2322 #endif
2323     }
2324
2325     if (sig < _SIG_MIN) return 0;
2326     if (sig > _MY_SIG_MAX) return 0;
2327     return sig_code[sig];
2328 }
2329
2330 unsigned int
2331 Perl_sig_to_vmscondition(int sig)
2332 {
2333 #ifdef SS$_DEBUG
2334     if (vms_debug_on_exception != 0)
2335         lib$signal(SS$_DEBUG);
2336 #endif
2337     return Perl_sig_to_vmscondition_int(sig);
2338 }
2339
2340
2341 #define sys$sigprc SYS$SIGPRC
2342 #ifdef __cplusplus
2343 extern "C" {
2344 #endif
2345 int sys$sigprc(unsigned int *pidadr,
2346                struct dsc$descriptor_s *prcname,
2347                unsigned int code);
2348 #ifdef __cplusplus
2349 }
2350 #endif
2351
2352 int
2353 Perl_my_kill(int pid, int sig)
2354 {
2355     int iss;
2356     unsigned int code;
2357
2358      /* sig 0 means validate the PID */
2359     /*------------------------------*/
2360     if (sig == 0) {
2361         const unsigned long int jpicode = JPI$_PID;
2362         pid_t ret_pid;
2363         int status;
2364         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2365         if ($VMS_STATUS_SUCCESS(status))
2366            return 0;
2367         switch (status) {
2368         case SS$_NOSUCHNODE:
2369         case SS$_UNREACHABLE:
2370         case SS$_NONEXPR:
2371            errno = ESRCH;
2372            break;
2373         case SS$_NOPRIV:
2374            errno = EPERM;
2375            break;
2376         default:
2377            errno = EVMSERR;
2378         }
2379         vaxc$errno=status;
2380         return -1;
2381     }
2382
2383     code = Perl_sig_to_vmscondition_int(sig);
2384
2385     if (!code) {
2386         SETERRNO(EINVAL, SS$_BADPARAM);
2387         return -1;
2388     }
2389
2390     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2391      * signals are to be sent to multiple processes.
2392      *  pid = 0 - all processes in group except ones that the system exempts
2393      *  pid = -1 - all processes except ones that the system exempts
2394      *  pid = -n - all processes in group (abs(n)) except ...
2395      * For now, just report as not supported.
2396      */
2397
2398     if (pid <= 0) {
2399         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2400         return -1;
2401     }
2402
2403     iss = sys$sigprc((unsigned int *)&pid,0,code);
2404     if (iss&1) return 0;
2405
2406     switch (iss) {
2407       case SS$_NOPRIV:
2408         set_errno(EPERM);  break;
2409       case SS$_NONEXPR:
2410       case SS$_NOSUCHNODE:
2411       case SS$_UNREACHABLE:
2412         set_errno(ESRCH);  break;
2413       case SS$_INSFMEM:
2414         set_errno(ENOMEM); break;
2415       default:
2416         _ckvmssts_noperl(iss);
2417         set_errno(EVMSERR);
2418     }
2419     set_vaxc_errno(iss);
2420
2421     return -1;
2422 }
2423 #endif
2424
2425 /* Routine to convert a VMS status code to a UNIX status code.
2426 ** More tricky than it appears because of conflicting conventions with
2427 ** existing code.
2428 **
2429 ** VMS status codes are a bit mask, with the least significant bit set for
2430 ** success.
2431 **
2432 ** Special UNIX status of EVMSERR indicates that no translation is currently
2433 ** available, and programs should check the VMS status code.
2434 **
2435 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2436 ** decoding.
2437 */
2438
2439 #ifndef C_FACILITY_NO
2440 #define C_FACILITY_NO 0x350000
2441 #endif
2442 #ifndef DCL_IVVERB
2443 #define DCL_IVVERB 0x38090
2444 #endif
2445
2446 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2447 {
2448 int facility;
2449 int fac_sp;
2450 int msg_no;
2451 int msg_status;
2452 int unix_status;
2453
2454   /* Assume the best or the worst */
2455   if (vms_status & STS$M_SUCCESS)
2456     unix_status = 0;
2457   else
2458     unix_status = EVMSERR;
2459
2460   msg_status = vms_status & ~STS$M_CONTROL;
2461
2462   facility = vms_status & STS$M_FAC_NO;
2463   fac_sp = vms_status & STS$M_FAC_SP;
2464   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2465
2466   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2467     switch(msg_no) {
2468     case SS$_NORMAL:
2469         unix_status = 0;
2470         break;
2471     case SS$_ACCVIO:
2472         unix_status = EFAULT;
2473         break;
2474     case SS$_DEVOFFLINE:
2475         unix_status = EBUSY;
2476         break;
2477     case SS$_CLEARED:
2478         unix_status = ENOTCONN;
2479         break;
2480     case SS$_IVCHAN:
2481     case SS$_IVLOGNAM:
2482     case SS$_BADPARAM:
2483     case SS$_IVLOGTAB:
2484     case SS$_NOLOGNAM:
2485     case SS$_NOLOGTAB:
2486     case SS$_INVFILFOROP:
2487     case SS$_INVARG:
2488     case SS$_NOSUCHID:
2489     case SS$_IVIDENT:
2490         unix_status = EINVAL;
2491         break;
2492     case SS$_UNSUPPORTED:
2493         unix_status = ENOTSUP;
2494         break;
2495     case SS$_FILACCERR:
2496     case SS$_NOGRPPRV:
2497     case SS$_NOSYSPRV:
2498         unix_status = EACCES;
2499         break;
2500     case SS$_DEVICEFULL:
2501         unix_status = ENOSPC;
2502         break;
2503     case SS$_NOSUCHDEV:
2504         unix_status = ENODEV;
2505         break;
2506     case SS$_NOSUCHFILE:
2507     case SS$_NOSUCHOBJECT:
2508         unix_status = ENOENT;
2509         break;
2510     case SS$_ABORT:                                 /* Fatal case */
2511     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2512     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2513         unix_status = EINTR;
2514         break;
2515     case SS$_BUFFEROVF:
2516         unix_status = E2BIG;
2517         break;
2518     case SS$_INSFMEM:
2519         unix_status = ENOMEM;
2520         break;
2521     case SS$_NOPRIV:
2522         unix_status = EPERM;
2523         break;
2524     case SS$_NOSUCHNODE:
2525     case SS$_UNREACHABLE:
2526         unix_status = ESRCH;
2527         break;
2528     case SS$_NONEXPR:
2529         unix_status = ECHILD;
2530         break;
2531     default:
2532         if ((facility == 0) && (msg_no < 8)) {
2533           /* These are not real VMS status codes so assume that they are
2534           ** already UNIX status codes
2535           */
2536           unix_status = msg_no;
2537           break;
2538         }
2539     }
2540   }
2541   else {
2542     /* Translate a POSIX exit code to a UNIX exit code */
2543     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2544         unix_status = (msg_no & 0x07F8) >> 3;
2545     }
2546     else {
2547
2548          /* Documented traditional behavior for handling VMS child exits */
2549         /*--------------------------------------------------------------*/
2550         if (child_flag != 0) {
2551
2552              /* Success / Informational return 0 */
2553             /*----------------------------------*/
2554             if (msg_no & STS$K_SUCCESS)
2555                 return 0;
2556
2557              /* Warning returns 1 */
2558             /*-------------------*/
2559             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2560                 return 1;
2561
2562              /* Everything else pass through the severity bits */
2563             /*------------------------------------------------*/
2564             return (msg_no & STS$M_SEVERITY);
2565         }
2566
2567          /* Normal VMS status to ERRNO mapping attempt */
2568         /*--------------------------------------------*/
2569         switch(msg_status) {
2570         /* case RMS$_EOF: */ /* End of File */
2571         case RMS$_FNF:  /* File Not Found */
2572         case RMS$_DNF:  /* Dir Not Found */
2573                 unix_status = ENOENT;
2574                 break;
2575         case RMS$_RNF:  /* Record Not Found */
2576                 unix_status = ESRCH;
2577                 break;
2578         case RMS$_DIR:
2579                 unix_status = ENOTDIR;
2580                 break;
2581         case RMS$_DEV:
2582                 unix_status = ENODEV;
2583                 break;
2584         case RMS$_IFI:
2585         case RMS$_FAC:
2586         case RMS$_ISI:
2587                 unix_status = EBADF;
2588                 break;
2589         case RMS$_FEX:
2590                 unix_status = EEXIST;
2591                 break;
2592         case RMS$_SYN:
2593         case RMS$_FNM:
2594         case LIB$_INVSTRDES:
2595         case LIB$_INVARG:
2596         case LIB$_NOSUCHSYM:
2597         case LIB$_INVSYMNAM:
2598         case DCL_IVVERB:
2599                 unix_status = EINVAL;
2600                 break;
2601         case CLI$_BUFOVF:
2602         case RMS$_RTB:
2603         case CLI$_TKNOVF:
2604         case CLI$_RSLOVF:
2605                 unix_status = E2BIG;
2606                 break;
2607         case RMS$_PRV:  /* No privilege */
2608         case RMS$_ACC:  /* ACP file access failed */
2609         case RMS$_WLK:  /* Device write locked */
2610                 unix_status = EACCES;
2611                 break;
2612         case RMS$_MKD:  /* Failed to mark for delete */
2613                 unix_status = EPERM;
2614                 break;
2615         /* case RMS$_NMF: */  /* No more files */
2616         }
2617     }
2618   }
2619
2620   return unix_status;
2621 }
2622
2623 /* Try to guess at what VMS error status should go with a UNIX errno
2624  * value.  This is hard to do as there could be many possible VMS
2625  * error statuses that caused the errno value to be set.
2626  */
2627
2628 int Perl_unix_status_to_vms(int unix_status)
2629 {
2630 int test_unix_status;
2631
2632      /* Trivial cases first */
2633     /*---------------------*/
2634     if (unix_status == EVMSERR)
2635         return vaxc$errno;
2636
2637      /* Is vaxc$errno sane? */
2638     /*---------------------*/
2639     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2640     if (test_unix_status == unix_status)
2641         return vaxc$errno;
2642
2643      /* If way out of range, must be VMS code already */
2644     /*-----------------------------------------------*/
2645     if (unix_status > EVMSERR)
2646         return unix_status;
2647
2648      /* If out of range, punt */
2649     /*-----------------------*/
2650     if (unix_status > __ERRNO_MAX)
2651         return SS$_ABORT;
2652
2653
2654      /* Ok, now we have to do it the hard way. */
2655     /*----------------------------------------*/
2656     switch(unix_status) {
2657     case 0:     return SS$_NORMAL;
2658     case EPERM: return SS$_NOPRIV;
2659     case ENOENT: return SS$_NOSUCHOBJECT;
2660     case ESRCH: return SS$_UNREACHABLE;
2661     case EINTR: return SS$_ABORT;
2662     /* case EIO: */
2663     /* case ENXIO:  */
2664     case E2BIG: return SS$_BUFFEROVF;
2665     /* case ENOEXEC */
2666     case EBADF: return RMS$_IFI;
2667     case ECHILD: return SS$_NONEXPR;
2668     /* case EAGAIN */
2669     case ENOMEM: return SS$_INSFMEM;
2670     case EACCES: return SS$_FILACCERR;
2671     case EFAULT: return SS$_ACCVIO;
2672     /* case ENOTBLK */
2673     case EBUSY: return SS$_DEVOFFLINE;
2674     case EEXIST: return RMS$_FEX;
2675     /* case EXDEV */
2676     case ENODEV: return SS$_NOSUCHDEV;
2677     case ENOTDIR: return RMS$_DIR;
2678     /* case EISDIR */
2679     case EINVAL: return SS$_INVARG;
2680     /* case ENFILE */
2681     /* case EMFILE */
2682     /* case ENOTTY */
2683     /* case ETXTBSY */
2684     /* case EFBIG */
2685     case ENOSPC: return SS$_DEVICEFULL;
2686     case ESPIPE: return LIB$_INVARG;
2687     /* case EROFS: */
2688     /* case EMLINK: */
2689     /* case EPIPE: */
2690     /* case EDOM */
2691     case ERANGE: return LIB$_INVARG;
2692     /* case EWOULDBLOCK */
2693     /* case EINPROGRESS */
2694     /* case EALREADY */
2695     /* case ENOTSOCK */
2696     /* case EDESTADDRREQ */
2697     /* case EMSGSIZE */
2698     /* case EPROTOTYPE */
2699     /* case ENOPROTOOPT */
2700     /* case EPROTONOSUPPORT */
2701     /* case ESOCKTNOSUPPORT */
2702     /* case EOPNOTSUPP */
2703     /* case EPFNOSUPPORT */
2704     /* case EAFNOSUPPORT */
2705     /* case EADDRINUSE */
2706     /* case EADDRNOTAVAIL */
2707     /* case ENETDOWN */
2708     /* case ENETUNREACH */
2709     /* case ENETRESET */
2710     /* case ECONNABORTED */
2711     /* case ECONNRESET */
2712     /* case ENOBUFS */
2713     /* case EISCONN */
2714     case ENOTCONN: return SS$_CLEARED;
2715     /* case ESHUTDOWN */
2716     /* case ETOOMANYREFS */
2717     /* case ETIMEDOUT */
2718     /* case ECONNREFUSED */
2719     /* case ELOOP */
2720     /* case ENAMETOOLONG */
2721     /* case EHOSTDOWN */
2722     /* case EHOSTUNREACH */
2723     /* case ENOTEMPTY */
2724     /* case EPROCLIM */
2725     /* case EUSERS  */
2726     /* case EDQUOT  */
2727     /* case ENOMSG  */
2728     /* case EIDRM */
2729     /* case EALIGN */
2730     /* case ESTALE */
2731     /* case EREMOTE */
2732     /* case ENOLCK */
2733     /* case ENOSYS */
2734     /* case EFTYPE */
2735     /* case ECANCELED */
2736     /* case EFAIL */
2737     /* case EINPROG */
2738     case ENOTSUP:
2739         return SS$_UNSUPPORTED;
2740     /* case EDEADLK */
2741     /* case ENWAIT */
2742     /* case EILSEQ */
2743     /* case EBADCAT */
2744     /* case EBADMSG */
2745     /* case EABANDONED */
2746     default:
2747         return SS$_ABORT; /* punt */
2748     }
2749 }
2750
2751
2752 /* default piping mailbox size */
2753 #ifdef __VAX
2754 #  define PERL_BUFSIZ        512
2755 #else
2756 #  define PERL_BUFSIZ        8192
2757 #endif
2758
2759
2760 static void
2761 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2762 {
2763   unsigned long int mbxbufsiz;
2764   static unsigned long int syssize = 0;
2765   unsigned long int dviitm = DVI$_DEVNAM;
2766   char csize[LNM$C_NAMLENGTH+1];
2767   int sts;
2768
2769   if (!syssize) {
2770     unsigned long syiitm = SYI$_MAXBUF;
2771     /*
2772      * Get the SYSGEN parameter MAXBUF
2773      *
2774      * If the logical 'PERL_MBX_SIZE' is defined
2775      * use the value of the logical instead of PERL_BUFSIZ, but
2776      * keep the size between 128 and MAXBUF.
2777      *
2778      */
2779     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2780   }
2781
2782   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2783       mbxbufsiz = atoi(csize);
2784   } else {
2785       mbxbufsiz = PERL_BUFSIZ;
2786   }
2787   if (mbxbufsiz < 128) mbxbufsiz = 128;
2788   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2789
2790   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2791
2792   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2793   _ckvmssts_noperl(sts);
2794   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2795
2796 }  /* end of create_mbx() */
2797
2798
2799 /*{{{  my_popen and my_pclose*/
2800
2801 typedef struct _iosb           IOSB;
2802 typedef struct _iosb*         pIOSB;
2803 typedef struct _pipe           Pipe;
2804 typedef struct _pipe*         pPipe;
2805 typedef struct pipe_details    Info;
2806 typedef struct pipe_details*  pInfo;
2807 typedef struct _srqp            RQE;
2808 typedef struct _srqp*          pRQE;
2809 typedef struct _tochildbuf      CBuf;
2810 typedef struct _tochildbuf*    pCBuf;
2811
2812 struct _iosb {
2813     unsigned short status;
2814     unsigned short count;
2815     unsigned long  dvispec;
2816 };
2817
2818 #pragma member_alignment save
2819 #pragma nomember_alignment quadword
2820 struct _srqp {          /* VMS self-relative queue entry */
2821     unsigned long qptr[2];
2822 };
2823 #pragma member_alignment restore
2824 static RQE  RQE_ZERO = {0,0};
2825
2826 struct _tochildbuf {
2827     RQE             q;
2828     int             eof;
2829     unsigned short  size;
2830     char            *buf;
2831 };
2832
2833 struct _pipe {
2834     RQE            free;
2835     RQE            wait;
2836     int            fd_out;
2837     unsigned short chan_in;
2838     unsigned short chan_out;
2839     char          *buf;
2840     unsigned int   bufsize;
2841     IOSB           iosb;
2842     IOSB           iosb2;
2843     int           *pipe_done;
2844     int            retry;
2845     int            type;
2846     int            shut_on_empty;
2847     int            need_wake;
2848     pPipe         *home;
2849     pInfo          info;
2850     pCBuf          curr;
2851     pCBuf          curr2;
2852 #if defined(PERL_IMPLICIT_CONTEXT)
2853     void            *thx;           /* Either a thread or an interpreter */
2854                                     /* pointer, depending on how we're built */
2855 #endif
2856 };
2857
2858
2859 struct pipe_details
2860 {
2861     pInfo           next;
2862     PerlIO *fp;  /* file pointer to pipe mailbox */
2863     int useFILE; /* using stdio, not perlio */
2864     int pid;   /* PID of subprocess */
2865     int mode;  /* == 'r' if pipe open for reading */
2866     int done;  /* subprocess has completed */
2867     int waiting; /* waiting for completion/closure */
2868     int             closing;        /* my_pclose is closing this pipe */
2869     unsigned long   completion;     /* termination status of subprocess */
2870     pPipe           in;             /* pipe in to sub */
2871     pPipe           out;            /* pipe out of sub */
2872     pPipe           err;            /* pipe of sub's sys$error */
2873     int             in_done;        /* true when in pipe finished */
2874     int             out_done;
2875     int             err_done;
2876     unsigned short  xchan;          /* channel to debug xterm */
2877     unsigned short  xchan_valid;    /* channel is assigned */
2878 };
2879
2880 struct exit_control_block
2881 {
2882     struct exit_control_block *flink;
2883     unsigned long int (*exit_routine)(void);
2884     unsigned long int arg_count;
2885     unsigned long int *status_address;
2886     unsigned long int exit_status;
2887 };
2888
2889 typedef struct _closed_pipes    Xpipe;
2890 typedef struct _closed_pipes*  pXpipe;
2891
2892 struct _closed_pipes {
2893     int             pid;            /* PID of subprocess */
2894     unsigned long   completion;     /* termination status of subprocess */
2895 };
2896 #define NKEEPCLOSED 50
2897 static Xpipe closed_list[NKEEPCLOSED];
2898 static int   closed_index = 0;
2899 static int   closed_num = 0;
2900
2901 #define RETRY_DELAY     "0 ::0.20"
2902 #define MAX_RETRY              50
2903
2904 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2905 static unsigned long mypid;
2906 static unsigned long delaytime[2];
2907
2908 static pInfo open_pipes = NULL;
2909 static $DESCRIPTOR(nl_desc, "NL:");
2910
2911 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2912
2913
2914
2915 static unsigned long int
2916 pipe_exit_routine(void)
2917 {
2918     pInfo info;
2919     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2920     int sts, did_stuff, j;
2921
2922    /*
2923     * Flush any pending i/o, but since we are in process run-down, be
2924     * careful about referencing PerlIO structures that may already have
2925     * been deallocated.  We may not even have an interpreter anymore.
2926     */
2927     info = open_pipes;
2928     while (info) {
2929         if (info->fp) {
2930 #if defined(PERL_IMPLICIT_CONTEXT)
2931            /* We need to use the Perl context of the thread that created */
2932            /* the pipe. */
2933            pTHX;
2934            if (info->err)
2935                aTHX = info->err->thx;
2936            else if (info->out)
2937                aTHX = info->out->thx;
2938            else if (info->in)
2939                aTHX = info->in->thx;
2940 #endif
2941            if (!info->useFILE
2942 #if defined(USE_ITHREADS)
2943              && my_perl
2944 #endif
2945 #ifdef USE_PERLIO
2946              && PL_perlio_fd_refcnt
2947 #endif
2948               )
2949                PerlIO_flush(info->fp);
2950            else
2951                fflush((FILE *)info->fp);
2952         }
2953         info = info->next;
2954     }
2955
2956     /*
2957      next we try sending an EOF...ignore if doesn't work, make sure we
2958      don't hang
2959     */
2960     did_stuff = 0;
2961     info = open_pipes;
2962
2963     while (info) {
2964       _ckvmssts_noperl(sys$setast(0));
2965       if (info->in && !info->in->shut_on_empty) {
2966         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2967                                  0, 0, 0, 0, 0, 0));
2968         info->waiting = 1;
2969         did_stuff = 1;
2970       }
2971       _ckvmssts_noperl(sys$setast(1));
2972       info = info->next;
2973     }
2974
2975     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2976
2977     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2978         int nwait = 0;
2979
2980         info = open_pipes;
2981         while (info) {
2982           _ckvmssts_noperl(sys$setast(0));
2983           if (info->waiting && info->done)
2984                 info->waiting = 0;
2985           nwait += info->waiting;
2986           _ckvmssts_noperl(sys$setast(1));
2987           info = info->next;
2988         }
2989         if (!nwait) break;
2990         sleep(1);
2991     }
2992
2993     did_stuff = 0;
2994     info = open_pipes;
2995     while (info) {
2996       _ckvmssts_noperl(sys$setast(0));
2997       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2998         sts = sys$forcex(&info->pid,0,&abort);
2999         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3000         did_stuff = 1;
3001       }
3002       _ckvmssts_noperl(sys$setast(1));
3003       info = info->next;
3004     }
3005
3006     /* again, wait for effect */
3007
3008     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3009         int nwait = 0;
3010
3011         info = open_pipes;
3012         while (info) {
3013           _ckvmssts_noperl(sys$setast(0));
3014           if (info->waiting && info->done)
3015                 info->waiting = 0;
3016           nwait += info->waiting;
3017           _ckvmssts_noperl(sys$setast(1));
3018           info = info->next;
3019         }
3020         if (!nwait) break;
3021         sleep(1);
3022     }
3023
3024     info = open_pipes;
3025     while (info) {
3026       _ckvmssts_noperl(sys$setast(0));
3027       if (!info->done) {  /* We tried to be nice . . . */
3028         sts = sys$delprc(&info->pid,0);
3029         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3030         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3031       }
3032       _ckvmssts_noperl(sys$setast(1));
3033       info = info->next;
3034     }
3035
3036     while(open_pipes) {
3037
3038 #if defined(PERL_IMPLICIT_CONTEXT)
3039       /* We need to use the Perl context of the thread that created */
3040       /* the pipe. */
3041       pTHX;
3042       if (open_pipes->err)
3043           aTHX = open_pipes->err->thx;
3044       else if (open_pipes->out)
3045           aTHX = open_pipes->out->thx;
3046       else if (open_pipes->in)
3047           aTHX = open_pipes->in->thx;
3048 #endif
3049       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3050       else if (!(sts & 1)) retsts = sts;
3051     }
3052     return retsts;
3053 }
3054
3055 static struct exit_control_block pipe_exitblock =
3056        {(struct exit_control_block *) 0,
3057         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3058
3059 static void pipe_mbxtofd_ast(pPipe p);
3060 static void pipe_tochild1_ast(pPipe p);
3061 static void pipe_tochild2_ast(pPipe p);
3062
3063 static void
3064 popen_completion_ast(pInfo info)
3065 {
3066   pInfo i = open_pipes;
3067   int iss;
3068
3069   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3070   closed_list[closed_index].pid = info->pid;
3071   closed_list[closed_index].completion = info->completion;
3072   closed_index++;
3073   if (closed_index == NKEEPCLOSED)
3074     closed_index = 0;
3075   closed_num++;
3076
3077   while (i) {
3078     if (i == info) break;
3079     i = i->next;
3080   }
3081   if (!i) return;       /* unlinked, probably freed too */
3082
3083   info->done = TRUE;
3084
3085 /*
3086     Writing to subprocess ...
3087             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3088
3089             chan_out may be waiting for "done" flag, or hung waiting
3090             for i/o completion to child...cancel the i/o.  This will
3091             put it into "snarf mode" (done but no EOF yet) that discards
3092             input.
3093
3094     Output from subprocess (stdout, stderr) needs to be flushed and
3095     shut down.   We try sending an EOF, but if the mbx is full the pipe
3096     routine should still catch the "shut_on_empty" flag, telling it to
3097     use immediate-style reads so that "mbx empty" -> EOF.
3098
3099
3100 */
3101   if (info->in && !info->in_done) {               /* only for mode=w */
3102         if (info->in->shut_on_empty && info->in->need_wake) {
3103             info->in->need_wake = FALSE;
3104             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3105         } else {
3106             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3107         }
3108   }
3109
3110   if (info->out && !info->out_done) {             /* were we also piping output? */
3111       info->out->shut_on_empty = TRUE;
3112       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3113       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3114       _ckvmssts_noperl(iss);
3115   }
3116
3117   if (info->err && !info->err_done) {        /* we were piping stderr */
3118         info->err->shut_on_empty = TRUE;
3119         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3120         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3121         _ckvmssts_noperl(iss);
3122   }
3123   _ckvmssts_noperl(sys$setef(pipe_ef));
3124
3125 }
3126
3127 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3128 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3129 static void pipe_infromchild_ast(pPipe p);
3130
3131 /*
3132     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3133     inside an AST routine without worrying about reentrancy and which Perl
3134     memory allocator is being used.
3135
3136     We read data and queue up the buffers, then spit them out one at a
3137     time to the output mailbox when the output mailbox is ready for one.
3138
3139 */
3140 #define INITIAL_TOCHILDQUEUE  2
3141
3142 static pPipe
3143 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3144 {
3145     pPipe p;
3146     pCBuf b;
3147     char mbx1[64], mbx2[64];
3148     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3149                                       DSC$K_CLASS_S, mbx1},
3150                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3151                                       DSC$K_CLASS_S, mbx2};
3152     unsigned int dviitm = DVI$_DEVBUFSIZ;
3153     int j, n;
3154
3155     n = sizeof(Pipe);
3156     _ckvmssts_noperl(lib$get_vm(&n, &p));
3157
3158     create_mbx(&p->chan_in , &d_mbx1);
3159     create_mbx(&p->chan_out, &d_mbx2);
3160     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3161
3162     p->buf           = 0;
3163     p->shut_on_empty = FALSE;
3164     p->need_wake     = FALSE;
3165     p->type          = 0;
3166     p->retry         = 0;
3167     p->iosb.status   = SS$_NORMAL;
3168     p->iosb2.status  = SS$_NORMAL;
3169     p->free          = RQE_ZERO;
3170     p->wait          = RQE_ZERO;
3171     p->curr          = 0;
3172     p->curr2         = 0;
3173     p->info          = 0;
3174 #ifdef PERL_IMPLICIT_CONTEXT
3175     p->thx           = aTHX;
3176 #endif
3177
3178     n = sizeof(CBuf) + p->bufsize;
3179
3180     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3181         _ckvmssts_noperl(lib$get_vm(&n, &b));
3182         b->buf = (char *) b + sizeof(CBuf);
3183         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3184     }
3185
3186     pipe_tochild2_ast(p);
3187     pipe_tochild1_ast(p);
3188     strcpy(wmbx, mbx1);
3189     strcpy(rmbx, mbx2);
3190     return p;
3191 }
3192
3193 /*  reads the MBX Perl is writing, and queues */
3194
3195 static void
3196 pipe_tochild1_ast(pPipe p)
3197 {
3198     pCBuf b = p->curr;
3199     int iss = p->iosb.status;
3200     int eof = (iss == SS$_ENDOFFILE);
3201     int sts;
3202 #ifdef PERL_IMPLICIT_CONTEXT
3203     pTHX = p->thx;
3204 #endif
3205
3206     if (p->retry) {
3207         if (eof) {
3208             p->shut_on_empty = TRUE;
3209             b->eof     = TRUE;
3210             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3211         } else  {
3212             _ckvmssts_noperl(iss);
3213         }
3214
3215         b->eof  = eof;
3216         b->size = p->iosb.count;
3217         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3218         if (p->need_wake) {
3219             p->need_wake = FALSE;
3220             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3221         }
3222     } else {
3223         p->retry = 1;   /* initial call */
3224     }
3225
3226     if (eof) {                  /* flush the free queue, return when done */
3227         int n = sizeof(CBuf) + p->bufsize;
3228         while (1) {
3229             iss = lib$remqti(&p->free, &b);
3230             if (iss == LIB$_QUEWASEMP) return;
3231             _ckvmssts_noperl(iss);
3232             _ckvmssts_noperl(lib$free_vm(&n, &b));
3233         }
3234     }
3235
3236     iss = lib$remqti(&p->free, &b);
3237     if (iss == LIB$_QUEWASEMP) {
3238         int n = sizeof(CBuf) + p->bufsize;
3239         _ckvmssts_noperl(lib$get_vm(&n, &b));
3240         b->buf = (char *) b + sizeof(CBuf);
3241     } else {
3242        _ckvmssts_noperl(iss);
3243     }
3244
3245     p->curr = b;
3246     iss = sys$qio(0,p->chan_in,
3247              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3248              &p->iosb,
3249              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3250     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3251     _ckvmssts_noperl(iss);
3252 }
3253
3254
3255 /* writes queued buffers to output, waits for each to complete before
3256    doing the next */
3257
3258 static void
3259 pipe_tochild2_ast(pPipe p)
3260 {
3261     pCBuf b = p->curr2;
3262     int iss = p->iosb2.status;
3263     int n = sizeof(CBuf) + p->bufsize;
3264     int done = (p->info && p->info->done) ||
3265               iss == SS$_CANCEL || iss == SS$_ABORT;
3266 #if defined(PERL_IMPLICIT_CONTEXT)
3267     pTHX = p->thx;
3268 #endif
3269
3270     do {
3271         if (p->type) {         /* type=1 has old buffer, dispose */
3272             if (p->shut_on_empty) {
3273                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3274             } else {
3275                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3276             }
3277             p->type = 0;
3278         }
3279
3280         iss = lib$remqti(&p->wait, &b);
3281         if (iss == LIB$_QUEWASEMP) {
3282             if (p->shut_on_empty) {
3283                 if (done) {
3284                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3285                     *p->pipe_done = TRUE;
3286                     _ckvmssts_noperl(sys$setef(pipe_ef));
3287                 } else {
3288                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3289                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3290                 }
3291                 return;
3292             }
3293             p->need_wake = TRUE;
3294             return;
3295         }
3296         _ckvmssts_noperl(iss);
3297         p->type = 1;
3298     } while (done);
3299
3300
3301     p->curr2 = b;
3302     if (b->eof) {
3303         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3304             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3305     } else {
3306         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3307             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3308     }
3309
3310     return;
3311
3312 }
3313
3314
3315 static pPipe
3316 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3317 {
3318     pPipe p;
3319     char mbx1[64], mbx2[64];
3320     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3321                                       DSC$K_CLASS_S, mbx1},
3322                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3323                                       DSC$K_CLASS_S, mbx2};
3324     unsigned int dviitm = DVI$_DEVBUFSIZ;
3325
3326     int n = sizeof(Pipe);
3327     _ckvmssts_noperl(lib$get_vm(&n, &p));
3328     create_mbx(&p->chan_in , &d_mbx1);
3329     create_mbx(&p->chan_out, &d_mbx2);
3330
3331     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3332     n = p->bufsize * sizeof(char);
3333     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3334     p->shut_on_empty = FALSE;
3335     p->info   = 0;
3336     p->type   = 0;
3337     p->iosb.status = SS$_NORMAL;
3338 #if defined(PERL_IMPLICIT_CONTEXT)
3339     p->thx = aTHX;
3340 #endif
3341     pipe_infromchild_ast(p);
3342
3343     strcpy(wmbx, mbx1);
3344     strcpy(rmbx, mbx2);
3345     return p;
3346 }
3347
3348 static void
3349 pipe_infromchild_ast(pPipe p)
3350 {
3351     int iss = p->iosb.status;
3352     int eof = (iss == SS$_ENDOFFILE);
3353     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3354     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3355 #if defined(PERL_IMPLICIT_CONTEXT)
3356     pTHX = p->thx;
3357 #endif
3358
3359     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3360         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3361         p->chan_out = 0;
3362     }
3363
3364     /* read completed:
3365             input shutdown if EOF from self (done or shut_on_empty)
3366             output shutdown if closing flag set (my_pclose)
3367             send data/eof from child or eof from self
3368             otherwise, re-read (snarf of data from child)
3369     */
3370
3371     if (p->type == 1) {
3372         p->type = 0;
3373         if (myeof && p->chan_in) {                  /* input shutdown */
3374             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3375             p->chan_in = 0;
3376         }
3377
3378         if (p->chan_out) {
3379             if (myeof || kideof) {      /* pass EOF to parent */
3380                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3381                                          pipe_infromchild_ast, p,
3382                                          0, 0, 0, 0, 0, 0));
3383                 return;
3384             } else if (eof) {       /* eat EOF --- fall through to read*/
3385
3386             } else {                /* transmit data */
3387                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3388                                          pipe_infromchild_ast,p,
3389                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3390                 return;
3391             }
3392         }
3393     }
3394
3395     /*  everything shut? flag as done */
3396
3397     if (!p->chan_in && !p->chan_out) {
3398         *p->pipe_done = TRUE;
3399         _ckvmssts_noperl(sys$setef(pipe_ef));
3400         return;
3401     }
3402
3403     /* write completed (or read, if snarfing from child)
3404             if still have input active,
3405                queue read...immediate mode if shut_on_empty so we get EOF if empty
3406             otherwise,
3407                check if Perl reading, generate EOFs as needed
3408     */
3409
3410     if (p->type == 0) {
3411         p->type = 1;
3412         if (p->chan_in) {
3413             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3414                           pipe_infromchild_ast,p,
3415                           p->buf, p->bufsize, 0, 0, 0, 0);
3416             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3417             _ckvmssts_noperl(iss);
3418         } else {           /* send EOFs for extra reads */
3419             p->iosb.status = SS$_ENDOFFILE;
3420             p->iosb.dvispec = 0;
3421             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3422                                      0, 0, 0,
3423                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3424         }
3425     }
3426 }
3427
3428 static pPipe
3429 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3430 {
3431     pPipe p;
3432     char mbx[64];
3433     unsigned long dviitm = DVI$_DEVBUFSIZ;
3434     struct stat s;
3435     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3436                                       DSC$K_CLASS_S, mbx};
3437     int n = sizeof(Pipe);
3438
3439     /* things like terminals and mbx's don't need this filter */
3440     if (fd && fstat(fd,&s) == 0) {
3441         unsigned long devchar;
3442         char device[65];
3443         unsigned short dev_len;
3444         struct dsc$descriptor_s d_dev;
3445         char * cptr;
3446         struct item_list_3 items[3];
3447         int status;
3448         unsigned short dvi_iosb[4];
3449
3450         cptr = getname(fd, out, 1);
3451         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3452         d_dev.dsc$a_pointer = out;
3453         d_dev.dsc$w_length = strlen(out);
3454         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3455         d_dev.dsc$b_class = DSC$K_CLASS_S;
3456
3457         items[0].len = 4;
3458         items[0].code = DVI$_DEVCHAR;
3459         items[0].bufadr = &devchar;
3460         items[0].retadr = NULL;
3461         items[1].len = 64;
3462         items[1].code = DVI$_FULLDEVNAM;
3463         items[1].bufadr = device;
3464         items[1].retadr = &dev_len;
3465         items[2].len = 0;
3466         items[2].code = 0;
3467
3468         status = sys$getdviw
3469                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3470         _ckvmssts_noperl(status);
3471         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3472             device[dev_len] = 0;
3473
3474             if (!(devchar & DEV$M_DIR)) {
3475                 strcpy(out, device);
3476                 return 0;
3477             }
3478         }
3479     }
3480
3481     _ckvmssts_noperl(lib$get_vm(&n, &p));
3482     p->fd_out = dup(fd);
3483     create_mbx(&p->chan_in, &d_mbx);
3484     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3485     n = (p->bufsize+1) * sizeof(char);
3486     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3487     p->shut_on_empty = FALSE;
3488     p->retry = 0;
3489     p->info  = 0;
3490     strcpy(out, mbx);
3491
3492     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3493                              pipe_mbxtofd_ast, p,
3494                              p->buf, p->bufsize, 0, 0, 0, 0));
3495
3496     return p;
3497 }
3498
3499 static void
3500 pipe_mbxtofd_ast(pPipe p)
3501 {
3502     int iss = p->iosb.status;
3503     int done = p->info->done;
3504     int iss2;
3505     int eof = (iss == SS$_ENDOFFILE);
3506     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3507     int err = !(iss&1) && !eof;
3508 #if defined(PERL_IMPLICIT_CONTEXT)
3509     pTHX = p->thx;
3510 #endif
3511
3512     if (done && myeof) {               /* end piping */
3513         close(p->fd_out);
3514         sys$dassgn(p->chan_in);
3515         *p->pipe_done = TRUE;
3516         _ckvmssts_noperl(sys$setef(pipe_ef));
3517         return;
3518     }
3519
3520     if (!err && !eof) {             /* good data to send to file */
3521         p->buf[p->iosb.count] = '\n';
3522         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3523         if (iss2 < 0) {
3524             p->retry++;
3525             if (p->retry < MAX_RETRY) {
3526                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3527                 return;
3528             }
3529         }
3530         p->retry = 0;
3531     } else if (err) {
3532         _ckvmssts_noperl(iss);
3533     }
3534
3535
3536     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3537           pipe_mbxtofd_ast, p,
3538           p->buf, p->bufsize, 0, 0, 0, 0);
3539     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3540     _ckvmssts_noperl(iss);
3541 }
3542
3543
3544 typedef struct _pipeloc     PLOC;
3545 typedef struct _pipeloc*   pPLOC;
3546
3547 struct _pipeloc {
3548     pPLOC   next;
3549     char    dir[NAM$C_MAXRSS+1];
3550 };
3551 static pPLOC  head_PLOC = 0;
3552
3553 void
3554 free_pipelocs(pTHX_ void *head)
3555 {
3556     pPLOC p, pnext;
3557     pPLOC *pHead = (pPLOC *)head;
3558
3559     p = *pHead;
3560     while (p) {
3561         pnext = p->next;
3562         PerlMem_free(p);
3563         p = pnext;
3564     }
3565     *pHead = 0;
3566 }
3567
3568 static void
3569 store_pipelocs(pTHX)
3570 {
3571     int    i;
3572     pPLOC  p;
3573     AV    *av = 0;
3574     SV    *dirsv;
3575     char  *dir, *x;
3576     char  *unixdir;
3577     char  temp[NAM$C_MAXRSS+1];
3578     STRLEN n_a;
3579
3580     if (head_PLOC)
3581         free_pipelocs(aTHX_ &head_PLOC);
3582
3583 /*  the . directory from @INC comes last */
3584
3585     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3586     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3587     p->next = head_PLOC;
3588     head_PLOC = p;
3589     strcpy(p->dir,"./");
3590
3591 /*  get the directory from $^X */
3592
3593     unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3594     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3595
3596 #ifdef PERL_IMPLICIT_CONTEXT
3597     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3598 #else
3599     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3600 #endif
3601         my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3602         x = strrchr(temp,']');
3603         if (x == NULL) {
3604         x = strrchr(temp,'>');
3605           if (x == NULL) {
3606             /* It could be a UNIX path */
3607             x = strrchr(temp,'/');
3608           }
3609         }
3610         if (x)
3611           x[1] = '\0';
3612         else {
3613           /* Got a bare name, so use default directory */
3614           temp[0] = '.';
3615           temp[1] = '\0';
3616         }
3617
3618         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3619             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3620             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3621             p->next = head_PLOC;
3622             head_PLOC = p;
3623             my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3624         }
3625     }
3626
3627 /*  reverse order of @INC entries, skip "." since entered above */
3628
3629 #ifdef PERL_IMPLICIT_CONTEXT
3630     if (aTHX)
3631 #endif
3632     if (PL_incgv) av = GvAVn(PL_incgv);
3633
3634     for (i = 0; av && i <= AvFILL(av); i++) {
3635         dirsv = *av_fetch(av,i,TRUE);
3636
3637         if (SvROK(dirsv)) continue;
3638         dir = SvPVx(dirsv,n_a);
3639         if (strcmp(dir,".") == 0) continue;
3640         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3641             continue;
3642
3643         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3644         p->next = head_PLOC;
3645         head_PLOC = p;
3646         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3647     }
3648
3649 /* most likely spot (ARCHLIB) put first in the list */
3650
3651 #ifdef ARCHLIB_EXP
3652     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3653         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3654         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3655         p->next = head_PLOC;
3656         head_PLOC = p;
3657         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3658     }
3659 #endif
3660     PerlMem_free(unixdir);
3661 }
3662
3663 static I32
3664 Perl_cando_by_name_int
3665    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3666 #if !defined(PERL_IMPLICIT_CONTEXT)
3667 #define cando_by_name_int               Perl_cando_by_name_int
3668 #else
3669 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3670 #endif
3671
3672 static char *
3673 find_vmspipe(pTHX)
3674 {
3675     static int   vmspipe_file_status = 0;
3676     static char  vmspipe_file[NAM$C_MAXRSS+1];
3677
3678     /* already found? Check and use ... need read+execute permission */
3679
3680     if (vmspipe_file_status == 1) {
3681         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3682          && cando_by_name_int
3683            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3684             return vmspipe_file;
3685         }
3686         vmspipe_file_status = 0;
3687     }
3688
3689     /* scan through stored @INC, $^X */
3690
3691     if (vmspipe_file_status == 0) {
3692         char file[NAM$C_MAXRSS+1];
3693         pPLOC  p = head_PLOC;
3694
3695         while (p) {
3696             char * exp_res;
3697             int dirlen;
3698             dirlen = my_strlcpy(file, p->dir, sizeof(file));
3699             my_strlcat(file, "vmspipe.com", sizeof(file));
3700             p = p->next;
3701
3702             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3703             if (!exp_res) continue;
3704
3705             if (cando_by_name_int
3706                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3707              && cando_by_name_int
3708                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3709                 vmspipe_file_status = 1;
3710                 return vmspipe_file;
3711             }
3712         }
3713         vmspipe_file_status = -1;   /* failed, use tempfiles */
3714     }
3715
3716     return 0;
3717 }
3718
3719 static FILE *
3720 vmspipe_tempfile(pTHX)
3721 {
3722     char file[NAM$C_MAXRSS+1];
3723     FILE *fp;
3724     static int index = 0;
3725     Stat_t s0, s1;
3726     int cmp_result;
3727
3728     /* create a tempfile */
3729
3730     /* we can't go from   W, shr=get to  R, shr=get without
3731        an intermediate vulnerable state, so don't bother trying...
3732
3733        and lib$spawn doesn't shr=put, so have to close the write
3734
3735        So... match up the creation date/time and the FID to
3736        make sure we're dealing with the same file
3737
3738     */
3739
3740     index++;
3741     if (!decc_filename_unix_only) {
3742       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3743       fp = fopen(file,"w");
3744       if (!fp) {
3745         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3746         fp = fopen(file,"w");
3747         if (!fp) {
3748             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3749             fp = fopen(file,"w");
3750         }
3751       }
3752      }
3753      else {
3754       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3755       fp = fopen(file,"w");
3756       if (!fp) {
3757         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3758         fp = fopen(file,"w");
3759         if (!fp) {
3760           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3761           fp = fopen(file,"w");
3762         }
3763       }
3764     }
3765     if (!fp) return 0;  /* we're hosed */
3766
3767     fprintf(fp,"$! 'f$verify(0)'\n");
3768     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3769     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3770     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3771     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3772     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3773     fprintf(fp,"$ perl_del    = \"delete\"\n");
3774     fprintf(fp,"$ pif         = \"if\"\n");
3775     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3776     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3777     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3778     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3779     fprintf(fp,"$!  --- build command line to get max possible length\n");
3780     fprintf(fp,"$c=perl_popen_cmd0\n");
3781     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3782     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3783     fprintf(fp,"$x=perl_popen_cmd3\n");
3784     fprintf(fp,"$c=c+x\n");
3785     fprintf(fp,"$ perl_on\n");
3786     fprintf(fp,"$ 'c'\n");
3787     fprintf(fp,"$ perl_status = $STATUS\n");
3788     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3789     fprintf(fp,"$ perl_exit 'perl_status'\n");
3790     fsync(fileno(fp));
3791
3792     fgetname(fp, file, 1);
3793     fstat(fileno(fp), &s0.crtl_stat);
3794     fclose(fp);
3795
3796     if (decc_filename_unix_only)
3797         int_tounixspec(file, file, NULL);
3798     fp = fopen(file,"r","shr=get");
3799     if (!fp) return 0;
3800     fstat(fileno(fp), &s1.crtl_stat);
3801
3802     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3803     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3804         fclose(fp);
3805         return 0;
3806     }
3807
3808     return fp;
3809 }
3810
3811
3812 static int vms_is_syscommand_xterm(void)
3813 {
3814     const static struct dsc$descriptor_s syscommand_dsc =
3815       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3816
3817     const static struct dsc$descriptor_s decwdisplay_dsc =
3818       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3819
3820     struct item_list_3 items[2];
3821     unsigned short dvi_iosb[4];
3822     unsigned long devchar;
3823     unsigned long devclass;
3824     int status;
3825
3826     /* Very simple check to guess if sys$command is a decterm? */
3827     /* First see if the DECW$DISPLAY: device exists */
3828     items[0].len = 4;
3829     items[0].code = DVI$_DEVCHAR;
3830     items[0].bufadr = &devchar;
3831     items[0].retadr = NULL;
3832     items[1].len = 0;
3833     items[1].code = 0;
3834
3835     status = sys$getdviw
3836         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3837
3838     if ($VMS_STATUS_SUCCESS(status)) {
3839         status = dvi_iosb[0];
3840     }
3841
3842     if (!$VMS_STATUS_SUCCESS(status)) {
3843         SETERRNO(EVMSERR, status);
3844         return -1;
3845     }
3846
3847     /* If it does, then for now assume that we are on a workstation */
3848     /* Now verify that SYS$COMMAND is a terminal */
3849     /* for creating the debugger DECTerm */
3850
3851     items[0].len = 4;
3852     items[0].code = DVI$_DEVCLASS;
3853     items[0].bufadr = &devclass;
3854     items[0].retadr = NULL;
3855     items[1].len = 0;
3856     items[1].code = 0;
3857
3858     status = sys$getdviw
3859         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3860
3861     if ($VMS_STATUS_SUCCESS(status)) {
3862         status = dvi_iosb[0];
3863     }
3864
3865     if (!$VMS_STATUS_SUCCESS(status)) {
3866         SETERRNO(EVMSERR, status);
3867         return -1;
3868     }
3869     else {
3870         if (devclass == DC$_TERM) {
3871             return 0;
3872         }
3873     }
3874     return -1;
3875 }
3876
3877 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3878 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3879 {
3880     int status;
3881     int ret_stat;
3882     char * ret_char;
3883     char device_name[65];
3884     unsigned short device_name_len;
3885     struct dsc$descriptor_s customization_dsc;
3886     struct dsc$descriptor_s device_name_dsc;
3887     const char * cptr;
3888     char customization[200];
3889     char title[40];
3890     pInfo info = NULL;
3891     char mbx1[64];
3892     unsigned short p_chan;
3893     int n;
3894     unsigned short iosb[4];
3895     const char * cust_str =
3896         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3897     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3898                                           DSC$K_CLASS_S, mbx1};
3899
3900      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3901     /*---------------------------------------*/
3902     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3903
3904
3905     /* Make sure that this is from the Perl debugger */
3906     ret_char = strstr(cmd," xterm ");
3907     if (ret_char == NULL)
3908         return NULL;
3909     cptr = ret_char + 7;
3910     ret_char = strstr(cmd,"tty");
3911     if (ret_char == NULL)
3912         return NULL;
3913     ret_char = strstr(cmd,"sleep");
3914     if (ret_char == NULL)
3915         return NULL;
3916
3917     if (decw_term_port == 0) {
3918         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3919         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3920         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3921
3922        status = lib$find_image_symbol
3923                                (&filename1_dsc,
3924                                 &decw_term_port_dsc,
3925                                 (void *)&decw_term_port,
3926                                 NULL,
3927                                 0);
3928
3929         /* Try again with the other image name */
3930         if (!$VMS_STATUS_SUCCESS(status)) {
3931
3932            status = lib$find_image_symbol
3933                                (&filename2_dsc,
3934                                 &decw_term_port_dsc,
3935                                 (void *)&decw_term_port,
3936                                 NULL,
3937                                 0);
3938
3939         }
3940
3941     }
3942
3943
3944     /* No decw$term_port, give it up */
3945     if (!$VMS_STATUS_SUCCESS(status))
3946         return NULL;
3947
3948     /* Are we on a workstation? */
3949     /* to do: capture the rows / columns and pass their properties */
3950     ret_stat = vms_is_syscommand_xterm();
3951     if (ret_stat < 0)
3952         return NULL;
3953
3954     /* Make the title: */
3955     ret_char = strstr(cptr,"-title");
3956     if (ret_char != NULL) {
3957         while ((*cptr != 0) && (*cptr != '\"')) {
3958             cptr++;
3959         }
3960         if (*cptr == '\"')
3961             cptr++;
3962         n = 0;
3963         while ((*cptr != 0) && (*cptr != '\"')) {
3964             title[n] = *cptr;
3965             n++;
3966             if (n == 39) {
3967                 title[39] = 0;
3968                 break;
3969             }
3970             cptr++;
3971         }
3972         title[n] = 0;
3973     }
3974     else {
3975             /* Default title */
3976             strcpy(title,"Perl Debug DECTerm");
3977     }
3978     sprintf(customization, cust_str, title);
3979
3980     customization_dsc.dsc$a_pointer = customization;
3981     customization_dsc.dsc$w_length = strlen(customization);
3982     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3983     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3984
3985     device_name_dsc.dsc$a_pointer = device_name;
3986     device_name_dsc.dsc$w_length = sizeof device_name -1;
3987     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3988     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3989
3990     device_name_len = 0;
3991
3992     /* Try to create the window */
3993      status = (*decw_term_port)
3994        (NULL,
3995         NULL,
3996         &customization_dsc,
3997         &device_name_dsc,
3998         &device_name_len,
3999         NULL,
4000         NULL,
4001         NULL);
4002     if (!$VMS_STATUS_SUCCESS(status)) {
4003         SETERRNO(EVMSERR, status);
4004         return NULL;
4005     }
4006
4007     device_name[device_name_len] = '\0';
4008
4009     /* Need to set this up to look like a pipe for cleanup */
4010     n = sizeof(Info);
4011     status = lib$get_vm(&n, &info);
4012     if (!$VMS_STATUS_SUCCESS(status)) {
4013         SETERRNO(ENOMEM, status);
4014         return NULL;
4015     }
4016
4017     info->mode = *mode;
4018     info->done = FALSE;
4019     info->completion = 0;
4020     info->closing    = FALSE;
4021     info->in         = 0;
4022     info->out        = 0;
4023     info->err        = 0;
4024     info->fp         = NULL;
4025     info->useFILE    = 0;
4026     info->waiting    = 0;
4027     info->in_done    = TRUE;
4028     info->out_done   = TRUE;
4029     info->err_done   = TRUE;
4030
4031     /* Assign a channel on this so that it will persist, and not login */
4032     /* We stash this channel in the info structure for reference. */
4033     /* The created xterm self destructs when the last channel is removed */
4034     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4035     /* So leave this assigned. */
4036     device_name_dsc.dsc$w_length = device_name_len;
4037     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4038     if (!$VMS_STATUS_SUCCESS(status)) {
4039         SETERRNO(EVMSERR, status);
4040         return NULL;
4041     }
4042     info->xchan_valid = 1;
4043
4044     /* Now create a mailbox to be read by the application */
4045
4046     create_mbx(&p_chan, &d_mbx1);
4047
4048     /* write the name of the created terminal to the mailbox */
4049     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4050             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4051
4052     if (!$VMS_STATUS_SUCCESS(status)) {
4053         SETERRNO(EVMSERR, status);
4054         return NULL;
4055     }
4056
4057     info->fp  = PerlIO_open(mbx1, mode);
4058
4059     /* Done with this channel */
4060     sys$dassgn(p_chan);
4061
4062     /* If any errors, then clean up */
4063     if (!info->fp) {
4064         n = sizeof(Info);
4065         _ckvmssts_noperl(lib$free_vm(&n, &info));
4066         return NULL;
4067         }
4068
4069     /* All done */
4070     return info->fp;
4071 }
4072
4073 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4074
4075 static PerlIO *
4076 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4077 {
4078     static int handler_set_up = FALSE;
4079     PerlIO * ret_fp;
4080     unsigned long int sts, flags = CLI$M_NOWAIT;
4081     /* The use of a GLOBAL table (as was done previously) rendered
4082      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4083      * environment.  Hence we've switched to LOCAL symbol table.
4084      */
4085     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4086     int j, wait = 0, n;
4087     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4088     char *in, *out, *err, mbx[512];
4089     FILE *tpipe = 0;
4090     char tfilebuf[NAM$C_MAXRSS+1];
4091     pInfo info = NULL;
4092     char cmd_sym_name[20];
4093     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4094                                       DSC$K_CLASS_S, symbol};
4095     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4096                                       DSC$K_CLASS_S, 0};
4097     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4098                                       DSC$K_CLASS_S, cmd_sym_name};
4099     struct dsc$descriptor_s *vmscmd;
4100     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4101     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4102     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4103
4104     /* Check here for Xterm create request.  This means looking for
4105      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4106      *  is possible to create an xterm.
4107      */
4108     if (*in_mode == 'r') {
4109         PerlIO * xterm_fd;
4110
4111 #if defined(PERL_IMPLICIT_CONTEXT)
4112         /* Can not fork an xterm with a NULL context */
4113         /* This probably could never happen */
4114         xterm_fd = NULL;
4115         if (aTHX != NULL)
4116 #endif
4117         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4118         if (xterm_fd != NULL)
4119             return xterm_fd;
4120     }
4121
4122     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4123
4124     /* once-per-program initialization...
4125        note that the SETAST calls and the dual test of pipe_ef
4126        makes sure that only the FIRST thread through here does
4127        the initialization...all other threads wait until it's
4128        done.
4129
4130        Yeah, uglier than a pthread call, it's got all the stuff inline
4131        rather than in a separate routine.
4132     */
4133
4134     if (!pipe_ef) {
4135         _ckvmssts_noperl(sys$setast(0));
4136         if (!pipe_ef) {
4137             unsigned long int pidcode = JPI$_PID;
4138             $DESCRIPTOR(d_delay, RETRY_DELAY);
4139             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4140             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4141             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4142         }
4143         if (!handler_set_up) {
4144           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4145           handler_set_up = TRUE;
4146         }
4147         _ckvmssts_noperl(sys$setast(1));
4148     }
4149
4150     /* see if we can find a VMSPIPE.COM */
4151
4152     tfilebuf[0] = '@';
4153     vmspipe = find_vmspipe(aTHX);
4154     if (vmspipe) {
4155         vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4156     } else {        /* uh, oh...we're in tempfile hell */
4157         tpipe = vmspipe_tempfile(aTHX);
4158         if (!tpipe) {       /* a fish popular in Boston */
4159             if (ckWARN(WARN_PIPE)) {
4160                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4161             }
4162         return NULL;
4163         }
4164         fgetname(tpipe,tfilebuf+1,1);
4165         vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4166     }
4167     vmspipedsc.dsc$a_pointer = tfilebuf;
4168
4169     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4170     if (!(sts & 1)) {
4171       switch (sts) {
4172         case RMS$_FNF:  case RMS$_DNF:
4173           set_errno(ENOENT); break;
4174         case RMS$_DIR:
4175           set_errno(ENOTDIR); break;
4176         case RMS$_DEV:
4177           set_errno(ENODEV); break;
4178         case RMS$_PRV:
4179           set_errno(EACCES); break;
4180         case RMS$_SYN:
4181           set_errno(EINVAL); break;
4182         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4183           set_errno(E2BIG); break;
4184         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4185           _ckvmssts_noperl(sts); /* fall through */
4186         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4187           set_errno(EVMSERR);
4188       }
4189       set_vaxc_errno(sts);
4190       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4191         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4192       }
4193       *psts = sts;
4194       return NULL;
4195     }
4196     n = sizeof(Info);
4197     _ckvmssts_noperl(lib$get_vm(&n, &info));
4198
4199     my_strlcpy(mode, in_mode, sizeof(mode));
4200     info->mode = *mode;
4201     info->done = FALSE;
4202     info->completion = 0;
4203     info->closing    = FALSE;
4204     info->in         = 0;
4205     info->out        = 0;
4206     info->err        = 0;
4207     info->fp         = NULL;
4208     info->useFILE    = 0;
4209     info->waiting    = 0;
4210     info->in_done    = TRUE;
4211     info->out_done   = TRUE;
4212     info->err_done   = TRUE;
4213     info->xchan      = 0;
4214     info->xchan_valid = 0;
4215
4216     in = (char *)PerlMem_malloc(VMS_MAXRSS);
4217     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4218     out = (char *)PerlMem_malloc(VMS_MAXRSS);
4219     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4220     err = (char *)PerlMem_malloc(VMS_MAXRSS);
4221     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4222
4223     in[0] = out[0] = err[0] = '\0';
4224
4225     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4226         info->useFILE = 1;
4227         strcpy(p,p+1);
4228     }
4229     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4230         wait = 1;
4231         strcpy(p,p+1);
4232     }
4233
4234     if (*mode == 'r') {             /* piping from subroutine */
4235
4236         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4237         if (info->out) {
4238             info->out->pipe_done = &info->out_done;
4239             info->out_done = FALSE;
4240             info->out->info = info;
4241         }
4242         if (!info->useFILE) {
4243             info->fp  = PerlIO_open(mbx, mode);
4244         } else {
4245             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4246             vmssetuserlnm("SYS$INPUT", mbx);
4247         }
4248
4249         if (!info->fp && info->out) {
4250             sys$cancel(info->out->chan_out);
4251
4252             while (!info->out_done) {
4253                 int done;
4254                 _ckvmssts_noperl(sys$setast(0));
4255                 done = info->out_done;
4256                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4257                 _ckvmssts_noperl(sys$setast(1));
4258                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4259             }
4260
4261             if (info->out->buf) {
4262                 n = info->out->bufsize * sizeof(char);
4263                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4264             }
4265             n = sizeof(Pipe);
4266             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4267             n = sizeof(Info);
4268             _ckvmssts_noperl(lib$free_vm(&n, &info));
4269             *psts = RMS$_FNF;
4270             return NULL;
4271         }
4272
4273         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4274         if (info->err) {
4275             info->err->pipe_done = &info->err_done;
4276             info->err_done = FALSE;
4277             info->err->info = info;
4278         }
4279
4280     } else if (*mode == 'w') {      /* piping to subroutine */
4281
4282         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4283         if (info->out) {
4284             info->out->pipe_done = &info->out_done;
4285             info->out_done = FALSE;
4286             info->out->info = info;
4287         }
4288
4289         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4290         if (info->err) {
4291             info->err->pipe_done = &info->err_done;
4292             info->err_done = FALSE;
4293             info->err->info = info;
4294         }
4295
4296         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4297         if (!info->useFILE) {
4298             info->fp  = PerlIO_open(mbx, mode);
4299         } else {
4300             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4301             vmssetuserlnm("SYS$OUTPUT", mbx);
4302         }
4303
4304         if (info->in) {
4305             info->in->pipe_done = &info->in_done;
4306             info->in_done = FALSE;
4307             info->in->info = info;
4308         }
4309
4310         /* error cleanup */
4311         if (!info->fp && info->in) {
4312             info->done = TRUE;
4313             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4314                                       0, 0, 0, 0, 0, 0, 0, 0));
4315
4316             while (!info->in_done) {
4317                 int done;
4318                 _ckvmssts_noperl(sys$setast(0));
4319                 done = info->in_done;
4320                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4321                 _ckvmssts_noperl(sys$setast(1));
4322                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4323             }
4324
4325             if (info->in->buf) {
4326                 n = info->in->bufsize * sizeof(char);
4327                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4328             }
4329             n = sizeof(Pipe);
4330             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4331             n = sizeof(Info);
4332             _ckvmssts_noperl(lib$free_vm(&n, &info));
4333             *psts = RMS$_FNF;
4334             return NULL;
4335         }
4336
4337
4338     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4339         /* Let the child inherit standard input, unless it's a directory. */
4340         Stat_t st;
4341         if (my_trnlnm("SYS$INPUT", in, 0)) {
4342             if (flex_stat(in, &st) != 0 || S_ISDIR(st.st_mode))
4343                 *in = '\0';
4344         }
4345
4346         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4347         if (info->out) {
4348             info->out->pipe_done = &info->out_done;
4349             info->out_done = FALSE;
4350             info->out->info = info;
4351         }
4352
4353         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4354         if (info->err) {
4355             info->err->pipe_done = &info->err_done;
4356             info->err_done = FALSE;
4357             info->err->info = info;
4358         }
4359     }
4360
4361     d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4362     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4363
4364     d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4365     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4366
4367     d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4368     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4369
4370     /* Done with the names for the pipes */
4371     PerlMem_free(err);
4372     PerlMem_free(out);
4373     PerlMem_free(in);
4374
4375     p = vmscmd->dsc$a_pointer;
4376     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4377     if (*p == '$') p++;                         /* remove leading $ */
4378     while (*p == ' ' || *p == '\t') p++;
4379
4380     for (j = 0; j < 4; j++) {
4381         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4382         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4383
4384     d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4385     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4386
4387         if (strlen(p) > MAX_DCL_SYMBOL) {
4388             p += MAX_DCL_SYMBOL;
4389         } else {
4390             p += strlen(p);
4391         }
4392     }
4393     _ckvmssts_noperl(sys$setast(0));
4394     info->next=open_pipes;  /* prepend to list */
4395     open_pipes=info;
4396     _ckvmssts_noperl(sys$setast(1));
4397     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4398      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4399      * have SYS$COMMAND if we need it.
4400      */
4401     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4402                       0, &info->pid, &info->completion,
4403                       0, popen_completion_ast,info,0,0,0));
4404
4405     /* if we were using a tempfile, close it now */
4406
4407     if (tpipe) fclose(tpipe);
4408
4409     /* once the subprocess is spawned, it has copied the symbols and
4410        we can get rid of ours */
4411
4412     for (j = 0; j < 4; j++) {
4413         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4414         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4415     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4416     }
4417     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4418     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4419     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4420     vms_execfree(vmscmd);
4421
4422 #ifdef PERL_IMPLICIT_CONTEXT
4423     if (aTHX)
4424 #endif
4425     PL_forkprocess = info->pid;
4426
4427     ret_fp = info->fp;
4428     if (wait) {
4429          dSAVEDERRNO;
4430          int done = 0;
4431          while (!done) {
4432              _ckvmssts_noperl(sys$setast(0));
4433              done = info->done;
4434              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4435              _ckvmssts_noperl(sys$setast(1));
4436              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4437          }
4438         *psts = info->completion;
4439 /* Caller thinks it is open and tries to close it. */
4440 /* This causes some problems, as it changes the error status */
4441 /*        my_pclose(info->fp); */
4442
4443          /* If we did not have a file pointer open, then we have to */
4444          /* clean up here or eventually we will run out of something */
4445          SAVE_ERRNO;
4446          if (info->fp == NULL) {
4447              my_pclose_pinfo(aTHX_ info);
4448          }
4449          RESTORE_ERRNO;
4450
4451     } else {
4452         *psts = info->pid;
4453     }
4454     return ret_fp;
4455 }  /* end of safe_popen */
4456
4457
4458 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4459 PerlIO *
4460 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4461 {
4462     int sts;
4463     TAINT_ENV();
4464     TAINT_PROPER("popen");
4465     PERL_FLUSHALL_FOR_CHILD;
4466     return safe_popen(aTHX_ cmd,mode,&sts);
4467 }
4468
4469 /*}}}*/
4470
4471
4472 /* Routine to close and cleanup a pipe info structure */
4473
4474 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4475
4476     unsigned long int retsts;
4477     int done, n;
4478     pInfo next, last;
4479
4480     /* If we were writing to a subprocess, insure that someone reading from
4481      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4482      * produce an EOF record in the mailbox.
4483      *
4484      *  well, at least sometimes it *does*, so we have to watch out for
4485      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4486      */
4487      if (info->fp) {
4488         if (!info->useFILE
4489 #if defined(USE_ITHREADS)
4490           && my_perl
4491 #endif
4492 #ifdef USE_PERLIO
4493           && PL_perlio_fd_refcnt
4494 #endif
4495            )
4496             PerlIO_flush(info->fp);
4497         else
4498             fflush((FILE *)info->fp);
4499     }
4500
4501     _ckvmssts(sys$setast(0));
4502      info->closing = TRUE;
4503      done = info->done && info->in_done && info->out_done && info->err_done;
4504      /* hanging on write to Perl's input? cancel it */
4505      if (info->mode == 'r' && info->out && !info->out_done) {
4506         if (info->out->chan_out) {
4507             _ckvmssts(sys$cancel(info->out->chan_out));
4508             if (!info->out->chan_in) {   /* EOF generation, need AST */
4509                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4510             }
4511         }
4512      }
4513      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4514          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4515                            0, 0, 0, 0, 0, 0));
4516     _ckvmssts(sys$setast(1));
4517     if (info->fp) {
4518      if (!info->useFILE
4519 #if defined(USE_ITHREADS)
4520          && my_perl
4521 #endif
4522 #ifdef USE_PERLIO
4523          && PL_perlio_fd_refcnt
4524 #endif
4525         )
4526         PerlIO_close(info->fp);
4527      else
4528         fclose((FILE *)info->fp);
4529     }
4530      /*
4531         we have to wait until subprocess completes, but ALSO wait until all
4532         the i/o completes...otherwise we'll be freeing the "info" structure
4533         that the i/o ASTs could still be using...
4534      */
4535
4536      while (!done) {
4537          _ckvmssts(sys$setast(0));
4538          done = info->done && info->in_done && info->out_done && info->err_done;
4539          if (!done) _ckvmssts(sys$clref(pipe_ef));
4540          _ckvmssts(sys$setast(1));
4541          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4542      }
4543      retsts = info->completion;
4544
4545     /* remove from list of open pipes */
4546     _ckvmssts(sys$setast(0));
4547     last = NULL;
4548     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4549         if (next == info)
4550             break;
4551     }
4552
4553     if (last)
4554         last->next = info->next;
4555     else
4556         open_pipes = info->next;
4557     _ckvmssts(sys$setast(1));
4558
4559     /* free buffers and structures */
4560
4561     if (info->in) {
4562         if (info->in->buf) {
4563             n = info->in->bufsize * sizeof(char);
4564             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4565         }
4566         n = sizeof(Pipe);
4567         _ckvmssts(lib$free_vm(&n, &info->in));
4568     }
4569     if (info->out) {
4570         if (info->out->buf) {
4571             n = info->out->bufsize * sizeof(char);
4572             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4573         }
4574         n = sizeof(Pipe);
4575         _ckvmssts(lib$free_vm(&n, &info->out));
4576     }
4577     if (info->err) {
4578         if (info->err->buf) {
4579             n = info->err->bufsize * sizeof(char);
4580             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4581         }
4582         n = sizeof(Pipe);
4583         _ckvmssts(lib$free_vm(&n, &info->err));
4584     }
4585     n = sizeof(Info);
4586     _ckvmssts(lib$free_vm(&n, &info));
4587
4588     return retsts;
4589 }
4590
4591
4592 /*{{{  I32 my_pclose(PerlIO *fp)*/
4593 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4594 {
4595     pInfo info, last = NULL;
4596     I32 ret_status;
4597
4598     /* Fixme - need ast and mutex protection here */
4599     for (info = open_pipes; info != NULL; last = info, info = info->next)
4600         if (info->fp == fp) break;
4601
4602     if (info == NULL) {  /* no such pipe open */
4603       set_errno(ECHILD); /* quoth POSIX */
4604       set_vaxc_errno(SS$_NONEXPR);
4605       return -1;
4606     }
4607
4608     ret_status = my_pclose_pinfo(aTHX_ info);
4609
4610     return ret_status;
4611
4612 }  /* end of my_pclose() */
4613
4614 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4615   /* Roll our own prototype because we want this regardless of whether
4616    * _VMS_WAIT is defined.
4617    */
4618
4619 #ifdef __cplusplus
4620 extern "C" {
4621 #endif
4622   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4623 #ifdef __cplusplus
4624 }
4625 #endif
4626
4627 #endif
4628 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4629    created with popen(); otherwise partially emulate waitpid() unless
4630    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4631    Also check processes not considered by the CRTL waitpid().
4632  */
4633 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4634 Pid_t
4635 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4636 {
4637     pInfo info;
4638     int done;
4639     int sts;
4640     int j;
4641
4642     if (statusp) *statusp = 0;
4643
4644     for (info = open_pipes; info != NULL; info = info->next)
4645         if (info->pid == pid) break;
4646
4647     if (info != NULL) {  /* we know about this child */
4648       while (!info->done) {
4649           _ckvmssts(sys$setast(0));
4650           done = info->done;
4651           if (!done) _ckvmssts(sys$clref(pipe_ef));
4652           _ckvmssts(sys$setast(1));
4653           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4654       }
4655
4656       if (statusp) *statusp = info->completion;
4657       return pid;
4658     }
4659
4660     /* child that already terminated? */
4661
4662     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4663         if (closed_list[j].pid == pid) {
4664             if (statusp) *statusp = closed_list[j].completion;
4665             return pid;
4666         }
4667     }
4668
4669     /* fall through if this child is not one of our own pipe children */
4670
4671 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4672
4673       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4674        * in 7.2 did we get a version that fills in the VMS completion
4675        * status as Perl has always tried to do.
4676        */
4677
4678       sts = __vms_waitpid( pid, statusp, flags );
4679
4680       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4681          return sts;
4682
4683       /* If the real waitpid tells us the child does not exist, we
4684        * fall through here to implement waiting for a child that
4685        * was created by some means other than exec() (say, spawned
4686        * from DCL) or to wait for a process that is not a subprocess
4687        * of the current process.
4688        */
4689
4690 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4691
4692     {
4693       $DESCRIPTOR(intdsc,"0 00:00:01");
4694       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4695       unsigned long int pidcode = JPI$_PID, mypid;
4696       unsigned long int interval[2];
4697       unsigned int jpi_iosb[2];
4698       struct itmlst_3 jpilist[2] = {
4699           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4700           {                      0,         0,                 0, 0}
4701       };
4702
4703       if (pid <= 0) {
4704         /* Sorry folks, we don't presently implement rooting around for
4705            the first child we can find, and we definitely don't want to
4706            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4707          */
4708         set_errno(ENOTSUP);
4709         return -1;
4710       }
4711
4712       /* Get the owner of the child so I can warn if it's not mine. If the
4713        * process doesn't exist or I don't have the privs to look at it,
4714        * I can go home early.
4715        */
4716       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4717       if (sts & 1) sts = jpi_iosb[0];
4718       if (!(sts & 1)) {
4719         switch (sts) {
4720             case SS$_NONEXPR:
4721                 set_errno(ECHILD);
4722                 break;
4723             case SS$_NOPRIV:
4724                 set_errno(EACCES);
4725                 break;
4726             default:
4727                 _ckvmssts(sts);
4728         }
4729         set_vaxc_errno(sts);
4730         return -1;
4731       }
4732
4733       if (ckWARN(WARN_EXEC)) {
4734         /* remind folks they are asking for non-standard waitpid behavior */
4735         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4736         if (ownerpid != mypid)
4737           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4738                       "waitpid: process %x is not a child of process %x",
4739                       pid,mypid);
4740       }
4741
4742       /* simply check on it once a second until it's not there anymore. */
4743
4744       _ckvmssts(sys$bintim(&intdsc,interval));
4745       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4746             _ckvmssts(sys$schdwk(0,0,interval,0));
4747             _ckvmssts(sys$hiber());
4748       }
4749       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4750
4751       _ckvmssts(sts);
4752       return pid;
4753     }
4754 }  /* end of waitpid() */
4755 /*}}}*/
4756 /*}}}*/
4757 /*}}}*/
4758
4759 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4760 char *
4761 my_gconvert(double val, int ndig, int trail, char *buf)
4762 {
4763   static char __gcvtbuf[DBL_DIG+1];
4764   char *loc;
4765
4766   loc = buf ? buf : __gcvtbuf;
4767
4768   if (val) {
4769     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4770     return gcvt(val,ndig,loc);
4771   }
4772   else {
4773     loc[0] = '0'; loc[1] = '\0';
4774     return loc;
4775   }
4776
4777 }
4778 /*}}}*/
4779
4780 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4781 static int rms_free_search_context(struct FAB * fab)
4782 {
4783 struct NAM * nam;
4784
4785     nam = fab->fab$l_nam;
4786     nam->nam$b_nop |= NAM$M_SYNCHK;
4787     nam->nam$l_rlf = NULL;
4788     fab->fab$b_dns = 0;
4789     return sys$parse(fab, NULL, NULL);
4790 }
4791
4792 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4793 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4794 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4795 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4796 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4797 #define rms_nam_esll(nam) nam.nam$b_esl
4798 #define rms_nam_esl(nam) nam.nam$b_esl
4799 #define rms_nam_name(nam) nam.nam$l_name
4800 #define rms_nam_namel(nam) nam.nam$l_name
4801 #define rms_nam_type(nam) nam.nam$l_type
4802 #define rms_nam_typel(nam) nam.nam$l_type
4803 #define rms_nam_ver(nam) nam.nam$l_ver
4804 #define rms_nam_verl(nam) nam.nam$l_ver
4805 #define rms_nam_rsll(nam) nam.nam$b_rsl
4806 #define rms_nam_rsl(nam) nam.nam$b_rsl
4807 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4808 #define rms_set_fna(fab, nam, name, size) \
4809         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4810 #define rms_get_fna(fab, nam) fab.fab$l_fna
4811 #define rms_set_dna(fab, nam, name, size) \
4812         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4813 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4814 #define rms_set_esa(nam, name, size) \
4815         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4816 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4817         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4818 #define rms_set_rsa(nam, name, size) \
4819         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4820 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4821         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4822 #define rms_nam_name_type_l_size(nam) \
4823         (nam.nam$b_name + nam.nam$b_type)
4824 #else
4825 static int rms_free_search_context(struct FAB * fab)
4826 {
4827 struct NAML * nam;
4828
4829     nam = fab->fab$l_naml;
4830     nam->naml$b_nop |= NAM$M_SYNCHK;
4831     nam->naml$l_rlf = NULL;
4832     nam->naml$l_long_defname_size = 0;
4833
4834     fab->fab$b_dns = 0;
4835     return sys$parse(fab, NULL, NULL);
4836 }
4837
4838 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4839 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4840 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4841 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4842 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4843 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4844 #define rms_nam_esl(nam) nam.naml$b_esl
4845 #define rms_nam_name(nam) nam.naml$l_name
4846 #define rms_nam_namel(nam) nam.naml$l_long_name
4847 #define rms_nam_type(nam) nam.naml$l_type
4848 #define rms_nam_typel(nam) nam.naml$l_long_type
4849 #define rms_nam_ver(nam) nam.naml$l_ver
4850 #define rms_nam_verl(nam) nam.naml$l_long_ver
4851 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4852 #define rms_nam_rsl(nam) nam.naml$b_rsl
4853 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4854 #define rms_set_fna(fab, nam, name, size) \
4855         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4856         nam.naml$l_long_filename_size = size; \
4857         nam.naml$l_long_filename = name;}
4858 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4859 #define rms_set_dna(fab, nam, name, size) \
4860         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4861         nam.naml$l_long_defname_size = size; \
4862         nam.naml$l_long_defname = name; }
4863 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4864 #define rms_set_esa(nam, name, size) \
4865         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4866         nam.naml$l_long_expand_alloc = size; \
4867         nam.naml$l_long_expand = name; }
4868 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4869         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4870         nam.naml$l_long_expand = l_name; \
4871         nam.naml$l_long_expand_alloc = l_size; }
4872 #define rms_set_rsa(nam, name, size) \
4873         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4874         nam.naml$l_long_result = name; \
4875         nam.naml$l_long_result_alloc = size; }
4876 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4877         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4878         nam.naml$l_long_result = l_name; \
4879         nam.naml$l_long_result_alloc = l_size; }
4880 #define rms_nam_name_type_l_size(nam) \
4881         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4882 #endif
4883
4884
4885 /* rms_erase
4886  * The CRTL for 8.3 and later can create symbolic links in any mode,
4887  * however in 8.3 the unlink/remove/delete routines will only properly handle
4888  * them if one of the PCP modes is active.
4889  */
4890 static int rms_erase(const char * vmsname)
4891 {
4892   int status;
4893   struct FAB myfab = cc$rms_fab;
4894   rms_setup_nam(mynam);
4895
4896   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4897   rms_bind_fab_nam(myfab, mynam);
4898
4899 #ifdef NAML$M_OPEN_SPECIAL
4900   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4901 #endif
4902
4903   status = sys$erase(&myfab, 0, 0);
4904
4905   return status;
4906 }
4907
4908
4909 static int
4910 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4911                     const struct dsc$descriptor_s * vms_dst_dsc,
4912                     unsigned long flags)
4913 {
4914     /*  VMS and UNIX handle file permissions differently and the
4915      * the same ACL trick may be needed for renaming files,
4916      * especially if they are directories.
4917      */
4918
4919    /* todo: get kill_file and rename to share common code */
4920    /* I can not find online documentation for $change_acl
4921     * it appears to be replaced by $set_security some time ago */
4922
4923 const unsigned int access_mode = 0;
4924 $DESCRIPTOR(obj_file_dsc,"FILE");
4925 char *vmsname;
4926 char *rslt;
4927 unsigned long int jpicode = JPI$_UIC;
4928 int aclsts, fndsts, rnsts = -1;
4929 unsigned int ctx = 0;
4930 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4931 struct dsc$descriptor_s * clean_dsc;
4932
4933 struct myacedef {
4934     unsigned char myace$b_length;
4935     unsigned char myace$b_type;
4936     unsigned short int myace$w_flags;
4937     unsigned long int myace$l_access;
4938     unsigned long int myace$l_ident;
4939 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4940              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4941              0},
4942              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4943
4944 struct item_list_3
4945         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4946                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4947                       {0,0,0,0}},
4948         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4949         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4950                      {0,0,0,0}};
4951
4952
4953     /* Expand the input spec using RMS, since we do not want to put
4954      * ACLs on the target of a symbolic link */
4955     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
4956     if (vmsname == NULL)
4957         return SS$_INSFMEM;
4958
4959     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4960                         vmsname,
4961                         PERL_RMSEXPAND_M_SYMLINK);
4962     if (rslt == NULL) {
4963         PerlMem_free(vmsname);
4964         return SS$_INSFMEM;
4965     }
4966
4967     /* So we get our own UIC to use as a rights identifier,
4968      * and the insert an ACE at the head of the ACL which allows us
4969      * to delete the file.
4970      */
4971     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4972
4973     fildsc.dsc$w_length = strlen(vmsname);
4974     fildsc.dsc$a_pointer = vmsname;
4975     ctx = 0;
4976     newace.myace$l_ident = oldace.myace$l_ident;
4977     rnsts = SS$_ABORT;
4978
4979     /* Grab any existing ACEs with this identifier in case we fail */
4980     clean_dsc = &fildsc;
4981     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4982                                &fildsc,
4983                                NULL,
4984                                OSS$M_WLOCK,
4985                                findlst,
4986                                &ctx,
4987                                &access_mode);
4988
4989     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4990         /* Add the new ACE . . . */
4991
4992         /* if the sys$get_security succeeded, then ctx is valid, and the
4993          * object/file descriptors will be ignored.  But otherwise they
4994          * are needed
4995          */
4996         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4997                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4998         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4999             set_errno(EVMSERR);
5000             set_vaxc_errno(aclsts);
5001             PerlMem_free(vmsname);
5002             return aclsts;
5003         }
5004
5005         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5006                                 NULL, NULL,
5007                                 &flags,
5008                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5009
5010         if ($VMS_STATUS_SUCCESS(rnsts)) {
5011             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5012         }
5013
5014         /* Put things back the way they were. */
5015         ctx = 0;
5016         aclsts = sys$get_security(&obj_file_dsc,
5017                                   clean_dsc,
5018                                   NULL,
5019                                   OSS$M_WLOCK,
5020                                   findlst,
5021                                   &ctx,
5022                                   &access_mode);
5023
5024         if ($VMS_STATUS_SUCCESS(aclsts)) {
5025         int sec_flags;
5026
5027             sec_flags = 0;
5028             if (!$VMS_STATUS_SUCCESS(fndsts))
5029                 sec_flags = OSS$M_RELCTX;
5030
5031             /* Get rid of the new ACE */
5032             aclsts = sys$set_security(NULL, NULL, NULL,
5033                                   sec_flags, dellst, &ctx, &access_mode);
5034
5035             /* If there was an old ACE, put it back */
5036             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5037                 addlst[0].bufadr = &oldace;
5038                 aclsts = sys$set_security(NULL, NULL, NULL,
5039                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5040                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5041                     set_errno(EVMSERR);
5042                     set_vaxc_errno(aclsts);
5043                     rnsts = aclsts;
5044                 }
5045             } else {
5046             int aclsts2;
5047
5048                 /* Try to clear the lock on the ACL list */
5049                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5050                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5051
5052                 /* Rename errors are most important */
5053                 if (!$VMS_STATUS_SUCCESS(rnsts))
5054                     aclsts = rnsts;
5055                 set_errno(EVMSERR);
5056                 set_vaxc_errno(aclsts);
5057                 rnsts = aclsts;
5058             }
5059         }
5060         else {
5061             if (aclsts != SS$_ACLEMPTY)
5062                 rnsts = aclsts;
5063         }
5064     }
5065     else
5066         rnsts = fndsts;
5067
5068     PerlMem_free(vmsname);
5069     return rnsts;
5070 }
5071
5072
5073 /*{{{int rename(const char *, const char * */
5074 /* Not exactly what X/Open says to do, but doing it absolutely right
5075  * and efficiently would require a lot more work.  This should be close
5076  * enough to pass all but the most strict X/Open compliance test.
5077  */
5078 int
5079 Perl_rename(pTHX_ const char *src, const char * dst)
5080 {
5081 int retval;
5082 int pre_delete = 0;
5083 int src_sts;
5084 int dst_sts;
5085 Stat_t src_st;
5086 Stat_t dst_st;
5087
5088     /* Validate the source file */
5089     src_sts = flex_lstat(src, &src_st);
5090     if (src_sts != 0) {
5091
5092         /* No source file or other problem */
5093         return src_sts;
5094     }
5095     if (src_st.st_devnam[0] == 0)  {
5096         /* This may be possible so fail if it is seen. */
5097         errno = EIO;
5098         return -1;
5099     }
5100
5101     dst_sts = flex_lstat(dst, &dst_st);
5102     if (dst_sts == 0) {
5103
5104         if (dst_st.st_dev != src_st.st_dev) {
5105             /* Must be on the same device */
5106             errno = EXDEV;
5107             return -1;
5108         }
5109
5110         /* VMS_INO_T_COMPARE is true if the inodes are different
5111          * to match the output of memcmp
5112          */
5113
5114         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5115             /* That was easy, the files are the same! */
5116             return 0;
5117         }
5118
5119         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5120             /* If source is a directory, so must be dest */
5121                 errno = EISDIR;
5122                 return -1;
5123         }
5124
5125     }
5126
5127
5128     if ((dst_sts == 0) &&
5129         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5130
5131         /* We have issues here if vms_unlink_all_versions is set
5132          * If the destination exists, and is not a directory, then
5133          * we must delete in advance.
5134          *
5135          * If the src is a directory, then we must always pre-delete
5136          * the destination.
5137          *
5138          * If we successfully delete the dst in advance, and the rename fails
5139          * X/Open requires that errno be EIO.
5140          *
5141          */
5142
5143         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5144             int d_sts;
5145             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5146                                      S_ISDIR(dst_st.st_mode));
5147
5148            /* Need to delete all versions ? */
5149            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5150                 int i = 0;
5151
5152                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5153                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5154                     if (d_sts != 0)
5155                         break;
5156                     i++;
5157
5158                     /* Make sure that we do not loop forever */
5159                     if (i > 32767) {
5160                         errno = EIO;
5161                         d_sts = -1;
5162                         break;
5163                     }
5164                 }
5165            }
5166
5167             if (d_sts != 0)
5168                 return d_sts;
5169
5170             /* We killed the destination, so only errno now is EIO */
5171             pre_delete = 1;
5172         }
5173     }
5174
5175     /* Originally the idea was to call the CRTL rename() and only
5176      * try the lib$rename_file if it failed.
5177      * It turns out that there are too many variants in what the
5178      * the CRTL rename might do, so only use lib$rename_file
5179      */
5180     retval = -1;
5181
5182     {
5183         /* Is the source and dest both in VMS format */
5184         /* if the source is a directory, then need to fileify */
5185         /*  and dest must be a directory or non-existent. */
5186
5187         char * vms_dst;
5188         int sts;
5189         char * ret_str;
5190         unsigned long flags;
5191         struct dsc$descriptor_s old_file_dsc;
5192         struct dsc$descriptor_s new_file_dsc;
5193
5194         /* We need to modify the src and dst depending
5195          * on if one or more of them are directories.
5196          */
5197
5198         vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
5199         if (vms_dst == NULL)
5200             _ckvmssts_noperl(SS$_INSFMEM);
5201
5202         if (S_ISDIR(src_st.st_mode)) {
5203         char * ret_str;
5204         char * vms_dir_file;
5205
5206             vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
5207             if (vms_dir_file == NULL)
5208                 _ckvmssts_noperl(SS$_INSFMEM);
5209
5210             /* If the dest is a directory, we must remove it */
5211             if (dst_sts == 0) {
5212                 int d_sts;
5213                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5214                 if (d_sts != 0) {
5215                     PerlMem_free(vms_dst);
5216                     errno = EIO;
5217                     return d_sts;
5218                 }
5219
5220                 pre_delete = 1;
5221             }
5222
5223            /* The dest must be a VMS file specification */
5224            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5225            if (ret_str == NULL) {
5226                 PerlMem_free(vms_dst);
5227                 errno = EIO;
5228                 return -1;
5229            }
5230
5231             /* The source must be a file specification */
5232             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5233             if (ret_str == NULL) {
5234                 PerlMem_free(vms_dst);
5235                 PerlMem_free(vms_dir_file);
5236                 errno = EIO;
5237                 return -1;
5238             }
5239             PerlMem_free(vms_dst);
5240             vms_dst = vms_dir_file;
5241
5242         } else {
5243             /* File to file or file to new dir */
5244
5245             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5246                 /* VMS pathify a dir target */
5247                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5248                 if (ret_str == NULL) {
5249                     PerlMem_free(vms_dst);
5250                     errno = EIO;
5251                     return -1;
5252                 }
5253             } else {
5254                 char * v_spec, * r_spec, * d_spec, * n_spec;
5255                 char * e_spec, * vs_spec;
5256                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5257
5258                 /* fileify a target VMS file specification */
5259                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5260                 if (ret_str == NULL) {
5261                     PerlMem_free(vms_dst);
5262                     errno = EIO;
5263                     return -1;
5264                 }
5265
5266                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5267                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5268                              &e_len, &vs_spec, &vs_len);
5269                 if (sts == 0) {
5270                      if (e_len == 0) {
5271                          /* Get rid of the version */
5272                          if (vs_len != 0) {
5273                              *vs_spec = '\0';
5274                          }
5275                          /* Need to specify a '.' so that the extension */
5276                          /* is not inherited */
5277                          strcat(vms_dst,".");
5278                      }
5279                 }
5280             }
5281         }
5282
5283         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5284         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5285         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5286         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5287
5288         new_file_dsc.dsc$a_pointer = vms_dst;
5289         new_file_dsc.dsc$w_length = strlen(vms_dst);
5290         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5291         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5292
5293         flags = 0;
5294 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5295         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5296 #endif
5297
5298         sts = lib$rename_file(&old_file_dsc,
5299                               &new_file_dsc,
5300                               NULL, NULL,
5301                               &flags,
5302                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5303         if (!$VMS_STATUS_SUCCESS(sts)) {
5304
5305            /* We could have failed because VMS style permissions do not
5306             * permit renames that UNIX will allow.  Just like the hack
5307             * in for kill_file.
5308             */
5309            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5310         }
5311
5312         PerlMem_free(vms_dst);
5313         if (!$VMS_STATUS_SUCCESS(sts)) {
5314             errno = EIO;
5315             return -1;
5316         }
5317         retval = 0;
5318     }
5319
5320     if (vms_unlink_all_versions) {
5321         /* Now get rid of any previous versions of the source file that
5322          * might still exist
5323          */
5324         int i = 0;
5325         dSAVEDERRNO;
5326         SAVE_ERRNO;
5327         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5328                                    S_ISDIR(src_st.st_mode));
5329         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5330              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5331                                        S_ISDIR(src_st.st_mode));
5332              if (src_sts != 0)
5333                  break;
5334              i++;
5335
5336              /* Make sure that we do not loop forever */
5337              if (i > 32767) {
5338                  src_sts = -1;
5339                  break;
5340              }
5341         }
5342         RESTORE_ERRNO;
5343     }
5344
5345     /* We deleted the destination, so must force the error to be EIO */
5346     if ((retval != 0) && (pre_delete != 0))
5347         errno = EIO;
5348
5349     return retval;
5350 }
5351 /*}}}*/
5352
5353
5354 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5355 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5356  * to expand file specification.  Allows for a single default file
5357  * specification and a simple mask of options.  If outbuf is non-NULL,
5358  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5359  * the resultant file specification is placed.  If outbuf is NULL, the
5360  * resultant file specification is placed into a static buffer.
5361  * The third argument, if non-NULL, is taken to be a default file
5362  * specification string.  The fourth argument is unused at present.
5363  * rmesexpand() returns the address of the resultant string if
5364  * successful, and NULL on error.
5365  *
5366  * New functionality for previously unused opts value:
5367  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5368  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5369  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5370  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5371  */
5372 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5373
5374 static char *
5375 int_rmsexpand
5376    (const char *filespec,
5377     char *outbuf,
5378     const char *defspec,
5379     unsigned opts,
5380     int * fs_utf8,
5381     int * dfs_utf8)
5382 {
5383   char * ret_spec;
5384   const char * in_spec;
5385   char * spec_buf;
5386   const char * def_spec;
5387   char * vmsfspec, *vmsdefspec;
5388   char * esa;
5389   char * esal = NULL;
5390   char * outbufl;
5391   struct FAB myfab = cc$rms_fab;
5392   rms_setup_nam(mynam);
5393   STRLEN speclen;
5394   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5395   int sts;
5396
5397   /* temp hack until UTF8 is actually implemented */
5398   if (fs_utf8 != NULL)
5399     *fs_utf8 = 0;
5400
5401   if (!filespec || !*filespec) {
5402     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5403     return NULL;
5404   }
5405
5406   vmsfspec = NULL;
5407   vmsdefspec = NULL;
5408   outbufl = NULL;
5409
5410   in_spec = filespec;
5411   isunix = 0;
5412   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5413       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5414       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5415
5416       /* If this is a UNIX file spec, convert it to VMS */
5417       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5418                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5419                            &e_len, &vs_spec, &vs_len);
5420       if (sts != 0) {
5421           isunix = 1;
5422           char * ret_spec;
5423
5424           vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5425           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5426           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5427           if (ret_spec == NULL) {
5428               PerlMem_free(vmsfspec);
5429               return NULL;
5430           }
5431           in_spec = (const char *)vmsfspec;
5432
5433           /* Unless we are forcing to VMS format, a UNIX input means
5434            * UNIX output, and that requires long names to be used
5435            */
5436           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5437 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5438               opts |= PERL_RMSEXPAND_M_LONG;
5439 #else
5440               NOOP;
5441 #endif
5442           else
5443               isunix = 0;
5444       }
5445
5446   }
5447
5448   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5449   rms_bind_fab_nam(myfab, mynam);
5450
5451   /* Process the default file specification if present */
5452   def_spec = defspec;
5453   if (defspec && *defspec) {
5454     int t_isunix;
5455     t_isunix = is_unix_filespec(defspec);
5456     if (t_isunix) {
5457       vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5458       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5459       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5460
5461       if (ret_spec == NULL) {
5462           /* Clean up and bail */
5463           PerlMem_free(vmsdefspec);
5464           if (vmsfspec != NULL)
5465               PerlMem_free(vmsfspec);
5466               return NULL;
5467           }
5468           def_spec = (const char *)vmsdefspec;
5469       }
5470       rms_set_dna(myfab, mynam,
5471                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5472   }
5473
5474   /* Now we need the expansion buffers */
5475   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
5476   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5477 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5478   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
5479   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5480 #endif
5481   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5482
5483   /* If a NAML block is used RMS always writes to the long and short
5484    * addresses unless you suppress the short name.
5485    */
5486 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5487   outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
5488   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5489 #endif
5490    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5491
5492 #ifdef NAM$M_NO_SHORT_UPCASE
5493   if (decc_efs_case_preserve)
5494     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5495 #endif
5496
5497    /* We may not want to follow symbolic links */
5498 #ifdef NAML$M_OPEN_SPECIAL
5499   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5500     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5501 #endif
5502
5503   /* First attempt to parse as an existing file */
5504   retsts = sys$parse(&myfab,0,0);
5505   if (!(retsts & STS$K_SUCCESS)) {
5506
5507     /* Could not find the file, try as syntax only if error is not fatal */
5508     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5509     if (retsts == RMS$_DNF ||
5510         retsts == RMS$_DIR ||
5511         retsts == RMS$_DEV ||
5512         retsts == RMS$_PRV) {
5513       retsts = sys$parse(&myfab,0,0);
5514       if (retsts & STS$K_SUCCESS) goto int_expanded;
5515     }
5516
5517      /* Still could not parse the file specification */
5518     /*----------------------------------------------*/
5519     sts = rms_free_search_context(&myfab); /* Free search context */
5520     if (vmsdefspec != NULL)
5521         PerlMem_free(vmsdefspec);
5522     if (vmsfspec != NULL)
5523         PerlMem_free(vmsfspec);
5524     if (outbufl != NULL)
5525         PerlMem_free(outbufl);
5526     PerlMem_free(esa);
5527     if (esal != NULL)
5528         PerlMem_free(esal);
5529     set_vaxc_errno(retsts);
5530     if      (retsts == RMS$_PRV) set_errno(EACCES);
5531     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5532     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5533     else                         set_errno(EVMSERR);
5534     return NULL;
5535   }
5536   retsts = sys$search(&myfab,0,0);
5537   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5538     sts = rms_free_search_context(&myfab); /* Free search context */
5539     if (vmsdefspec != NULL)
5540         PerlMem_free(vmsdefspec);
5541     if (vmsfspec != NULL)
5542         PerlMem_free(vmsfspec);
5543     if (outbufl != NULL)
5544         PerlMem_free(outbufl);
5545     PerlMem_free(esa);
5546     if (esal != NULL)
5547         PerlMem_free(esal);
5548     set_vaxc_errno(retsts);
5549     if      (retsts == RMS$_PRV) set_errno(EACCES);
5550     else                         set_errno(EVMSERR);
5551     return NULL;
5552   }
5553
5554   /* If the input filespec contained any lowercase characters,
5555    * downcase the result for compatibility with Unix-minded code. */
5556 int_expanded:
5557   if (!decc_efs_case_preserve) {
5558     char * tbuf;
5559     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5560       if (islower(*tbuf)) { haslower = 1; break; }
5561   }
5562
5563    /* Is a long or a short name expected */
5564   /*------------------------------------*/
5565   spec_buf = NULL;
5566 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5567   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5568     if (rms_nam_rsll(mynam)) {
5569         spec_buf = outbufl;
5570         speclen = rms_nam_rsll(mynam);
5571     }
5572     else {
5573         spec_buf = esal; /* Not esa */
5574         speclen = rms_nam_esll(mynam);
5575     }
5576   }
5577   else {
5578 #endif
5579     if (rms_nam_rsl(mynam)) {
5580         spec_buf = outbuf;
5581         speclen = rms_nam_rsl(mynam);
5582     }
5583     else {
5584         spec_buf = esa; /* Not esal */
5585         speclen = rms_nam_esl(mynam);
5586     }
5587 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5588   }
5589 #endif
5590   spec_buf[speclen] = '\0';
5591
5592   /* Trim off null fields added by $PARSE
5593    * If type > 1 char, must have been specified in original or default spec
5594    * (not true for version; $SEARCH may have added version of existing file).
5595    */
5596   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5597   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5598     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5599              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5600   }
5601   else {
5602     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5603              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5604   }
5605   if (trimver || trimtype) {
5606     if (defspec && *defspec) {
5607       char *defesal = NULL;
5608       char *defesa = NULL;
5609       defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5610       if (defesa != NULL) {
5611         struct FAB deffab = cc$rms_fab;
5612 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5613         defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5614         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5615 #endif
5616         rms_setup_nam(defnam);
5617
5618         rms_bind_fab_nam(deffab, defnam);
5619
5620         /* Cast ok */
5621         rms_set_fna
5622             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5623
5624         /* RMS needs the esa/esal as a work area if wildcards are involved */
5625         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5626
5627         rms_clear_nam_nop(defnam);
5628         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5629 #ifdef NAM$M_NO_SHORT_UPCASE
5630         if (decc_efs_case_preserve)
5631           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5632 #endif
5633 #ifdef NAML$M_OPEN_SPECIAL
5634         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5635           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5636 #endif
5637         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5638           if (trimver) {
5639              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5640           }
5641           if (trimtype) {
5642             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5643           }
5644         }
5645         if (defesal != NULL)
5646             PerlMem_free(defesal);
5647         PerlMem_free(defesa);
5648       } else {
5649           _ckvmssts_noperl(SS$_INSFMEM);
5650       }
5651     }
5652     if (trimver) {
5653       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5654         if (*(rms_nam_verl(mynam)) != '\"')
5655           speclen = rms_nam_verl(mynam) - spec_buf;
5656       }
5657       else {
5658         if (*(rms_nam_ver(mynam)) != '\"')
5659           speclen = rms_nam_ver(mynam) - spec_buf;
5660       }
5661     }
5662     if (trimtype) {
5663       /* If we didn't already trim version, copy down */
5664       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5665         if (speclen > rms_nam_verl(mynam) - spec_buf)
5666           memmove
5667            (rms_nam_typel(mynam),
5668             rms_nam_verl(mynam),
5669             speclen - (rms_nam_verl(mynam) - spec_buf));
5670           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5671       }
5672       else {
5673         if (speclen > rms_nam_ver(mynam) - spec_buf)
5674           memmove
5675            (rms_nam_type(mynam),
5676             rms_nam_ver(mynam),
5677             speclen - (rms_nam_ver(mynam) - spec_buf));
5678           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5679       }
5680     }
5681   }
5682
5683    /* Done with these copies of the input files */
5684   /*-------------------------------------------*/
5685   if (vmsfspec != NULL)
5686         PerlMem_free(vmsfspec);
5687   if (vmsdefspec != NULL)
5688         PerlMem_free(vmsdefspec);
5689
5690   /* If we just had a directory spec on input, $PARSE "helpfully"
5691    * adds an empty name and type for us */
5692 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5693   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5694     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5695         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5696         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5697       speclen = rms_nam_namel(mynam) - spec_buf;
5698   }
5699   else
5700 #endif
5701   {
5702     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5703         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5704         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5705       speclen = rms_nam_name(mynam) - spec_buf;
5706   }
5707
5708   /* Posix format specifications must have matching quotes */
5709   if (speclen < (VMS_MAXRSS - 1)) {
5710     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5711       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5712         spec_buf[speclen] = '\"';
5713         speclen++;
5714       }
5715     }
5716   }
5717   spec_buf[speclen] = '\0';
5718   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5719
5720   /* Have we been working with an expanded, but not resultant, spec? */
5721   /* Also, convert back to Unix syntax if necessary. */
5722   {
5723   int rsl;
5724
5725 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5726     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5727       rsl = rms_nam_rsll(mynam);
5728     } else
5729 #endif
5730     {
5731       rsl = rms_nam_rsl(mynam);
5732     }
5733     if (!rsl) {
5734       /* rsl is not present, it means that spec_buf is either */
5735       /* esa or esal, and needs to be copied to outbuf */
5736       /* convert to Unix if desired */
5737       if (isunix) {
5738         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5739       } else {
5740         /* VMS file specs are not in UTF-8 */
5741         if (fs_utf8 != NULL)
5742             *fs_utf8 = 0;
5743         my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5744         ret_spec = outbuf;
5745       }
5746     }
5747     else {
5748       /* Now spec_buf is either outbuf or outbufl */
5749       /* We need the result into outbuf */
5750       if (isunix) {
5751            /* If we need this in UNIX, then we need another buffer */
5752            /* to keep things in order */
5753            char * src;
5754            char * new_src = NULL;
5755            if (spec_buf == outbuf) {
5756                new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
5757                my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5758            } else {
5759                src = spec_buf;
5760            }
5761            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5762            if (new_src) {
5763                PerlMem_free(new_src);
5764            }
5765       } else {
5766            /* VMS file specs are not in UTF-8 */
5767            if (fs_utf8 != NULL)
5768                *fs_utf8 = 0;
5769
5770            /* Copy the buffer if needed */
5771            if (outbuf != spec_buf)
5772                my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5773            ret_spec = outbuf;
5774       }
5775     }
5776   }
5777
5778   /* Need to clean up the search context */
5779   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5780   sts = rms_free_search_context(&myfab); /* Free search context */
5781
5782   /* Clean up the extra buffers */
5783   if (esal != NULL)
5784       PerlMem_free(esal);
5785   PerlMem_free(esa);
5786   if (outbufl != NULL)
5787      PerlMem_free(outbufl);
5788
5789   /* Return the result */
5790   return ret_spec;
5791 }
5792
5793 /* Common simple case - Expand an already VMS spec */
5794 static char *
5795 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5796     opts |= PERL_RMSEXPAND_M_VMS_IN;
5797     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5798 }
5799
5800 /* Common simple case - Expand to a VMS spec */
5801 static char *
5802 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5803     opts |= PERL_RMSEXPAND_M_VMS;
5804     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5805 }
5806
5807
5808 /* Entry point used by perl routines */
5809 static char *
5810 mp_do_rmsexpand
5811    (pTHX_ const char *filespec,
5812     char *outbuf,
5813     int ts,
5814     const char *defspec,
5815     unsigned opts,
5816     int * fs_utf8,
5817     int * dfs_utf8)
5818 {
5819     static char __rmsexpand_retbuf[VMS_MAXRSS];
5820     char * expanded, *ret_spec, *ret_buf;
5821
5822     expanded = NULL;
5823     ret_buf = outbuf;
5824     if (ret_buf == NULL) {
5825         if (ts) {
5826             Newx(expanded, VMS_MAXRSS, char);
5827             if (expanded == NULL)
5828                 _ckvmssts(SS$_INSFMEM);
5829             ret_buf = expanded;
5830         } else {
5831             ret_buf = __rmsexpand_retbuf;
5832         }
5833     }
5834
5835
5836     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5837                              opts, fs_utf8,  dfs_utf8);
5838
5839     if (ret_spec == NULL) {
5840        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5841        if (expanded)
5842            Safefree(expanded);
5843     }
5844
5845     return ret_spec;
5846 }
5847 /*}}}*/
5848 /* External entry points */
5849 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5850 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5851 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5852 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5853 char *Perl_rmsexpand_utf8
5854   (pTHX_ const char *spec, char *buf, const char *def,
5855    unsigned opt, int * fs_utf8, int * dfs_utf8)
5856 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5857 char *Perl_rmsexpand_utf8_ts
5858   (pTHX_ const char *spec, char *buf, const char *def,
5859    unsigned opt, int * fs_utf8, int * dfs_utf8)
5860 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5861
5862
5863 /*
5864 ** The following routines are provided to make life easier when
5865 ** converting among VMS-style and Unix-style directory specifications.
5866 ** All will take input specifications in either VMS or Unix syntax. On
5867 ** failure, all return NULL.  If successful, the routines listed below
5868 ** return a pointer to a buffer containing the appropriately
5869 ** reformatted spec (and, therefore, subsequent calls to that routine
5870 ** will clobber the result), while the routines of the same names with
5871 ** a _ts suffix appended will return a pointer to a mallocd string
5872 ** containing the appropriately reformatted spec.
5873 ** In all cases, only explicit syntax is altered; no check is made that
5874 ** the resulting string is valid or that the directory in question
5875 ** actually exists.
5876 **
5877 **   fileify_dirspec() - convert a directory spec into the name of the
5878 **     directory file (i.e. what you can stat() to see if it's a dir).
5879 **     The style (VMS or Unix) of the result is the same as the style
5880 **     of the parameter passed in.
5881 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5882 **     what you prepend to a filename to indicate what directory it's in).
5883 **     The style (VMS or Unix) of the result is the same as the style
5884 **     of the parameter passed in.
5885 **   tounixpath() - convert a directory spec into a Unix-style path.
5886 **   tovmspath() - convert a directory spec into a VMS-style path.
5887 **   tounixspec() - convert any file spec into a Unix-style file spec.
5888 **   tovmsspec() - convert any file spec into a VMS-style spec.
5889 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5890 **
5891 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5892 ** Permission is given to distribute this code as part of the Perl
5893 ** standard distribution under the terms of the GNU General Public
5894 ** License or the Perl Artistic License.  Copies of each may be
5895 ** found in the Perl standard distribution.
5896  */
5897
5898 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5899 static char *
5900 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5901 {
5902     unsigned long int dirlen, retlen, hasfilename = 0;
5903     char *cp1, *cp2, *lastdir;
5904     char *trndir, *vmsdir;
5905     unsigned short int trnlnm_iter_count;
5906     int sts;
5907     if (utf8_fl != NULL)
5908         *utf8_fl = 0;
5909
5910     if (!dir || !*dir) {
5911       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5912     }
5913     dirlen = strlen(dir);
5914     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5915     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5916       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5917         dir = "/sys$disk";
5918         dirlen = 9;
5919       }
5920       else
5921         dirlen = 1;
5922     }
5923     if (dirlen > (VMS_MAXRSS - 1)) {
5924       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5925       return NULL;
5926     }
5927     trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5928     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5929     if (!strpbrk(dir+1,"/]>:")  &&
5930         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5931       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5932       trnlnm_iter_count = 0;
5933       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
5934         trnlnm_iter_count++;
5935         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5936       }
5937       dirlen = strlen(trndir);
5938     }
5939     else {
5940       memcpy(trndir, dir, dirlen);
5941       trndir[dirlen] = '\0';
5942     }
5943
5944     /* At this point we are done with *dir and use *trndir which is a
5945      * copy that can be modified.  *dir must not be modified.
5946      */
5947
5948     /* If we were handed a rooted logical name or spec, treat it like a
5949      * simple directory, so that
5950      *    $ Define myroot dev:[dir.]
5951      *    ... do_fileify_dirspec("myroot",buf,1) ...
5952      * does something useful.
5953      */
5954     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5955       trndir[--dirlen] = '\0';
5956       trndir[dirlen-1] = ']';
5957     }
5958     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5959       trndir[--dirlen] = '\0';
5960       trndir[dirlen-1] = '>';
5961     }
5962
5963     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5964       /* If we've got an explicit filename, we can just shuffle the string. */
5965       if (*(cp1+1)) hasfilename = 1;
5966       /* Similarly, we can just back up a level if we've got multiple levels
5967          of explicit directories in a VMS spec which ends with directories. */
5968       else {
5969         for (cp2 = cp1; cp2 > trndir; cp2--) {
5970           if (*cp2 == '.') {
5971             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5972 /* fix-me, can not scan EFS file specs backward like this */
5973               *cp2 = *cp1; *cp1 = '\0';
5974               hasfilename = 1;
5975               break;
5976             }
5977           }
5978           if (*cp2 == '[' || *cp2 == '<') break;
5979         }
5980       }
5981     }
5982
5983     vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5984     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5985     cp1 = strpbrk(trndir,"]:>");
5986     if (cp1 && *(cp1+1) == ':')   /* DECNet node spec with :: */
5987         cp1 = strpbrk(cp1+2,"]:>");
5988
5989     if (hasfilename || !cp1) { /* filename present or not VMS */
5990
5991       if (trndir[0] == '.') {
5992         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5993           PerlMem_free(trndir);
5994           PerlMem_free(vmsdir);
5995           return int_fileify_dirspec("[]", buf, NULL);
5996         }
5997         else if (trndir[1] == '.' &&
5998                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5999           PerlMem_free(trndir);
6000           PerlMem_free(vmsdir);
6001           return int_fileify_dirspec("[-]", buf, NULL);
6002         }
6003       }
6004       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6005         dirlen -= 1;                 /* to last element */
6006         lastdir = strrchr(trndir,'/');
6007       }
6008       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6009         /* If we have "/." or "/..", VMSify it and let the VMS code
6010          * below expand it, rather than repeating the code to handle
6011          * relative components of a filespec here */
6012         do {
6013           if (*(cp1+2) == '.') cp1++;
6014           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6015             char * ret_chr;
6016             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6017                 PerlMem_free(trndir);
6018                 PerlMem_free(vmsdir);
6019                 return NULL;
6020             }
6021             if (strchr(vmsdir,'/') != NULL) {
6022               /* If int_tovmsspec() returned it, it must have VMS syntax
6023                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6024                * the time to check this here only so we avoid a recursion
6025                * loop; otherwise, gigo.
6026                */
6027               PerlMem_free(trndir);
6028               PerlMem_free(vmsdir);
6029               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6030               return NULL;
6031             }
6032             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6033                 PerlMem_free(trndir);
6034                 PerlMem_free(vmsdir);
6035                 return NULL;
6036             }
6037             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6038             PerlMem_free(trndir);
6039             PerlMem_free(vmsdir);
6040             return ret_chr;
6041           }
6042           cp1++;
6043         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6044         lastdir = strrchr(trndir,'/');
6045       }
6046       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6047         char * ret_chr;
6048         /* Ditto for specs that end in an MFD -- let the VMS code
6049          * figure out whether it's a real device or a rooted logical. */
6050
6051         /* This should not happen any more.  Allowing the fake /000000
6052          * in a UNIX pathname causes all sorts of problems when trying
6053          * to run in UNIX emulation.  So the VMS to UNIX conversions
6054          * now remove the fake /000000 directories.
6055          */
6056
6057         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6058         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6059             PerlMem_free(trndir);
6060             PerlMem_free(vmsdir);
6061             return NULL;
6062         }
6063         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6064             PerlMem_free(trndir);
6065             PerlMem_free(vmsdir);
6066             return NULL;
6067         }
6068         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6069         PerlMem_free(trndir);
6070         PerlMem_free(vmsdir);
6071         return ret_chr;
6072       }
6073       else {
6074
6075         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6076              !(lastdir = cp1 = strrchr(trndir,']')) &&
6077              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6078
6079         cp2 = strrchr(cp1,'.');
6080         if (cp2) {
6081             int e_len, vs_len = 0;
6082             int is_dir = 0;
6083             char * cp3;
6084             cp3 = strchr(cp2,';');
6085             e_len = strlen(cp2);
6086             if (cp3) {
6087                 vs_len = strlen(cp3);
6088                 e_len = e_len - vs_len;
6089             }
6090             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6091             if (!is_dir) {
6092                 if (!decc_efs_charset) {
6093                     /* If this is not EFS, then not a directory */
6094                     PerlMem_free(trndir);
6095                     PerlMem_free(vmsdir);
6096                     set_errno(ENOTDIR);
6097                     set_vaxc_errno(RMS$_DIR);
6098                     return NULL;
6099                 }
6100             } else {
6101                 /* Ok, here we have an issue, technically if a .dir shows */
6102                 /* from inside a directory, then we should treat it as */
6103                 /* xxx^.dir.dir.  But we do not have that context at this */
6104                 /* point unless this is totally restructured, so we remove */
6105                 /* The .dir for now, and fix this better later */
6106                 dirlen = cp2 - trndir;
6107             }
6108             if (decc_efs_charset && !strchr(trndir,'/')) {
6109                 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6110                 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6111
6112                 for (; cp4 > cp1; cp4--) {
6113                     if (*cp4 == '.') {
6114                         if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6115                             memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6116                             *cp4 = '^';
6117                             dirlen++;
6118                         }
6119                     }
6120                 }
6121             }
6122         }
6123
6124       }
6125
6126       retlen = dirlen + 6;
6127       memcpy(buf, trndir, dirlen);
6128       buf[dirlen] = '\0';
6129
6130       /* We've picked up everything up to the directory file name.
6131          Now just add the type and version, and we're set. */
6132       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6133           strcat(buf,".dir");
6134       else
6135           strcat(buf,".DIR");
6136       if (!decc_filename_unix_no_version)
6137           strcat(buf,";1");
6138       PerlMem_free(trndir);
6139       PerlMem_free(vmsdir);
6140       return buf;
6141     }
6142     else {  /* VMS-style directory spec */
6143
6144       char *esa, *esal, term, *cp;
6145       char *my_esa;
6146       int my_esa_len;
6147       unsigned long int cmplen, haslower = 0;
6148       struct FAB dirfab = cc$rms_fab;
6149       rms_setup_nam(savnam);
6150       rms_setup_nam(dirnam);
6151
6152       esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
6153       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6154       esal = NULL;
6155 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6156       esal = (char *)PerlMem_malloc(VMS_MAXRSS);
6157       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6158 #endif
6159       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6160       rms_bind_fab_nam(dirfab, dirnam);
6161       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6162       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6163 #ifdef NAM$M_NO_SHORT_UPCASE
6164       if (decc_efs_case_preserve)
6165         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6166 #endif
6167
6168       for (cp = trndir; *cp; cp++)
6169         if (islower(*cp)) { haslower = 1; break; }
6170       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6171         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6172             (dirfab.fab$l_sts == RMS$_DNF) ||
6173             (dirfab.fab$l_sts == RMS$_PRV)) {
6174             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6175             sts = sys$parse(&dirfab);
6176         }
6177         if (!sts) {
6178           PerlMem_free(esa);
6179           if (esal != NULL)
6180               PerlMem_free(esal);
6181           PerlMem_free(trndir);
6182           PerlMem_free(vmsdir);
6183           set_errno(EVMSERR);
6184           set_vaxc_errno(dirfab.fab$l_sts);
6185           return NULL;
6186         }
6187       }
6188       else {
6189         savnam = dirnam;
6190         /* Does the file really exist? */
6191         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6192           /* Yes; fake the fnb bits so we'll check type below */
6193           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6194         }
6195         else { /* No; just work with potential name */
6196           if (dirfab.fab$l_sts    == RMS$_FNF
6197               || dirfab.fab$l_sts == RMS$_DNF
6198               || dirfab.fab$l_sts == RMS$_FND)
6199                 dirnam = savnam;
6200           else {
6201             int fab_sts;
6202             fab_sts = dirfab.fab$l_sts;
6203             sts = rms_free_search_context(&dirfab);
6204             PerlMem_free(esa);
6205             if (esal != NULL)
6206                 PerlMem_free(esal);
6207             PerlMem_free(trndir);
6208             PerlMem_free(vmsdir);
6209             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6210             return NULL;
6211           }
6212         }
6213       }
6214
6215       /* Make sure we are using the right buffer */
6216 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6217       if (esal != NULL) {
6218         my_esa = esal;
6219         my_esa_len = rms_nam_esll(dirnam);
6220       } else {
6221 #endif
6222         my_esa = esa;
6223         my_esa_len = rms_nam_esl(dirnam);
6224 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6225       }
6226 #endif
6227       my_esa[my_esa_len] = '\0';
6228       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6229         cp1 = strchr(my_esa,']');
6230         if (!cp1) cp1 = strchr(my_esa,'>');
6231         if (cp1) {  /* Should always be true */
6232           my_esa_len -= cp1 - my_esa - 1;
6233           memmove(my_esa, cp1 + 1, my_esa_len);
6234         }
6235       }
6236       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6237         /* Yep; check version while we're at it, if it's there. */
6238         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6239         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6240           /* Something other than .DIR[;1].  Bzzt. */
6241           sts = rms_free_search_context(&dirfab);
6242           PerlMem_free(esa);
6243           if (esal != NULL)
6244              PerlMem_free(esal);
6245           PerlMem_free(trndir);
6246           PerlMem_free(vmsdir);
6247           set_errno(ENOTDIR);
6248           set_vaxc_errno(RMS$_DIR);
6249           return NULL;
6250         }
6251       }
6252
6253       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6254         /* They provided at least the name; we added the type, if necessary, */
6255         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6256         sts = rms_free_search_context(&dirfab);
6257         PerlMem_free(trndir);
6258         PerlMem_free(esa);
6259         if (esal != NULL)
6260             PerlMem_free(esal);
6261         PerlMem_free(vmsdir);
6262         return buf;
6263       }
6264       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6265         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6266         *cp1 = '\0';
6267         my_esa_len -= 9;
6268       }
6269       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6270       if (cp1 == NULL) { /* should never happen */
6271         sts = rms_free_search_context(&dirfab);
6272         PerlMem_free(trndir);
6273         PerlMem_free(esa);
6274         if (esal != NULL)
6275             PerlMem_free(esal);
6276         PerlMem_free(vmsdir);
6277         return NULL;
6278       }
6279       term = *cp1;
6280       *cp1 = '\0';
6281       retlen = strlen(my_esa);
6282       cp1 = strrchr(my_esa,'.');
6283       /* ODS-5 directory specifications can have extra "." in them. */
6284       /* Fix-me, can not scan EFS file specifications backwards */
6285       while (cp1 != NULL) {
6286         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6287           break;
6288         else {
6289            cp1--;
6290            while ((cp1 > my_esa) && (*cp1 != '.'))
6291              cp1--;
6292         }
6293         if (cp1 == my_esa)
6294           cp1 = NULL;
6295       }
6296
6297       if ((cp1) != NULL) {
6298         /* There's more than one directory in the path.  Just roll back. */
6299         *cp1 = term;
6300         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6301       }
6302       else {
6303         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6304           /* Go back and expand rooted logical name */
6305           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6306 #ifdef NAM$M_NO_SHORT_UPCASE
6307           if (decc_efs_case_preserve)
6308             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6309 #endif
6310           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6311             sts = rms_free_search_context(&dirfab);
6312             PerlMem_free(esa);
6313             if (esal != NULL)
6314                 PerlMem_free(esal);
6315             PerlMem_free(trndir);
6316             PerlMem_free(vmsdir);
6317             set_errno(EVMSERR);
6318             set_vaxc_errno(dirfab.fab$l_sts);
6319             return NULL;
6320           }
6321
6322           /* This changes the length of the string of course */
6323           if (esal != NULL) {
6324               my_esa_len = rms_nam_esll(dirnam);
6325           } else {
6326               my_esa_len = rms_nam_esl(dirnam);
6327           }
6328
6329           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6330           cp1 = strstr(my_esa,"][");
6331           if (!cp1) cp1 = strstr(my_esa,"]<");
6332           dirlen = cp1 - my_esa;
6333           memcpy(buf, my_esa, dirlen);
6334           if (!strncmp(cp1+2,"000000]",7)) {
6335             buf[dirlen-1] = '\0';
6336             /* fix-me Not full ODS-5, just extra dots in directories for now */
6337             cp1 = buf + dirlen - 1;
6338             while (cp1 > buf)
6339             {
6340               if (*cp1 == '[')
6341                 break;
6342               if (*cp1 == '.') {
6343                 if (*(cp1-1) != '^')
6344                   break;
6345               }
6346               cp1--;
6347             }
6348             if (*cp1 == '.') *cp1 = ']';
6349             else {
6350               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6351               memmove(cp1+1,"000000]",7);
6352             }
6353           }
6354           else {
6355             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6356             buf[retlen] = '\0';
6357             /* Convert last '.' to ']' */
6358             cp1 = buf+retlen-1;
6359             while (*cp != '[') {
6360               cp1--;
6361               if (*cp1 == '.') {
6362                 /* Do not trip on extra dots in ODS-5 directories */
6363                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6364                 break;
6365               }
6366             }
6367             if (*cp1 == '.') *cp1 = ']';
6368             else {
6369               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6370               memmove(cp1+1,"000000]",7);
6371             }
6372           }
6373         }
6374         else {  /* This is a top-level dir.  Add the MFD to the path. */
6375           cp1 = strrchr(my_esa, ':');
6376           assert(cp1);
6377           memmove(buf, my_esa, cp1 - my_esa + 1);
6378           memmove(buf + (cp1 - my_esa) + 1, "[000000]", 8);
6379           memmove(buf + (cp1 - my_esa) + 9, cp1 + 2, retlen - (cp1 - my_esa + 2));
6380           buf[retlen + 7] = '\0';  /* We've inserted '000000]' */
6381         }
6382       }
6383       sts = rms_free_search_context(&dirfab);
6384       /* We've set up the string up through the filename.  Add the
6385          type and version, and we're done. */
6386       strcat(buf,".DIR;1");
6387
6388       /* $PARSE may have upcased filespec, so convert output to lower
6389        * case if input contained any lowercase characters. */
6390       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6391       PerlMem_free(trndir);
6392       PerlMem_free(esa);
6393       if (esal != NULL)
6394         PerlMem_free(esal);
6395       PerlMem_free(vmsdir);
6396       return buf;
6397     }
6398 }  /* end of int_fileify_dirspec() */
6399
6400
6401 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6402 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6403 {
6404     static char __fileify_retbuf[VMS_MAXRSS];
6405     char * fileified, *ret_spec, *ret_buf;
6406
6407     fileified = NULL;
6408     ret_buf = buf;
6409     if (ret_buf == NULL) {
6410         if (ts) {
6411             Newx(fileified, VMS_MAXRSS, char);
6412             if (fileified == NULL)
6413                 _ckvmssts(SS$_INSFMEM);
6414             ret_buf = fileified;
6415         } else {
6416             ret_buf = __fileify_retbuf;
6417         }
6418     }
6419
6420     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6421
6422     if (ret_spec == NULL) {
6423        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6424        if (fileified)
6425            Safefree(fileified);
6426     }
6427
6428     return ret_spec;
6429 }  /* end of do_fileify_dirspec() */
6430 /*}}}*/
6431
6432 /* External entry points */
6433 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6434 { return do_fileify_dirspec(dir,buf,0,NULL); }
6435 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6436 { return do_fileify_dirspec(dir,buf,1,NULL); }
6437 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6438 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6439 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6440 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6441
6442 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6443     char * v_spec, int v_len, char * r_spec, int r_len,
6444     char * d_spec, int d_len, char * n_spec, int n_len,
6445     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6446
6447     /* VMS specification - Try to do this the simple way */
6448     if ((v_len + r_len > 0) || (d_len > 0)) {
6449         int is_dir;
6450
6451         /* No name or extension component, already a directory */
6452         if ((n_len + e_len + vs_len) == 0) {
6453             strcpy(buf, dir);
6454             return buf;
6455         }
6456
6457         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6458         /* This results from catfile() being used instead of catdir() */
6459         /* So even though it should not work, we need to allow it */
6460
6461         /* If this is .DIR;1 then do a simple conversion */
6462         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6463         if (is_dir || (e_len == 0) && (d_len > 0)) {
6464              int len;
6465              len = v_len + r_len + d_len - 1;
6466              char dclose = d_spec[d_len - 1];
6467              memcpy(buf, dir, len);
6468              buf[len] = '.';
6469              len++;
6470              memcpy(&buf[len], n_spec, n_len);
6471              len += n_len;
6472              buf[len] = dclose;
6473              buf[len + 1] = '\0';
6474              return buf;
6475         }
6476
6477 #ifdef HAS_SYMLINK
6478         else if (d_len > 0) {
6479             /* In the olden days, a directory needed to have a .DIR */
6480             /* extension to be a valid directory, but now it could  */
6481             /* be a symbolic link */
6482             int len;
6483             len = v_len + r_len + d_len - 1;
6484             char dclose = d_spec[d_len - 1];
6485             memcpy(buf, dir, len);
6486             buf[len] = '.';
6487             len++;
6488             memcpy(&buf[len], n_spec, n_len);
6489             len += n_len;
6490             if (e_len > 0) {
6491                 if (decc_efs_charset) {
6492                     if (e_len == 4
6493                         && (toupper(e_spec[1]) == 'D')
6494                         && (toupper(e_spec[2]) == 'I')
6495                         && (toupper(e_spec[3]) == 'R')) {
6496
6497                         /* Corner case: directory spec with invalid version.
6498                          * Valid would have followed is_dir path above.
6499                          */
6500                         SETERRNO(ENOTDIR, RMS$_DIR);
6501                         return NULL;
6502                     }
6503                     else {
6504                         buf[len] = '^';
6505                         len++;
6506                         memcpy(&buf[len], e_spec, e_len);
6507                         len += e_len;
6508                     }
6509                 }
6510                 else {
6511                     SETERRNO(ENOTDIR, RMS$_DIR);
6512                     return NULL;
6513                 }
6514             }
6515             buf[len] = dclose;
6516             buf[len + 1] = '\0';
6517             return buf;
6518         }
6519 #else
6520         else {
6521             set_vaxc_errno(RMS$_DIR);
6522             set_errno(ENOTDIR);
6523             return NULL;
6524         }
6525 #endif
6526     }
6527     set_vaxc_errno(RMS$_DIR);
6528     set_errno(ENOTDIR);
6529     return NULL;
6530 }
6531
6532
6533 /* Internal routine to make sure or convert a directory to be in a */
6534 /* path specification.  No utf8 flag because it is not changed or used */
6535 static char *int_pathify_dirspec(const char *dir, char *buf)
6536 {
6537     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6538     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6539     char * exp_spec, *ret_spec;
6540     char * trndir;
6541     unsigned short int trnlnm_iter_count;
6542     STRLEN trnlen;
6543     int need_to_lower;
6544
6545     if (vms_debug_fileify) {
6546         if (dir == NULL)
6547             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6548         else
6549             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6550     }
6551
6552     /* We may need to lower case the result if we translated  */
6553     /* a logical name or got the current working directory */
6554     need_to_lower = 0;
6555
6556     if (!dir || !*dir) {
6557       set_errno(EINVAL);
6558       set_vaxc_errno(SS$_BADPARAM);
6559       return NULL;
6560     }
6561
6562     trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
6563     if (trndir == NULL)
6564         _ckvmssts_noperl(SS$_INSFMEM);
6565
6566     /* If no directory specified use the current default */
6567     if (*dir)
6568         my_strlcpy(trndir, dir, VMS_MAXRSS);
6569     else {
6570         getcwd(trndir, VMS_MAXRSS - 1);
6571         need_to_lower = 1;
6572     }
6573
6574     /* now deal with bare names that could be logical names */
6575     trnlnm_iter_count = 0;
6576     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6577            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6578         trnlnm_iter_count++;
6579         need_to_lower = 1;
6580         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6581             break;
6582         trnlen = strlen(trndir);
6583
6584         /* Trap simple rooted lnms, and return lnm:[000000] */
6585         if (!strcmp(trndir+trnlen-2,".]")) {
6586             my_strlcpy(buf, dir, VMS_MAXRSS);
6587             strcat(buf, ":[000000]");
6588             PerlMem_free(trndir);
6589
6590             if (vms_debug_fileify) {
6591                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6592             }
6593             return buf;
6594         }
6595     }
6596
6597     /* At this point we do not work with *dir, but the copy in  *trndir */
6598
6599     if (need_to_lower && !decc_efs_case_preserve) {
6600         /* Legacy mode, lower case the returned value */
6601         __mystrtolower(trndir);
6602     }
6603
6604
6605     /* Some special cases, '..', '.' */
6606     sts = 0;
6607     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6608        /* Force UNIX filespec */
6609        sts = 1;
6610
6611     } else {
6612         /* Is this Unix or VMS format? */
6613         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6614                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6615                              &e_len, &vs_spec, &vs_len);
6616         if (sts == 0) {
6617
6618             /* Just a filename? */
6619             if ((v_len + r_len + d_len) == 0) {
6620
6621                 /* Now we have a problem, this could be Unix or VMS */
6622                 /* We have to guess.  .DIR usually means VMS */
6623
6624                 /* In UNIX report mode, the .DIR extension is removed */
6625                 /* if one shows up, it is for a non-directory or a directory */
6626                 /* in EFS charset mode */
6627
6628                 /* So if we are in Unix report mode, assume that this */
6629                 /* is a relative Unix directory specification */
6630
6631                 sts = 1;
6632                 if (!decc_filename_unix_report && decc_efs_charset) {
6633                     int is_dir;
6634                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6635
6636                     if (is_dir) {
6637                         /* Traditional mode, assume .DIR is directory */
6638                         buf[0] = '[';
6639                         buf[1] = '.';
6640                         memcpy(&buf[2], n_spec, n_len);
6641                         buf[n_len + 2] = ']';
6642                         buf[n_len + 3] = '\0';
6643                         PerlMem_free(trndir);
6644                         if (vms_debug_fileify) {
6645                             fprintf(stderr,
6646                                     "int_pathify_dirspec: buf = %s\n",
6647                                     buf);
6648                         }
6649                         return buf;
6650                     }
6651                 }
6652             }
6653         }
6654     }
6655     if (sts == 0) {
6656         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6657             v_spec, v_len, r_spec, r_len,
6658             d_spec, d_len, n_spec, n_len,
6659             e_spec, e_len, vs_spec, vs_len);
6660
6661         if (ret_spec != NULL) {
6662             PerlMem_free(trndir);
6663             if (vms_debug_fileify) {
6664                 fprintf(stderr,
6665                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6666             }
6667             return ret_spec;
6668         }
6669
6670         /* Simple way did not work, which means that a logical name */
6671         /* was present for the directory specification.             */
6672         /* Need to use an rmsexpand variant to decode it completely */
6673         exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
6674         if (exp_spec == NULL)
6675             _ckvmssts_noperl(SS$_INSFMEM);
6676
6677         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6678         if (ret_spec != NULL) {
6679             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6680                                  &r_spec, &r_len, &d_spec, &d_len,
6681                                  &n_spec, &n_len, &e_spec,
6682                                  &e_len, &vs_spec, &vs_len);
6683             if (sts == 0) {
6684                 ret_spec = int_pathify_dirspec_simple(
6685                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6686                     d_spec, d_len, n_spec, n_len,
6687                     e_spec, e_len, vs_spec, vs_len);
6688
6689                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6690                     /* Legacy mode, lower case the returned value */
6691                     __mystrtolower(ret_spec);
6692                 }
6693             } else {
6694                 set_vaxc_errno(RMS$_DIR);
6695                 set_errno(ENOTDIR);
6696                 ret_spec = NULL;
6697             }
6698         }
6699         PerlMem_free(exp_spec);
6700         PerlMem_free(trndir);
6701         if (vms_debug_fileify) {
6702             if (ret_spec == NULL)
6703                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6704             else
6705                 fprintf(stderr,
6706                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6707         }
6708         return ret_spec;
6709
6710     } else {
6711         /* Unix specification, Could be trivial conversion, */
6712         /* but have to deal with trailing '.dir' or extra '.' */
6713
6714         char * lastdot;
6715         char * lastslash;
6716         int is_dir;
6717         STRLEN dir_len = strlen(trndir);
6718
6719         lastslash = strrchr(trndir, '/');
6720         if (lastslash == NULL)
6721             lastslash = trndir;
6722         else
6723             lastslash++;
6724
6725         lastdot = NULL;
6726
6727         /* '..' or '.' are valid directory components */
6728         is_dir = 0;
6729         if (lastslash[0] == '.') {
6730             if (lastslash[1] == '\0') {
6731                is_dir = 1;
6732             } else if (lastslash[1] == '.') {
6733                 if (lastslash[2] == '\0') {
6734                     is_dir = 1;
6735                 } else {
6736                     /* And finally allow '...' */
6737                     if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6738                         is_dir = 1;
6739                     }
6740                 }
6741             }
6742         }
6743
6744         if (!is_dir) {
6745            lastdot = strrchr(lastslash, '.');
6746         }
6747         if (lastdot != NULL) {
6748             STRLEN e_len;
6749              /* '.dir' is discarded, and any other '.' is invalid */
6750             e_len = strlen(lastdot);
6751
6752             is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6753
6754             if (is_dir) {
6755                 dir_len = dir_len - 4;
6756             }
6757         }
6758
6759         my_strlcpy(buf, trndir, VMS_MAXRSS);
6760         if (buf[dir_len - 1] != '/') {
6761             buf[dir_len] = '/';
6762             buf[dir_len + 1] = '\0';
6763         }
6764
6765         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6766         if (!decc_efs_charset) {
6767              int dir_start = 0;
6768              char * str = buf;
6769              if (str[0] == '.') {
6770                  char * dots = str;
6771                  int cnt = 1;
6772                  while ((dots[cnt] == '.') && (cnt < 3))
6773                      cnt++;
6774                  if (cnt <= 3) {
6775                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6776                          dir_start = 1;
6777                          str += cnt;
6778                      }
6779                  }
6780              }
6781              for (; *str; ++str) {
6782                  while (*str == '/') {
6783                      dir_start = 1;
6784                      *str++;
6785                  }
6786                  if (dir_start) {
6787
6788                      /* Have to skip up to three dots which could be */
6789                      /* directories, 3 dots being a VMS extension for Perl */
6790                      char * dots = str;
6791                      int cnt = 0;
6792                      while ((dots[cnt] == '.') && (cnt < 3)) {
6793                          cnt++;
6794                      }
6795                      if (dots[cnt] == '\0')
6796                          break;
6797                      if ((cnt > 1) && (dots[cnt] != '/')) {
6798                          dir_start = 0;
6799                      } else {
6800                          str += cnt;
6801                      }
6802
6803                      /* too many dots? */
6804                      if ((cnt == 0) || (cnt > 3)) {
6805                          dir_start = 0;
6806                      }
6807                  }
6808                  if (!dir_start && (*str == '.')) {
6809                      *str = '_';
6810                  }
6811              }
6812         }
6813         PerlMem_free(trndir);
6814         ret_spec = buf;
6815         if (vms_debug_fileify) {
6816             if (ret_spec == NULL)
6817                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6818             else
6819                 fprintf(stderr,
6820                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6821         }
6822         return ret_spec;
6823     }
6824 }
6825
6826 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6827 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6828 {
6829     static char __pathify_retbuf[VMS_MAXRSS];
6830     char * pathified, *ret_spec, *ret_buf;
6831
6832     pathified = NULL;
6833     ret_buf = buf;
6834     if (ret_buf == NULL) {
6835         if (ts) {
6836             Newx(pathified, VMS_MAXRSS, char);
6837             if (pathified == NULL)
6838                 _ckvmssts(SS$_INSFMEM);
6839             ret_buf = pathified;
6840         } else {
6841             ret_buf = __pathify_retbuf;
6842         }
6843     }
6844
6845     ret_spec = int_pathify_dirspec(dir, ret_buf);
6846
6847     if (ret_spec == NULL) {
6848        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6849        if (pathified)
6850            Safefree(pathified);
6851     }
6852
6853     return ret_spec;
6854
6855 }  /* end of do_pathify_dirspec() */
6856
6857
6858 /* External entry points */
6859 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6860 { return do_pathify_dirspec(dir,buf,0,NULL); }
6861 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6862 { return do_pathify_dirspec(dir,buf,1,NULL); }
6863 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6864 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6865 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6866 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6867
6868 /* Internal tounixspec routine that does not use a thread context */
6869 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6870 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6871 {
6872   char *dirend, *cp1, *cp3, *tmp;
6873   const char *cp2;
6874   int dirlen;
6875   unsigned short int trnlnm_iter_count;
6876   int cmp_rslt, outchars_added;
6877   if (utf8_fl != NULL)
6878     *utf8_fl = 0;
6879
6880   if (vms_debug_fileify) {
6881       if (spec == NULL)
6882           fprintf(stderr, "int_tounixspec: spec = NULL\n");
6883       else
6884           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6885   }
6886
6887
6888   if (spec == NULL) {
6889       set_errno(EINVAL);
6890       set_vaxc_errno(SS$_BADPARAM);
6891       return NULL;
6892   }
6893   if (strlen(spec) > (VMS_MAXRSS-1)) {
6894       set_errno(E2BIG);
6895       set_vaxc_errno(SS$_BUFFEROVF);
6896       return NULL;
6897   }
6898
6899   /* New VMS specific format needs translation
6900    * glob passes filenames with trailing '\n' and expects this preserved.
6901    */
6902   if (decc_posix_compliant_pathnames) {
6903     if (strncmp(spec, "\"^UP^", 5) == 0) {
6904       char * uspec;
6905       char *tunix;
6906       int tunix_len;
6907       int nl_flag;
6908
6909       tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
6910       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6911       tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
6912       nl_flag = 0;
6913       if (tunix[tunix_len - 1] == '\n') {
6914         tunix[tunix_len - 1] = '\"';
6915         tunix[tunix_len] = '\0';
6916         tunix_len--;
6917         nl_flag = 1;
6918       }
6919       uspec = decc$translate_vms(tunix);
6920       PerlMem_free(tunix);
6921       if ((int)uspec > 0) {
6922         my_strlcpy(rslt, uspec, VMS_MAXRSS);
6923         if (nl_flag) {
6924           strcat(rslt,"\n");
6925         }
6926         else {
6927           /* If we can not translate it, makemaker wants as-is */
6928           my_strlcpy(rslt, spec, VMS_MAXRSS);
6929         }
6930         return rslt;
6931       }
6932     }
6933   }
6934
6935   cmp_rslt = 0; /* Presume VMS */
6936   cp1 = strchr(spec, '/');
6937   if (cp1 == NULL)
6938     cmp_rslt = 0;
6939
6940     /* Look for EFS ^/ */
6941     if (decc_efs_charset) {
6942       while (cp1 != NULL) {
6943         cp2 = cp1 - 1;
6944         if (*cp2 != '^') {
6945           /* Found illegal VMS, assume UNIX */
6946           cmp_rslt = 1;
6947           break;
6948         }
6949       cp1++;
6950       cp1 = strchr(cp1, '/');
6951     }
6952   }
6953
6954   /* Look for "." and ".." */
6955   if (decc_filename_unix_report) {
6956     if (spec[0] == '.') {
6957       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6958         cmp_rslt = 1;
6959       }
6960       else {
6961         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6962           cmp_rslt = 1;
6963         }
6964       }
6965     }
6966   }
6967
6968   cp1 = rslt;
6969   cp2 = spec;
6970
6971   /* This is already UNIX or at least nothing VMS understands,
6972    * so all we can reasonably do is unescape extended chars.
6973    */
6974   if (cmp_rslt) {
6975     while (*cp2) {
6976         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
6977         cp1 += outchars_added;
6978     }
6979     *cp1 = '\0';
6980     if (vms_debug_fileify) {
6981         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6982     }
6983     return rslt;
6984   }
6985
6986   dirend = strrchr(spec,']');
6987   if (dirend == NULL) dirend = strrchr(spec,'>');
6988   if (dirend == NULL) dirend = strchr(spec,':');
6989   if (dirend == NULL) {
6990     while (*cp2) {
6991         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
6992         cp1 += outchars_added;
6993     }
6994     *cp1 = '\0';
6995     if (vms_debug_fileify) {
6996         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6997     }
6998     return rslt;
6999   }
7000
7001   /* Special case 1 - sys$posix_root = / */
7002   if (!decc_disable_posix_root) {
7003     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7004       *cp1 = '/';
7005       cp1++;
7006       cp2 = cp2 + 15;
7007       }
7008   }
7009
7010   /* Special case 2 - Convert NLA0: to /dev/null */
7011   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7012   if (cmp_rslt == 0) {
7013     strcpy(rslt, "/dev/null");
7014     cp1 = cp1 + 9;
7015     cp2 = cp2 + 5;
7016     if (spec[6] != '\0') {
7017       cp1[9] = '/';
7018       cp1++;
7019       cp2++;
7020     }
7021   }
7022
7023    /* Also handle special case "SYS$SCRATCH:" */
7024   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7025   tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
7026   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7027   if (cmp_rslt == 0) {
7028   int islnm;
7029
7030     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7031     if (!islnm) {
7032       strcpy(rslt, "/tmp");
7033       cp1 = cp1 + 4;
7034       cp2 = cp2 + 12;
7035       if (spec[12] != '\0') {
7036         cp1[4] = '/';
7037         cp1++;
7038         cp2++;
7039       }
7040     }
7041   }
7042
7043   if (*cp2 != '[' && *cp2 != '<') {
7044     *(cp1++) = '/';
7045   }
7046   else {  /* the VMS spec begins with directories */
7047     cp2++;
7048     if (*cp2 == ']' || *cp2 == '>') {
7049       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7050       PerlMem_free(tmp);
7051       return rslt;
7052     }
7053     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7054       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7055         PerlMem_free(tmp);
7056         if (vms_debug_fileify) {
7057             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7058         }
7059         return NULL;
7060       }
7061       trnlnm_iter_count = 0;
7062       do {
7063         cp3 = tmp;
7064         while (*cp3 != ':' && *cp3) cp3++;
7065         *(cp3++) = '\0';
7066         if (strchr(cp3,']') != NULL) break;
7067         trnlnm_iter_count++;
7068         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7069       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7070       cp1 = rslt;
7071       cp3 = tmp;
7072       *(cp1++) = '/';
7073       while (*cp3) {
7074         *(cp1++) = *(cp3++);
7075         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7076             PerlMem_free(tmp);
7077             set_errno(ENAMETOOLONG);
7078             set_vaxc_errno(SS$_BUFFEROVF);
7079             if (vms_debug_fileify) {
7080                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7081             }
7082             return NULL; /* No room */
7083         }
7084       }
7085       *(cp1++) = '/';
7086     }
7087     if ((*cp2 == '^')) {
7088         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7089         cp1 += outchars_added;
7090     }
7091     else if ( *cp2 == '.') {
7092       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7093         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7094         cp2 += 3;
7095       }
7096       else cp2++;
7097     }
7098   }
7099   PerlMem_free(tmp);
7100   for (; cp2 <= dirend; cp2++) {
7101     if ((*cp2 == '^')) {
7102         /* EFS file escape, pass the next character as is */
7103         /* Fix me: HEX encoding for Unicode not implemented */
7104         *(cp1++) = *(++cp2);
7105         /* An escaped dot stays as is -- don't convert to slash */
7106         if (*cp2 == '.') cp2++;
7107     }
7108     if (*cp2 == ':') {
7109       *(cp1++) = '/';
7110       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7111     }
7112     else if (*cp2 == ']' || *cp2 == '>') {
7113       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7114     }
7115     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7116       *(cp1++) = '/';
7117       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7118         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7119                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7120         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7121             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7122       }
7123       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7124         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7125         cp2 += 2;
7126       }
7127     }
7128     else if (*cp2 == '-') {
7129       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7130         while (*cp2 == '-') {
7131           cp2++;
7132           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7133         }
7134         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7135                                                          /* filespecs like */
7136           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7137           if (vms_debug_fileify) {
7138               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7139           }
7140           return NULL;
7141         }
7142       }
7143       else *(cp1++) = *cp2;
7144     }
7145     else *(cp1++) = *cp2;
7146   }
7147   /* Translate the rest of the filename. */
7148   while (*cp2) {
7149       int dot_seen = 0;
7150       switch(*cp2) {
7151       /* Fixme - for compatibility with the CRTL we should be removing */
7152       /* spaces from the file specifications, but this may show that */
7153       /* some tests that were appearing to pass are not really passing */
7154       case '%':
7155           cp2++;
7156           *(cp1++) = '?';
7157           break;
7158       case '^':
7159           cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7160           cp1 += outchars_added;
7161           break;
7162       case ';':
7163           if (decc_filename_unix_no_version) {
7164               /* Easy, drop the version */
7165               while (*cp2)
7166                   cp2++;
7167               break;
7168           } else {
7169               /* Punt - passing the version as a dot will probably */
7170               /* break perl in weird ways, but so did passing */
7171               /* through the ; as a version.  Follow the CRTL and */
7172               /* hope for the best. */
7173               cp2++;
7174               *(cp1++) = '.';
7175           }
7176           break;
7177       case '.':
7178           if (dot_seen) {
7179               /* We will need to fix this properly later */
7180               /* As Perl may be installed on an ODS-5 volume, but not */
7181               /* have the EFS_CHARSET enabled, it still may encounter */
7182               /* filenames with extra dots in them, and a precedent got */
7183               /* set which allowed them to work, that we will uphold here */
7184               /* If extra dots are present in a name and no ^ is on them */
7185               /* VMS assumes that the first one is the extension delimiter */
7186               /* the rest have an implied ^. */
7187
7188               /* this is also a conflict as the . is also a version */
7189               /* delimiter in VMS, */
7190
7191               *(cp1++) = *(cp2++);
7192               break;
7193           }
7194           dot_seen = 1;
7195           /* This is an extension */
7196           if (decc_readdir_dropdotnotype) {
7197               cp2++;
7198               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7199                   /* Drop the dot for the extension */
7200                   break;
7201               } else {
7202                   *(cp1++) = '.';
7203               }
7204               break;
7205           }
7206       default:
7207           *(cp1++) = *(cp2++);
7208       }
7209   }
7210   *cp1 = '\0';
7211
7212   /* This still leaves /000000/ when working with a
7213    * VMS device root or concealed root.
7214    */
7215   {
7216   int ulen;
7217   char * zeros;
7218
7219       ulen = strlen(rslt);
7220
7221       /* Get rid of "000000/ in rooted filespecs */
7222       if (ulen > 7) {
7223         zeros = strstr(rslt, "/000000/");
7224         if (zeros != NULL) {
7225           int mlen;
7226           mlen = ulen - (zeros - rslt) - 7;
7227           memmove(zeros, &zeros[7], mlen);
7228           ulen = ulen - 7;
7229           rslt[ulen] = '\0';
7230         }
7231       }
7232   }
7233
7234   if (vms_debug_fileify) {
7235       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7236   }
7237   return rslt;
7238
7239 }  /* end of int_tounixspec() */
7240
7241
7242 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7243 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7244 {
7245     static char __tounixspec_retbuf[VMS_MAXRSS];
7246     char * unixspec, *ret_spec, *ret_buf;
7247
7248     unixspec = NULL;
7249     ret_buf = buf;
7250     if (ret_buf == NULL) {
7251         if (ts) {
7252             Newx(unixspec, VMS_MAXRSS, char);
7253             if (unixspec == NULL)
7254                 _ckvmssts(SS$_INSFMEM);
7255             ret_buf = unixspec;
7256         } else {
7257             ret_buf = __tounixspec_retbuf;
7258         }
7259     }
7260
7261     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7262
7263     if (ret_spec == NULL) {
7264        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7265        if (unixspec)
7266            Safefree(unixspec);
7267     }
7268
7269     return ret_spec;
7270
7271 }  /* end of do_tounixspec() */
7272 /*}}}*/
7273 /* External entry points */
7274 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7275   { return do_tounixspec(spec,buf,0, NULL); }
7276 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7277   { return do_tounixspec(spec,buf,1, NULL); }
7278 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7279   { return do_tounixspec(spec,buf,0, utf8_fl); }
7280 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7281   { return do_tounixspec(spec,buf,1, utf8_fl); }
7282
7283 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7284
7285 /*
7286  This procedure is used to identify if a path is based in either
7287  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7288  it returns the OpenVMS format directory for it.
7289
7290  It is expecting specifications of only '/' or '/xxxx/'
7291
7292  If a posix root does not exist, or 'xxxx' is not a directory
7293  in the posix root, it returns a failure.
7294
7295  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7296
7297  It is used only internally by posix_to_vmsspec_hardway().
7298  */
7299
7300 static int posix_root_to_vms
7301   (char *vmspath, int vmspath_len,
7302    const char *unixpath,
7303    const int * utf8_fl)
7304 {
7305 int sts;
7306 struct FAB myfab = cc$rms_fab;
7307 rms_setup_nam(mynam);
7308 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7309 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7310 char * esa, * esal, * rsa, * rsal;
7311 int dir_flag;
7312 int unixlen;
7313
7314     dir_flag = 0;
7315     vmspath[0] = '\0';
7316     unixlen = strlen(unixpath);
7317     if (unixlen == 0) {
7318       return RMS$_FNF;
7319     }
7320
7321 #if __CRTL_VER >= 80200000
7322   /* If not a posix spec already, convert it */
7323   if (decc_posix_compliant_pathnames) {
7324     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7325       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7326     }
7327     else {
7328       /* This is already a VMS specification, no conversion */
7329       unixlen--;
7330       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7331     }
7332   }
7333   else
7334 #endif
7335   {
7336   int path_len;
7337   int i,j;
7338
7339      /* Check to see if this is under the POSIX root */
7340      if (decc_disable_posix_root) {
7341         return RMS$_FNF;
7342      }
7343
7344      /* Skip leading / */
7345      if (unixpath[0] == '/') {
7346         unixpath++;
7347         unixlen--;
7348      }
7349
7350
7351      strcpy(vmspath,"SYS$POSIX_ROOT:");
7352
7353      /* If this is only the / , or blank, then... */
7354      if (unixpath[0] == '\0') {
7355         /* by definition, this is the answer */
7356         return SS$_NORMAL;
7357      }
7358
7359      /* Need to look up a directory */
7360      vmspath[15] = '[';
7361      vmspath[16] = '\0';
7362
7363      /* Copy and add '^' escape characters as needed */
7364      j = 16;
7365      i = 0;
7366      while (unixpath[i] != 0) {
7367      int k;
7368
7369         j += copy_expand_unix_filename_escape
7370             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7371         i += k;
7372      }
7373
7374      path_len = strlen(vmspath);
7375      if (vmspath[path_len - 1] == '/')
7376         path_len--;
7377      vmspath[path_len] = ']';
7378      path_len++;
7379      vmspath[path_len] = '\0';
7380
7381   }
7382   vmspath[vmspath_len] = 0;
7383   if (unixpath[unixlen - 1] == '/')
7384   dir_flag = 1;
7385   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7386   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7387   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7388   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7389   rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7390   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7391   rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7392   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7393   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7394   rms_bind_fab_nam(myfab, mynam);
7395   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7396   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7397   if (decc_efs_case_preserve)
7398     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7399 #ifdef NAML$M_OPEN_SPECIAL
7400   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7401 #endif
7402
7403   /* Set up the remaining naml fields */
7404   sts = sys$parse(&myfab);
7405
7406   /* It failed! Try again as a UNIX filespec */
7407   if (!(sts & 1)) {
7408     PerlMem_free(esal);
7409     PerlMem_free(esa);
7410     PerlMem_free(rsal);
7411     PerlMem_free(rsa);
7412     return sts;
7413   }
7414
7415    /* get the Device ID and the FID */
7416    sts = sys$search(&myfab);
7417
7418    /* These are no longer needed */
7419    PerlMem_free(esa);
7420    PerlMem_free(rsal);
7421    PerlMem_free(rsa);
7422
7423    /* on any failure, returned the POSIX ^UP^ filespec */
7424    if (!(sts & 1)) {
7425       PerlMem_free(esal);
7426       return sts;
7427    }
7428    specdsc.dsc$a_pointer = vmspath;
7429    specdsc.dsc$w_length = vmspath_len;
7430
7431    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7432    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7433    sts = lib$fid_to_name
7434       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7435
7436   /* on any failure, returned the POSIX ^UP^ filespec */
7437   if (!(sts & 1)) {
7438      /* This can happen if user does not have permission to read directories */
7439      if (strncmp(unixpath,"\"^UP^",5) != 0)
7440        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7441      else
7442        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7443   }
7444   else {
7445     vmspath[specdsc.dsc$w_length] = 0;
7446
7447     /* Are we expecting a directory? */
7448     if (dir_flag != 0) {
7449     int i;
7450     char *eptr;
7451
7452       eptr = NULL;
7453
7454       i = specdsc.dsc$w_length - 1;
7455       while (i > 0) {
7456       int zercnt;
7457         zercnt = 0;
7458         /* Version must be '1' */
7459         if (vmspath[i--] != '1')
7460           break;
7461         /* Version delimiter is one of ".;" */
7462         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7463           break;
7464         i--;
7465         if (vmspath[i--] != 'R')
7466           break;
7467         if (vmspath[i--] != 'I')
7468           break;
7469         if (vmspath[i--] != 'D')
7470           break;
7471         if (vmspath[i--] != '.')
7472           break;
7473         eptr = &vmspath[i+1];
7474         while (i > 0) {
7475           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7476             if (vmspath[i-1] != '^') {
7477               if (zercnt != 6) {
7478                 *eptr = vmspath[i];
7479                 eptr[1] = '\0';
7480                 vmspath[i] = '.';
7481                 break;
7482               }
7483               else {
7484                 /* Get rid of 6 imaginary zero directory filename */
7485                 vmspath[i+1] = '\0';
7486               }
7487             }
7488           }
7489           if (vmspath[i] == '0')
7490             zercnt++;
7491           else
7492             zercnt = 10;
7493           i--;
7494         }
7495         break;
7496       }
7497     }
7498   }
7499   PerlMem_free(esal);
7500   return sts;
7501 }
7502
7503 /* /dev/mumble needs to be handled special.
7504    /dev/null becomes NLA0:, And there is the potential for other stuff
7505    like /dev/tty which may need to be mapped to something.
7506 */
7507
7508 static int
7509 slash_dev_special_to_vms
7510    (const char * unixptr,
7511     char * vmspath,
7512     int vmspath_len)
7513 {
7514 char * nextslash;
7515 int len;
7516 int cmp;
7517
7518     unixptr += 4;
7519     nextslash = strchr(unixptr, '/');
7520     len = strlen(unixptr);
7521     if (nextslash != NULL)
7522         len = nextslash - unixptr;
7523     cmp = strncmp("null", unixptr, 5);
7524     if (cmp == 0) {
7525         if (vmspath_len >= 6) {
7526             strcpy(vmspath, "_NLA0:");
7527             return SS$_NORMAL;
7528         }
7529     }
7530     return 0;
7531 }
7532
7533
7534 /* The built in routines do not understand perl's special needs, so
7535     doing a manual conversion from UNIX to VMS
7536
7537     If the utf8_fl is not null and points to a non-zero value, then
7538     treat 8 bit characters as UTF-8.
7539
7540     The sequence starting with '$(' and ending with ')' will be passed
7541     through with out interpretation instead of being escaped.
7542
7543   */
7544 static int posix_to_vmsspec_hardway
7545   (char *vmspath, int vmspath_len,
7546    const char *unixpath,
7547    int dir_flag,
7548    int * utf8_fl) {
7549
7550 char *esa;
7551 const char *unixptr;
7552 const char *unixend;
7553 char *vmsptr;
7554 const char *lastslash;
7555 const char *lastdot;
7556 int unixlen;
7557 int vmslen;
7558 int dir_start;
7559 int dir_dot;
7560 int quoted;
7561 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7562 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7563
7564   if (utf8_fl != NULL)
7565     *utf8_fl = 0;
7566
7567   unixptr = unixpath;
7568   dir_dot = 0;
7569
7570   /* Ignore leading "/" characters */
7571   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7572     unixptr++;
7573   }
7574   unixlen = strlen(unixptr);
7575
7576   /* Do nothing with blank paths */
7577   if (unixlen == 0) {
7578     vmspath[0] = '\0';
7579     return SS$_NORMAL;
7580   }
7581
7582   quoted = 0;
7583   /* This could have a "^UP^ on the front */
7584   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7585     quoted = 1;
7586     unixptr+= 5;
7587     unixlen-= 5;
7588   }
7589
7590   lastslash = strrchr(unixptr,'/');
7591   lastdot = strrchr(unixptr,'.');
7592   unixend = strrchr(unixptr,'\"');
7593   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7594     unixend = unixptr + unixlen;
7595   }
7596
7597   /* last dot is last dot or past end of string */
7598   if (lastdot == NULL)
7599     lastdot = unixptr + unixlen;
7600
7601   /* if no directories, set last slash to beginning of string */
7602   if (lastslash == NULL) {
7603     lastslash = unixptr;
7604   }
7605   else {
7606     /* Watch out for trailing "." after last slash, still a directory */
7607     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7608       lastslash = unixptr + unixlen;
7609     }
7610
7611     /* Watch out for trailing ".." after last slash, still a directory */
7612     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7613       lastslash = unixptr + unixlen;
7614     }
7615
7616     /* dots in directories are aways escaped */
7617     if (lastdot < lastslash)
7618       lastdot = unixptr + unixlen;
7619   }
7620
7621   /* if (unixptr < lastslash) then we are in a directory */
7622
7623   dir_start = 0;
7624
7625   vmsptr = vmspath;
7626   vmslen = 0;
7627
7628   /* Start with the UNIX path */
7629   if (*unixptr != '/') {
7630     /* relative paths */
7631
7632     /* If allowing logical names on relative pathnames, then handle here */
7633     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7634         !decc_posix_compliant_pathnames) {
7635     char * nextslash;
7636     int seg_len;
7637     char * trn;
7638     int islnm;
7639
7640         /* Find the next slash */
7641         nextslash = strchr(unixptr,'/');
7642
7643         esa = (char *)PerlMem_malloc(vmspath_len);
7644         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7645
7646         trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7647         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7648
7649         if (nextslash != NULL) {
7650
7651             seg_len = nextslash - unixptr;
7652             memcpy(esa, unixptr, seg_len);
7653             esa[seg_len] = 0;
7654         }
7655         else {
7656             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7657         }
7658         /* trnlnm(section) */
7659         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7660
7661         if (islnm) {
7662             /* Now fix up the directory */
7663
7664             /* Split up the path to find the components */
7665             sts = vms_split_path
7666                   (trn,
7667                    &v_spec,
7668                    &v_len,
7669                    &r_spec,
7670                    &r_len,
7671                    &d_spec,
7672                    &d_len,
7673                    &n_spec,
7674                    &n_len,
7675                    &e_spec,
7676                    &e_len,
7677                    &vs_spec,
7678                    &vs_len);
7679
7680             while (sts == 0) {
7681             int cmp;
7682
7683                 /* A logical name must be a directory  or the full
7684                    specification.  It is only a full specification if
7685                    it is the only component */
7686                 if ((unixptr[seg_len] == '\0') ||
7687                     (unixptr[seg_len+1] == '\0')) {
7688
7689                     /* Is a directory being required? */
7690                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7691                         /* Not a logical name */
7692                         break;
7693                     }
7694
7695
7696                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7697                         /* This must be a directory */
7698                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7699                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7700                             vmsptr[vmslen] = ':';
7701                             vmslen++;
7702                             vmsptr[vmslen] = '\0';
7703                             return SS$_NORMAL;
7704                         }
7705                     }
7706
7707                 }
7708
7709
7710                 /* must be dev/directory - ignore version */
7711                 if ((n_len + e_len) != 0)
7712                     break;
7713
7714                 /* transfer the volume */
7715                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7716                     memcpy(vmsptr, v_spec, v_len);
7717                     vmsptr += v_len;
7718                     vmsptr[0] = '\0';
7719                     vmslen += v_len;
7720                 }
7721
7722                 /* unroot the rooted directory */
7723                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7724                     r_spec[0] = '[';
7725                     r_spec[r_len - 1] = ']';
7726
7727                     /* This should not be there, but nothing is perfect */
7728                     if (r_len > 9) {
7729                         cmp = strcmp(&r_spec[1], "000000.");
7730                         if (cmp == 0) {
7731                             r_spec += 7;
7732                             r_spec[7] = '[';
7733                             r_len -= 7;
7734                             if (r_len == 2)
7735                                 r_len = 0;
7736                         }
7737                     }
7738                     if (r_len > 0) {
7739                         memcpy(vmsptr, r_spec, r_len);
7740                         vmsptr += r_len;
7741                         vmslen += r_len;
7742                         vmsptr[0] = '\0';
7743                     }
7744                 }
7745                 /* Bring over the directory. */
7746                 if ((d_len > 0) &&
7747                     ((d_len + vmslen) < vmspath_len)) {
7748                     d_spec[0] = '[';
7749                     d_spec[d_len - 1] = ']';
7750                     if (d_len > 9) {
7751                         cmp = strcmp(&d_spec[1], "000000.");
7752                         if (cmp == 0) {
7753                             d_spec += 7;
7754                             d_spec[7] = '[';
7755                             d_len -= 7;
7756                             if (d_len == 2)
7757                                 d_len = 0;
7758                         }
7759                     }
7760
7761                     if (r_len > 0) {
7762                         /* Remove the redundant root */
7763                         if (r_len > 0) {
7764                             /* remove the ][ */
7765                             vmsptr--;
7766                             vmslen--;
7767                             d_spec++;
7768                             d_len--;
7769                         }
7770                         memcpy(vmsptr, d_spec, d_len);
7771                             vmsptr += d_len;
7772                             vmslen += d_len;
7773                             vmsptr[0] = '\0';
7774                     }
7775                 }
7776                 break;
7777             }
7778         }
7779
7780         PerlMem_free(esa);
7781         PerlMem_free(trn);
7782     }
7783
7784     if (lastslash > unixptr) {
7785     int dotdir_seen;
7786
7787       /* skip leading ./ */
7788       dotdir_seen = 0;
7789       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7790         dotdir_seen = 1;
7791         unixptr++;
7792         unixptr++;
7793       }
7794
7795       /* Are we still in a directory? */
7796       if (unixptr <= lastslash) {
7797         *vmsptr++ = '[';
7798         vmslen = 1;
7799         dir_start = 1;
7800
7801         /* if not backing up, then it is relative forward. */
7802         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7803               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7804           *vmsptr++ = '.';
7805           vmslen++;
7806           dir_dot = 1;
7807           }
7808        }
7809        else {
7810          if (dotdir_seen) {
7811            /* Perl wants an empty directory here to tell the difference
7812             * between a DCL command and a filename
7813             */
7814           *vmsptr++ = '[';
7815           *vmsptr++ = ']';
7816           vmslen = 2;
7817         }
7818       }
7819     }
7820     else {
7821       /* Handle two special files . and .. */
7822       if (unixptr[0] == '.') {
7823         if (&unixptr[1] == unixend) {
7824           *vmsptr++ = '[';
7825           *vmsptr++ = ']';
7826           vmslen += 2;
7827           *vmsptr++ = '\0';
7828           return SS$_NORMAL;
7829         }
7830         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7831           *vmsptr++ = '[';
7832           *vmsptr++ = '-';
7833           *vmsptr++ = ']';
7834           vmslen += 3;
7835           *vmsptr++ = '\0';
7836           return SS$_NORMAL;
7837         }
7838       }
7839     }
7840   }
7841   else {        /* Absolute PATH handling */
7842   int sts;
7843   char * nextslash;
7844   int seg_len;
7845     /* Need to find out where root is */
7846
7847     /* In theory, this procedure should never get an absolute POSIX pathname
7848      * that can not be found on the POSIX root.
7849      * In practice, that can not be relied on, and things will show up
7850      * here that are a VMS device name or concealed logical name instead.
7851      * So to make things work, this procedure must be tolerant.
7852      */
7853     esa = (char *)PerlMem_malloc(vmspath_len);
7854     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7855
7856     sts = SS$_NORMAL;
7857     nextslash = strchr(&unixptr[1],'/');
7858     seg_len = 0;
7859     if (nextslash != NULL) {
7860       int cmp;
7861       seg_len = nextslash - &unixptr[1];
7862       my_strlcpy(vmspath, unixptr, seg_len + 2);
7863       cmp = 1;
7864       if (seg_len == 3) {
7865         cmp = strncmp(vmspath, "dev", 4);
7866         if (cmp == 0) {
7867             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7868             if (sts == SS$_NORMAL)
7869                 return SS$_NORMAL;
7870         }
7871       }
7872       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7873     }
7874
7875     if ($VMS_STATUS_SUCCESS(sts)) {
7876       /* This is verified to be a real path */
7877
7878       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7879       if ($VMS_STATUS_SUCCESS(sts)) {
7880         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
7881         vmsptr = vmspath + vmslen;
7882         unixptr++;
7883         if (unixptr < lastslash) {
7884         char * rptr;
7885           vmsptr--;
7886           *vmsptr++ = '.';
7887           dir_start = 1;
7888           dir_dot = 1;
7889           if (vmslen > 7) {
7890           int cmp;
7891             rptr = vmsptr - 7;
7892             cmp = strcmp(rptr,"000000.");
7893             if (cmp == 0) {
7894               vmslen -= 7;
7895               vmsptr -= 7;
7896               vmsptr[1] = '\0';
7897             } /* removing 6 zeros */
7898           } /* vmslen < 7, no 6 zeros possible */
7899         } /* Not in a directory */
7900       } /* Posix root found */
7901       else {
7902         /* No posix root, fall back to default directory */
7903         strcpy(vmspath, "SYS$DISK:[");
7904         vmsptr = &vmspath[10];
7905         vmslen = 10;
7906         if (unixptr > lastslash) {
7907            *vmsptr = ']';
7908            vmsptr++;
7909            vmslen++;
7910         }
7911         else {
7912            dir_start = 1;
7913         }
7914       }
7915     } /* end of verified real path handling */
7916     else {
7917     int add_6zero;
7918     int islnm;
7919
7920       /* Ok, we have a device or a concealed root that is not in POSIX
7921        * or we have garbage.  Make the best of it.
7922        */
7923
7924       /* Posix to VMS destroyed this, so copy it again */
7925       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
7926       vmslen = strlen(vmspath); /* We know we're truncating. */
7927       vmsptr = &vmsptr[vmslen];
7928       islnm = 0;
7929
7930       /* Now do we need to add the fake 6 zero directory to it? */
7931       add_6zero = 1;
7932       if ((*lastslash == '/') && (nextslash < lastslash)) {
7933         /* No there is another directory */
7934         add_6zero = 0;
7935       }
7936       else {
7937       int trnend;
7938       int cmp;
7939
7940         /* now we have foo:bar or foo:[000000]bar to decide from */
7941         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7942
7943         if (!islnm && !decc_posix_compliant_pathnames) {
7944
7945             cmp = strncmp("bin", vmspath, 4);
7946             if (cmp == 0) {
7947                 /* bin => SYS$SYSTEM: */
7948                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7949             }
7950             else {
7951                 /* tmp => SYS$SCRATCH: */
7952                 cmp = strncmp("tmp", vmspath, 4);
7953                 if (cmp == 0) {
7954                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7955                 }
7956             }
7957         }
7958
7959         trnend = islnm ? islnm - 1 : 0;
7960
7961         /* if this was a logical name, ']' or '>' must be present */
7962         /* if not a logical name, then assume a device and hope. */
7963         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7964
7965         /* if log name and trailing '.' then rooted - treat as device */
7966         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7967
7968         /* Fix me, if not a logical name, a device lookup should be
7969          * done to see if the device is file structured.  If the device
7970          * is not file structured, the 6 zeros should not be put on.
7971          *
7972          * As it is, perl is occasionally looking for dev:[000000]tty.
7973          * which looks a little strange.
7974          *
7975          * Not that easy to detect as "/dev" may be file structured with
7976          * special device files.
7977          */
7978
7979         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
7980             (&nextslash[1] == unixend)) {
7981           /* No real directory present */
7982           add_6zero = 1;
7983         }
7984       }
7985
7986       /* Put the device delimiter on */
7987       *vmsptr++ = ':';
7988       vmslen++;
7989       unixptr = nextslash;
7990       unixptr++;
7991
7992       /* Start directory if needed */
7993       if (!islnm || add_6zero) {
7994         *vmsptr++ = '[';
7995         vmslen++;
7996         dir_start = 1;
7997       }
7998
7999       /* add fake 000000] if needed */
8000       if (add_6zero) {
8001         *vmsptr++ = '0';
8002         *vmsptr++ = '0';
8003         *vmsptr++ = '0';
8004         *vmsptr++ = '0';
8005         *vmsptr++ = '0';
8006         *vmsptr++ = '0';
8007         *vmsptr++ = ']';
8008         vmslen += 7;
8009         dir_start = 0;
8010       }
8011
8012     } /* non-POSIX translation */
8013     PerlMem_free(esa);
8014   } /* End of relative/absolute path handling */
8015
8016   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8017   int dash_flag;
8018   int in_cnt;
8019   int out_cnt;
8020
8021     dash_flag = 0;
8022
8023     if (dir_start != 0) {
8024
8025       /* First characters in a directory are handled special */
8026       while ((*unixptr == '/') ||
8027              ((*unixptr == '.') &&
8028               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8029                 (&unixptr[1]==unixend)))) {
8030       int loop_flag;
8031
8032         loop_flag = 0;
8033
8034         /* Skip redundant / in specification */
8035         while ((*unixptr == '/') && (dir_start != 0)) {
8036           loop_flag = 1;
8037           unixptr++;
8038           if (unixptr == lastslash)
8039             break;
8040         }
8041         if (unixptr == lastslash)
8042           break;
8043
8044         /* Skip redundant ./ characters */
8045         while ((*unixptr == '.') &&
8046                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8047           loop_flag = 1;
8048           unixptr++;
8049           if (unixptr == lastslash)
8050             break;
8051           if (*unixptr == '/')
8052             unixptr++;
8053         }
8054         if (unixptr == lastslash)
8055           break;
8056
8057         /* Skip redundant ../ characters */
8058         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8059              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8060           /* Set the backing up flag */
8061           loop_flag = 1;
8062           dir_dot = 0;
8063           dash_flag = 1;
8064           *vmsptr++ = '-';
8065           vmslen++;
8066           unixptr++; /* first . */
8067           unixptr++; /* second . */
8068           if (unixptr == lastslash)
8069             break;
8070           if (*unixptr == '/') /* The slash */
8071             unixptr++;
8072         }
8073         if (unixptr == lastslash)
8074           break;
8075
8076         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8077         /* Not needed when VMS is pretending to be UNIX. */
8078
8079         /* Is this loop stuck because of too many dots? */
8080         if (loop_flag == 0) {
8081           /* Exit the loop and pass the rest through */
8082           break;
8083         }
8084       }
8085
8086       /* Are we done with directories yet? */
8087       if (unixptr >= lastslash) {
8088
8089         /* Watch out for trailing dots */
8090         if (dir_dot != 0) {
8091             vmslen --;
8092             vmsptr--;
8093         }
8094         *vmsptr++ = ']';
8095         vmslen++;
8096         dash_flag = 0;
8097         dir_start = 0;
8098         if (*unixptr == '/')
8099           unixptr++;
8100       }
8101       else {
8102         /* Have we stopped backing up? */
8103         if (dash_flag) {
8104           *vmsptr++ = '.';
8105           vmslen++;
8106           dash_flag = 0;
8107           /* dir_start continues to be = 1 */
8108         }
8109         if (*unixptr == '-') {
8110           *vmsptr++ = '^';
8111           *vmsptr++ = *unixptr++;
8112           vmslen += 2;
8113           dir_start = 0;
8114
8115           /* Now are we done with directories yet? */
8116           if (unixptr >= lastslash) {
8117
8118             /* Watch out for trailing dots */
8119             if (dir_dot != 0) {
8120               vmslen --;
8121               vmsptr--;
8122             }
8123
8124             *vmsptr++ = ']';
8125             vmslen++;
8126             dash_flag = 0;
8127             dir_start = 0;
8128           }
8129         }
8130       }
8131     }
8132
8133     /* All done? */
8134     if (unixptr >= unixend)
8135       break;
8136
8137     /* Normal characters - More EFS work probably needed */
8138     dir_start = 0;
8139     dir_dot = 0;
8140
8141     switch(*unixptr) {
8142     case '/':
8143         /* remove multiple / */
8144         while (unixptr[1] == '/') {
8145            unixptr++;
8146         }
8147         if (unixptr == lastslash) {
8148           /* Watch out for trailing dots */
8149           if (dir_dot != 0) {
8150             vmslen --;
8151             vmsptr--;
8152           }
8153           *vmsptr++ = ']';
8154         }
8155         else {
8156           dir_start = 1;
8157           *vmsptr++ = '.';
8158           dir_dot = 1;
8159
8160           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8161           /* Not needed when VMS is pretending to be UNIX. */
8162
8163         }
8164         dash_flag = 0;
8165         if (unixptr != unixend)
8166           unixptr++;
8167         vmslen++;
8168         break;
8169     case '.':
8170         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8171             (&unixptr[1] == unixend)) {
8172           *vmsptr++ = '^';
8173           *vmsptr++ = '.';
8174           vmslen += 2;
8175           unixptr++;
8176
8177           /* trailing dot ==> '^..' on VMS */
8178           if (unixptr == unixend) {
8179             *vmsptr++ = '.';
8180             vmslen++;
8181             unixptr++;
8182           }
8183           break;
8184         }
8185
8186         *vmsptr++ = *unixptr++;
8187         vmslen ++;
8188         break;
8189     case '"':
8190         if (quoted && (&unixptr[1] == unixend)) {
8191             unixptr++;
8192             break;
8193         }
8194         in_cnt = copy_expand_unix_filename_escape
8195                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8196         vmsptr += out_cnt;
8197         unixptr += in_cnt;
8198         break;
8199     case '~':
8200     case ';':
8201     case '\\':
8202     case '?':
8203     case ' ':
8204     default:
8205         in_cnt = copy_expand_unix_filename_escape
8206                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8207         vmsptr += out_cnt;
8208         unixptr += in_cnt;
8209         break;
8210     }
8211   }
8212
8213   /* Make sure directory is closed */
8214   if (unixptr == lastslash) {
8215     char *vmsptr2;
8216     vmsptr2 = vmsptr - 1;
8217
8218     if (*vmsptr2 != ']') {
8219       *vmsptr2--;
8220
8221       /* directories do not end in a dot bracket */
8222       if (*vmsptr2 == '.') {
8223         vmsptr2--;
8224
8225         /* ^. is allowed */
8226         if (*vmsptr2 != '^') {
8227           vmsptr--; /* back up over the dot */
8228         }
8229       }
8230       *vmsptr++ = ']';
8231     }
8232   }
8233   else {
8234     char *vmsptr2;
8235     /* Add a trailing dot if a file with no extension */
8236     vmsptr2 = vmsptr - 1;
8237     if ((vmslen > 1) &&
8238         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8239         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8240         *vmsptr++ = '.';
8241         vmslen++;
8242     }
8243   }
8244
8245   *vmsptr = '\0';
8246   return SS$_NORMAL;
8247 }
8248 #endif
8249
8250  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8251 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8252 {
8253 char * result;
8254 int utf8_flag;
8255
8256    /* If a UTF8 flag is being passed, honor it */
8257    utf8_flag = 0;
8258    if (utf8_fl != NULL) {
8259      utf8_flag = *utf8_fl;
8260     *utf8_fl = 0;
8261    }
8262
8263    if (utf8_flag) {
8264      /* If there is a possibility of UTF8, then if any UTF8 characters
8265         are present, then they must be converted to VTF-7
8266       */
8267      result = strcpy(rslt, path); /* FIX-ME */
8268    }
8269    else
8270      result = strcpy(rslt, path);
8271
8272    return result;
8273 }
8274
8275 /* A convenience macro for copying dots in filenames and escaping
8276  * them when they haven't already been escaped, with guards to
8277  * avoid checking before the start of the buffer or advancing
8278  * beyond the end of it (allowing room for the NUL terminator).
8279  */
8280 #define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
8281     if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8282           || ((vmsefsdot) == (vmsefsbuf))) \
8283          && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
8284        ) { \
8285         *((vmsefsdot)++) = '^'; \
8286     } \
8287     if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8288         *((vmsefsdot)++) = '.'; \
8289 } STMT_END
8290
8291 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8292 static char *int_tovmsspec
8293    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8294   char *dirend;
8295   char *lastdot;
8296   char *cp1;
8297   const char *cp2;
8298   unsigned long int infront = 0, hasdir = 1;
8299   int rslt_len;
8300   int no_type_seen;
8301   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8302   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8303
8304   if (vms_debug_fileify) {
8305       if (path == NULL)
8306           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8307       else
8308           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8309   }
8310
8311   if (path == NULL) {
8312       /* If we fail, we should be setting errno */
8313       set_errno(EINVAL);
8314       set_vaxc_errno(SS$_BADPARAM);
8315       return NULL;
8316   }
8317   rslt_len = VMS_MAXRSS-1;
8318
8319   /* '.' and '..' are "[]" and "[-]" for a quick check */
8320   if (path[0] == '.') {
8321     if (path[1] == '\0') {
8322       strcpy(rslt,"[]");
8323       if (utf8_flag != NULL)
8324         *utf8_flag = 0;
8325       return rslt;
8326     }
8327     else {
8328       if (path[1] == '.' && path[2] == '\0') {
8329         strcpy(rslt,"[-]");
8330         if (utf8_flag != NULL)
8331            *utf8_flag = 0;
8332         return rslt;
8333       }
8334     }
8335   }
8336
8337    /* Posix specifications are now a native VMS format */
8338   /*--------------------------------------------------*/
8339 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8340   if (decc_posix_compliant_pathnames) {
8341     if (strncmp(path,"\"^UP^",5) == 0) {
8342       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8343       return rslt;
8344     }
8345   }
8346 #endif
8347
8348   /* This is really the only way to see if this is already in VMS format */
8349   sts = vms_split_path
8350        (path,
8351         &v_spec,
8352         &v_len,
8353         &r_spec,
8354         &r_len,
8355         &d_spec,
8356         &d_len,
8357         &n_spec,
8358         &n_len,
8359         &e_spec,
8360         &e_len,
8361         &vs_spec,
8362         &vs_len);
8363   if (sts == 0) {
8364     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8365        replacement, because the above parse just took care of most of
8366        what is needed to do vmspath when the specification is already
8367        in VMS format.
8368
8369        And if it is not already, it is easier to do the conversion as
8370        part of this routine than to call this routine and then work on
8371        the result.
8372      */
8373
8374     /* If VMS punctuation was found, it is already VMS format */
8375     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8376       if (utf8_flag != NULL)
8377         *utf8_flag = 0;
8378       my_strlcpy(rslt, path, VMS_MAXRSS);
8379       if (vms_debug_fileify) {
8380           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8381       }
8382       return rslt;
8383     }
8384     /* Now, what to do with trailing "." cases where there is no
8385        extension?  If this is a UNIX specification, and EFS characters
8386        are enabled, then the trailing "." should be converted to a "^.".
8387        But if this was already a VMS specification, then it should be
8388        left alone.
8389
8390        So in the case of ambiguity, leave the specification alone.
8391      */
8392
8393
8394     /* If there is a possibility of UTF8, then if any UTF8 characters
8395         are present, then they must be converted to VTF-7
8396      */
8397     if (utf8_flag != NULL)
8398       *utf8_flag = 0;
8399     my_strlcpy(rslt, path, VMS_MAXRSS);
8400     if (vms_debug_fileify) {
8401         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8402     }
8403     return rslt;
8404   }
8405
8406   dirend = strrchr(path,'/');
8407
8408   if (dirend == NULL) {
8409      /* If we get here with no Unix directory delimiters, then this is an
8410       * ambiguous file specification, such as a Unix glob specification, a
8411       * shell or make macro, or a filespec that would be valid except for
8412       * unescaped extended characters.  The safest thing if it's a macro
8413       * is to pass it through as-is.
8414       */
8415       if (strstr(path, "$(")) {
8416           my_strlcpy(rslt, path, VMS_MAXRSS);
8417           if (vms_debug_fileify) {
8418               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8419           }
8420           return rslt;
8421       }
8422       hasdir = 0;
8423   }
8424   else if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8425     if (!*(dirend+2)) dirend +=2;
8426     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8427     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8428   }
8429
8430   cp1 = rslt;
8431   cp2 = path;
8432   lastdot = strrchr(cp2,'.');
8433   if (*cp2 == '/') {
8434     char *trndev;
8435     int islnm, rooted;
8436     STRLEN trnend;
8437
8438     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8439     if (!*(cp2+1)) {
8440       if (decc_disable_posix_root) {
8441         strcpy(rslt,"sys$disk:[000000]");
8442       }
8443       else {
8444         strcpy(rslt,"sys$posix_root:[000000]");
8445       }
8446       if (utf8_flag != NULL)
8447         *utf8_flag = 0;
8448       if (vms_debug_fileify) {
8449           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8450       }
8451       return rslt;
8452     }
8453     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8454     *cp1 = '\0';
8455     trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8456     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8457     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8458
8459      /* DECC special handling */
8460     if (!islnm) {
8461       if (strcmp(rslt,"bin") == 0) {
8462         strcpy(rslt,"sys$system");
8463         cp1 = rslt + 10;
8464         *cp1 = 0;
8465         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8466       }
8467       else if (strcmp(rslt,"tmp") == 0) {
8468         strcpy(rslt,"sys$scratch");
8469         cp1 = rslt + 11;
8470         *cp1 = 0;
8471         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8472       }
8473       else if (!decc_disable_posix_root) {
8474         strcpy(rslt, "sys$posix_root");
8475         cp1 = rslt + 14;
8476         *cp1 = 0;
8477         cp2 = path;
8478         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8479         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8480       }
8481       else if (strcmp(rslt,"dev") == 0) {
8482         if (strncmp(cp2,"/null", 5) == 0) {
8483           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8484             strcpy(rslt,"NLA0");
8485             cp1 = rslt + 4;
8486             *cp1 = 0;
8487             cp2 = cp2 + 5;
8488             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8489           }
8490         }
8491       }
8492     }
8493
8494     trnend = islnm ? strlen(trndev) - 1 : 0;
8495     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8496     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8497     /* If the first element of the path is a logical name, determine
8498      * whether it has to be translated so we can add more directories. */
8499     if (!islnm || rooted) {
8500       *(cp1++) = ':';
8501       *(cp1++) = '[';
8502       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8503       else cp2++;
8504     }
8505     else {
8506       if (cp2 != dirend) {
8507         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8508         cp1 = rslt + trnend;
8509         if (*cp2 != 0) {
8510           *(cp1++) = '.';
8511           cp2++;
8512         }
8513       }
8514       else {
8515         if (decc_disable_posix_root) {
8516           *(cp1++) = ':';
8517           hasdir = 0;
8518         }
8519       }
8520     }
8521     PerlMem_free(trndev);
8522   }
8523   else if (hasdir) {
8524     *(cp1++) = '[';
8525     if (*cp2 == '.') {
8526       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8527         cp2 += 2;         /* skip over "./" - it's redundant */
8528         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8529       }
8530       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8531         *(cp1++) = '-';                                 /* "../" --> "-" */
8532         cp2 += 3;
8533       }
8534       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8535                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8536         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8537         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8538         cp2 += 4;
8539       }
8540       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8541         /* Escape the extra dots in EFS file specifications */
8542         *(cp1++) = '^';
8543       }
8544       if (cp2 > dirend) cp2 = dirend;
8545     }
8546     else *(cp1++) = '.';
8547   }
8548   for (; cp2 < dirend; cp2++) {
8549     if (*cp2 == '/') {
8550       if (*(cp2-1) == '/') continue;
8551       if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
8552       infront = 0;
8553     }
8554     else if (!infront && *cp2 == '.') {
8555       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8556       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8557       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8558         if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
8559         else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
8560         else {
8561           *(cp1++) = '-';
8562         }
8563         cp2 += 2;
8564         if (cp2 == dirend) break;
8565       }
8566       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8567                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8568         if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8569         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8570         if (!*(cp2+3)) {
8571           *(cp1++) = '.';  /* Simulate trailing '/' */
8572           cp2 += 2;  /* for loop will incr this to == dirend */
8573         }
8574         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8575       }
8576       else {
8577         if (decc_efs_charset == 0) {
8578           if (cp1 > rslt && *(cp1-1) == '^')
8579             cp1--;         /* remove the escape, if any */
8580           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8581         }
8582         else {
8583           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8584         }
8585       }
8586     }
8587     else {
8588       if (!infront && cp1 > rslt && *(cp1-1) == '-')  *(cp1++) = '.';
8589       if (*cp2 == '.') {
8590         if (decc_efs_charset == 0) {
8591           if (cp1 > rslt && *(cp1-1) == '^')
8592             cp1--;         /* remove the escape, if any */
8593           *(cp1++) = '_';
8594         }
8595         else {
8596           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8597         }
8598       }
8599       else                  *(cp1++) =  *cp2;
8600       infront = 1;
8601     }
8602   }
8603   if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8604   if (hasdir) *(cp1++) = ']';
8605   if (*cp2 && *cp2 == '/') cp2++;  /* check in case we ended with trailing '/' */
8606   no_type_seen = 0;
8607   if (cp2 > lastdot)
8608     no_type_seen = 1;
8609   while (*cp2) {
8610     switch(*cp2) {
8611     case '?':
8612         if (decc_efs_charset == 0)
8613           *(cp1++) = '%';
8614         else
8615           *(cp1++) = '?';
8616         cp2++;
8617     case ' ':
8618         if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
8619             *(cp1)++ = '^';
8620         *(cp1)++ = '_';
8621         cp2++;
8622         break;
8623     case '.':
8624         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8625             decc_readdir_dropdotnotype) {
8626           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8627           cp2++;
8628
8629           /* trailing dot ==> '^..' on VMS */
8630           if (*cp2 == '\0') {
8631             *(cp1++) = '.';
8632             no_type_seen = 0;
8633           }
8634         }
8635         else {
8636           *(cp1++) = *(cp2++);
8637           no_type_seen = 0;
8638         }
8639         break;
8640     case '$':
8641          /* This could be a macro to be passed through */
8642         *(cp1++) = *(cp2++);
8643         if (*cp2 == '(') {
8644         const char * save_cp2;
8645         char * save_cp1;
8646         int is_macro;
8647
8648             /* paranoid check */
8649             save_cp2 = cp2;
8650             save_cp1 = cp1;
8651             is_macro = 0;
8652
8653             /* Test through */
8654             *(cp1++) = *(cp2++);
8655             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8656                 *(cp1++) = *(cp2++);
8657                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8658                     *(cp1++) = *(cp2++);
8659                 }
8660                 if (*cp2 == ')') {
8661                     *(cp1++) = *(cp2++);
8662                     is_macro = 1;
8663                 }
8664             }
8665             if (is_macro == 0) {
8666                 /* Not really a macro - never mind */
8667                 cp2 = save_cp2;
8668                 cp1 = save_cp1;
8669             }
8670         }
8671         break;
8672     case '\"':
8673     case '~':
8674     case '`':
8675     case '!':
8676     case '#':
8677     case '%':
8678     case '^':
8679         /* Don't escape again if following character is
8680          * already something we escape.
8681          */
8682         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8683             *(cp1++) = *(cp2++);
8684             break;
8685         }
8686         /* But otherwise fall through and escape it. */
8687     case '&':
8688     case '(':
8689     case ')':
8690     case '=':
8691     case '+':
8692     case '\'':
8693     case '@':
8694     case '[':
8695     case ']':
8696     case '{':
8697     case '}':
8698     case ':':
8699     case '\\':
8700     case '|':
8701     case '<':
8702     case '>':
8703         if (cp2 > path && *(cp2-1) != '^') /* not previously escaped */
8704             *(cp1++) = '^';
8705         *(cp1++) = *(cp2++);
8706         break;
8707     case ';':
8708         /* If it doesn't look like the beginning of a version number,
8709          * or we've been promised there are no version numbers, then
8710          * escape it.
8711          */
8712         if (decc_filename_unix_no_version) {
8713           *(cp1++) = '^';
8714         }
8715         else {
8716           size_t all_nums = strspn(cp2+1, "0123456789");
8717           if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0')
8718             *(cp1++) = '^';
8719         }
8720         *(cp1++) = *(cp2++);
8721         break;
8722     default:
8723         *(cp1++) = *(cp2++);
8724     }
8725   }
8726   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8727   char *lcp1;
8728     lcp1 = cp1;
8729     lcp1--;
8730      /* Fix me for "^]", but that requires making sure that you do
8731       * not back up past the start of the filename
8732       */
8733     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8734       *cp1++ = '.';
8735   }
8736   *cp1 = '\0';
8737
8738   if (utf8_flag != NULL)
8739     *utf8_flag = 0;
8740   if (vms_debug_fileify) {
8741       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8742   }
8743   return rslt;
8744
8745 }  /* end of int_tovmsspec() */
8746
8747
8748 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8749 static char *mp_do_tovmsspec
8750    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8751   static char __tovmsspec_retbuf[VMS_MAXRSS];
8752     char * vmsspec, *ret_spec, *ret_buf;
8753
8754     vmsspec = NULL;
8755     ret_buf = buf;
8756     if (ret_buf == NULL) {
8757         if (ts) {
8758             Newx(vmsspec, VMS_MAXRSS, char);
8759             if (vmsspec == NULL)
8760                 _ckvmssts(SS$_INSFMEM);
8761             ret_buf = vmsspec;
8762         } else {
8763             ret_buf = __tovmsspec_retbuf;
8764         }
8765     }
8766
8767     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8768
8769     if (ret_spec == NULL) {
8770        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8771        if (vmsspec)
8772            Safefree(vmsspec);
8773     }
8774
8775     return ret_spec;
8776
8777 }  /* end of mp_do_tovmsspec() */
8778 /*}}}*/
8779 /* External entry points */
8780 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8781   { return do_tovmsspec(path,buf,0,NULL); }
8782 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8783   { return do_tovmsspec(path,buf,1,NULL); }
8784 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8785   { return do_tovmsspec(path,buf,0,utf8_fl); }
8786 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8787   { return do_tovmsspec(path,buf,1,utf8_fl); }
8788
8789 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8790 /* Internal routine for use with out an explicit context present */
8791 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
8792
8793     char * ret_spec, *pathified;
8794
8795     if (path == NULL)
8796         return NULL;
8797
8798     pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8799     if (pathified == NULL)
8800         _ckvmssts_noperl(SS$_INSFMEM);
8801
8802     ret_spec = int_pathify_dirspec(path, pathified);
8803
8804     if (ret_spec == NULL) {
8805         PerlMem_free(pathified);
8806         return NULL;
8807     }
8808
8809     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8810
8811     PerlMem_free(pathified);
8812     return ret_spec;
8813
8814 }
8815
8816 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8817 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8818   static char __tovmspath_retbuf[VMS_MAXRSS];
8819   int vmslen;
8820   char *pathified, *vmsified, *cp;
8821
8822   if (path == NULL) return NULL;
8823   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8824   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8825   if (int_pathify_dirspec(path, pathified) == NULL) {
8826     PerlMem_free(pathified);
8827     return NULL;
8828   }
8829
8830   vmsified = NULL;
8831   if (buf == NULL)
8832      Newx(vmsified, VMS_MAXRSS, char);
8833   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8834     PerlMem_free(pathified);
8835     if (vmsified) Safefree(vmsified);
8836     return NULL;
8837   }
8838   PerlMem_free(pathified);
8839   if (buf) {
8840     return buf;
8841   }
8842   else if (ts) {
8843     vmslen = strlen(vmsified);
8844     Newx(cp,vmslen+1,char);
8845     memcpy(cp,vmsified,vmslen);
8846     cp[vmslen] = '\0';
8847     Safefree(vmsified);
8848     return cp;
8849   }
8850   else {
8851     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8852     Safefree(vmsified);
8853     return __tovmspath_retbuf;
8854   }
8855
8856 }  /* end of do_tovmspath() */
8857 /*}}}*/
8858 /* External entry points */
8859 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8860   { return do_tovmspath(path,buf,0, NULL); }
8861 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8862   { return do_tovmspath(path,buf,1, NULL); }
8863 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8864   { return do_tovmspath(path,buf,0,utf8_fl); }
8865 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8866   { return do_tovmspath(path,buf,1,utf8_fl); }
8867
8868
8869 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8870 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8871   static char __tounixpath_retbuf[VMS_MAXRSS];
8872   int unixlen;
8873   char *pathified, *unixified, *cp;
8874
8875   if (path == NULL) return NULL;
8876   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8877   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8878   if (int_pathify_dirspec(path, pathified) == NULL) {
8879     PerlMem_free(pathified);
8880     return NULL;
8881   }
8882
8883   unixified = NULL;
8884   if (buf == NULL) {
8885       Newx(unixified, VMS_MAXRSS, char);
8886   }
8887   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8888     PerlMem_free(pathified);
8889     if (unixified) Safefree(unixified);
8890     return NULL;
8891   }
8892   PerlMem_free(pathified);
8893   if (buf) {
8894     return buf;
8895   }
8896   else if (ts) {
8897     unixlen = strlen(unixified);
8898     Newx(cp,unixlen+1,char);
8899     memcpy(cp,unixified,unixlen);
8900     cp[unixlen] = '\0';
8901     Safefree(unixified);
8902     return cp;
8903   }
8904   else {
8905     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
8906     Safefree(unixified);
8907     return __tounixpath_retbuf;
8908   }
8909
8910 }  /* end of do_tounixpath() */
8911 /*}}}*/
8912 /* External entry points */
8913 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8914   { return do_tounixpath(path,buf,0,NULL); }
8915 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8916   { return do_tounixpath(path,buf,1,NULL); }
8917 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8918   { return do_tounixpath(path,buf,0,utf8_fl); }
8919 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8920   { return do_tounixpath(path,buf,1,utf8_fl); }
8921
8922 /*
8923  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8924  *
8925  *****************************************************************************
8926  *                                                                           *
8927  *  Copyright (C) 1989-1994, 2007 by                                         *
8928  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8929  *                                                                           *
8930  *  Permission is hereby granted for the reproduction of this software       *
8931  *  on condition that this copyright notice is included in source            *
8932  *  distributions of the software.  The code may be modified and             *
8933  *  distributed under the same terms as Perl itself.                         *
8934  *                                                                           *
8935  *  27-Aug-1994 Modified for inclusion in perl5                              *
8936  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8937  *****************************************************************************
8938  */
8939
8940 /*
8941  * getredirection() is intended to aid in porting C programs
8942  * to VMS (Vax-11 C).  The native VMS environment does not support
8943  * '>' and '<' I/O redirection, or command line wild card expansion,
8944  * or a command line pipe mechanism using the '|' AND background
8945  * command execution '&'.  All of these capabilities are provided to any
8946  * C program which calls this procedure as the first thing in the
8947  * main program.
8948  * The piping mechanism will probably work with almost any 'filter' type
8949  * of program.  With suitable modification, it may useful for other
8950  * portability problems as well.
8951  *
8952  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8953  */
8954 struct list_item
8955     {
8956     struct list_item *next;
8957     char *value;
8958     };
8959
8960 static void add_item(struct list_item **head,
8961                      struct list_item **tail,
8962                      char *value,
8963                      int *count);
8964
8965 static void mp_expand_wild_cards(pTHX_ char *item,
8966                                 struct list_item **head,
8967                                 struct list_item **tail,
8968                                 int *count);
8969
8970 static int background_process(pTHX_ int argc, char **argv);
8971
8972 static void pipe_and_fork(pTHX_ char **cmargv);
8973
8974 /*{{{ void getredirection(int *ac, char ***av)*/
8975 static void
8976 mp_getredirection(pTHX_ int *ac, char ***av)
8977 /*
8978  * Process vms redirection arg's.  Exit if any error is seen.
8979  * If getredirection() processes an argument, it is erased
8980  * from the vector.  getredirection() returns a new argc and argv value.
8981  * In the event that a background command is requested (by a trailing "&"),
8982  * this routine creates a background subprocess, and simply exits the program.
8983  *
8984  * Warning: do not try to simplify the code for vms.  The code
8985  * presupposes that getredirection() is called before any data is
8986  * read from stdin or written to stdout.
8987  *
8988  * Normal usage is as follows:
8989  *
8990  *      main(argc, argv)
8991  *      int             argc;
8992  *      char            *argv[];
8993  *      {
8994  *              getredirection(&argc, &argv);
8995  *      }
8996  */
8997 {
8998     int                 argc = *ac;     /* Argument Count         */
8999     char                **argv = *av;   /* Argument Vector        */
9000     char                *ap;            /* Argument pointer       */
9001     int                 j;              /* argv[] index           */
9002     int                 item_count = 0; /* Count of Items in List */
9003     struct list_item    *list_head = 0; /* First Item in List       */
9004     struct list_item    *list_tail;     /* Last Item in List        */
9005     char                *in = NULL;     /* Input File Name          */
9006     char                *out = NULL;    /* Output File Name         */
9007     char                *outmode = "w"; /* Mode to Open Output File */
9008     char                *err = NULL;    /* Error File Name          */
9009     char                *errmode = "w"; /* Mode to Open Error File  */
9010     int                 cmargc = 0;     /* Piped Command Arg Count  */
9011     char                **cmargv = NULL;/* Piped Command Arg Vector */
9012
9013     /*
9014      * First handle the case where the last thing on the line ends with
9015      * a '&'.  This indicates the desire for the command to be run in a
9016      * subprocess, so we satisfy that desire.
9017      */
9018     ap = argv[argc-1];
9019     if (0 == strcmp("&", ap))
9020        exit(background_process(aTHX_ --argc, argv));
9021     if (*ap && '&' == ap[strlen(ap)-1])
9022         {
9023         ap[strlen(ap)-1] = '\0';
9024        exit(background_process(aTHX_ argc, argv));
9025         }
9026     /*
9027      * Now we handle the general redirection cases that involve '>', '>>',
9028      * '<', and pipes '|'.
9029      */
9030     for (j = 0; j < argc; ++j)
9031         {
9032         if (0 == strcmp("<", argv[j]))
9033             {
9034             if (j+1 >= argc)
9035                 {
9036                 fprintf(stderr,"No input file after < on command line");
9037                 exit(LIB$_WRONUMARG);
9038                 }
9039             in = argv[++j];
9040             continue;
9041             }
9042         if ('<' == *(ap = argv[j]))
9043             {
9044             in = 1 + ap;
9045             continue;
9046             }
9047         if (0 == strcmp(">", ap))
9048             {
9049             if (j+1 >= argc)
9050                 {
9051                 fprintf(stderr,"No output file after > on command line");
9052                 exit(LIB$_WRONUMARG);
9053                 }
9054             out = argv[++j];
9055             continue;
9056             }
9057         if ('>' == *ap)
9058             {
9059             if ('>' == ap[1])
9060                 {
9061                 outmode = "a";
9062                 if ('\0' == ap[2])
9063                     out = argv[++j];
9064                 else
9065                     out = 2 + ap;
9066                 }
9067             else
9068                 out = 1 + ap;
9069             if (j >= argc)
9070                 {
9071                 fprintf(stderr,"No output file after > or >> on command line");
9072                 exit(LIB$_WRONUMARG);
9073                 }
9074             continue;
9075             }
9076         if (('2' == *ap) && ('>' == ap[1]))
9077             {
9078             if ('>' == ap[2])
9079                 {
9080                 errmode = "a";
9081                 if ('\0' == ap[3])
9082                     err = argv[++j];
9083                 else
9084                     err = 3 + ap;
9085                 }
9086             else
9087                 if ('\0' == ap[2])
9088                     err = argv[++j];
9089                 else
9090                     err = 2 + ap;
9091             if (j >= argc)
9092                 {
9093                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9094                 exit(LIB$_WRONUMARG);
9095                 }
9096             continue;
9097             }
9098         if (0 == strcmp("|", argv[j]))
9099             {
9100             if (j+1 >= argc)
9101                 {
9102                 fprintf(stderr,"No command into which to pipe on command line");
9103                 exit(LIB$_WRONUMARG);
9104                 }
9105             cmargc = argc-(j+1);
9106             cmargv = &argv[j+1];
9107             argc = j;
9108             continue;
9109             }
9110         if ('|' == *(ap = argv[j]))
9111             {
9112             ++argv[j];
9113             cmargc = argc-j;
9114             cmargv = &argv[j];
9115             argc = j;
9116             continue;
9117             }
9118         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9119         }
9120     /*
9121      * Allocate and fill in the new argument vector, Some Unix's terminate
9122      * the list with an extra null pointer.
9123      */
9124     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9125     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9126     *av = argv;
9127     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9128         argv[j] = list_head->value;
9129     *ac = item_count;
9130     if (cmargv != NULL)
9131         {
9132         if (out != NULL)
9133             {
9134             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9135             exit(LIB$_INVARGORD);
9136             }
9137         pipe_and_fork(aTHX_ cmargv);
9138         }
9139
9140     /* Check for input from a pipe (mailbox) */
9141
9142     if (in == NULL && 1 == isapipe(0))
9143         {
9144         char mbxname[L_tmpnam];
9145         long int bufsize;
9146         long int dvi_item = DVI$_DEVBUFSIZ;
9147         $DESCRIPTOR(mbxnam, "");
9148         $DESCRIPTOR(mbxdevnam, "");
9149
9150         /* Input from a pipe, reopen it in binary mode to disable       */
9151         /* carriage control processing.                                 */
9152
9153         fgetname(stdin, mbxname, 1);
9154         mbxnam.dsc$a_pointer = mbxname;
9155         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9156         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9157         mbxdevnam.dsc$a_pointer = mbxname;
9158         mbxdevnam.dsc$w_length = sizeof(mbxname);
9159         dvi_item = DVI$_DEVNAM;
9160         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9161         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9162         set_errno(0);
9163         set_vaxc_errno(1);
9164         freopen(mbxname, "rb", stdin);
9165         if (errno != 0)
9166             {
9167             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9168             exit(vaxc$errno);
9169             }
9170         }
9171     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9172         {
9173         fprintf(stderr,"Can't open input file %s as stdin",in);
9174         exit(vaxc$errno);
9175         }
9176     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9177         {
9178         fprintf(stderr,"Can't open output file %s as stdout",out);
9179         exit(vaxc$errno);
9180         }
9181         if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
9182
9183     if (err != NULL) {
9184         if (strcmp(err,"&1") == 0) {
9185             dup2(fileno(stdout), fileno(stderr));
9186             vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
9187         } else {
9188         FILE *tmperr;
9189         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9190             {
9191             fprintf(stderr,"Can't open error file %s as stderr",err);
9192             exit(vaxc$errno);
9193             }
9194             fclose(tmperr);
9195            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9196                 {
9197                 exit(vaxc$errno);
9198                 }
9199             vmssetuserlnm("SYS$ERROR", err);
9200         }
9201         }
9202 #ifdef ARGPROC_DEBUG
9203     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9204     for (j = 0; j < *ac;  ++j)
9205         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9206 #endif
9207    /* Clear errors we may have hit expanding wildcards, so they don't
9208       show up in Perl's $! later */
9209    set_errno(0); set_vaxc_errno(1);
9210 }  /* end of getredirection() */
9211 /*}}}*/
9212
9213 static void add_item(struct list_item **head,
9214                      struct list_item **tail,
9215                      char *value,
9216                      int *count)
9217 {
9218     if (*head == 0)
9219         {
9220         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9221         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9222         *tail = *head;
9223         }
9224     else {
9225         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9226         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9227         *tail = (*tail)->next;
9228         }
9229     (*tail)->value = value;
9230     ++(*count);
9231 }
9232
9233 static void mp_expand_wild_cards(pTHX_ char *item,
9234                               struct list_item **head,
9235                               struct list_item **tail,
9236                               int *count)
9237 {
9238 int expcount = 0;
9239 unsigned long int context = 0;
9240 int isunix = 0;
9241 int item_len = 0;
9242 char *had_version;
9243 char *had_device;
9244 int had_directory;
9245 char *devdir,*cp;
9246 char *vmsspec;
9247 $DESCRIPTOR(filespec, "");
9248 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9249 $DESCRIPTOR(resultspec, "");
9250 unsigned long int lff_flags = 0;
9251 int sts;
9252 int rms_sts;
9253
9254 #ifdef VMS_LONGNAME_SUPPORT
9255     lff_flags = LIB$M_FIL_LONG_NAMES;
9256 #endif
9257
9258     for (cp = item; *cp; cp++) {
9259         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9260         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9261     }
9262     if (!*cp || isspace(*cp))
9263         {
9264         add_item(head, tail, item, count);
9265         return;
9266         }
9267     else
9268         {
9269      /* "double quoted" wild card expressions pass as is */
9270      /* From DCL that means using e.g.:                  */
9271      /* perl program """perl.*"""                        */
9272      item_len = strlen(item);
9273      if ( '"' == *item && '"' == item[item_len-1] )
9274        {
9275        item++;
9276        item[item_len-2] = '\0';
9277        add_item(head, tail, item, count);
9278        return;
9279        }
9280      }
9281     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9282     resultspec.dsc$b_class = DSC$K_CLASS_D;
9283     resultspec.dsc$a_pointer = NULL;
9284     vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9285     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9286     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9287       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9288     if (!isunix || !filespec.dsc$a_pointer)
9289       filespec.dsc$a_pointer = item;
9290     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9291     /*
9292      * Only return version specs, if the caller specified a version
9293      */
9294     had_version = strchr(item, ';');
9295     /*
9296      * Only return device and directory specs, if the caller specified either.
9297      */
9298     had_device = strchr(item, ':');
9299     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9300
9301     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9302                                  (&filespec, &resultspec, &context,
9303                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9304         {
9305         char *string;
9306         char *c;
9307
9308         string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9309         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9310         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9311         if (NULL == had_version)
9312             *(strrchr(string, ';')) = '\0';
9313         if ((!had_directory) && (had_device == NULL))
9314             {
9315             if (NULL == (devdir = strrchr(string, ']')))
9316                 devdir = strrchr(string, '>');
9317             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9318             }
9319         /*
9320          * Be consistent with what the C RTL has already done to the rest of
9321          * the argv items and lowercase all of these names.
9322          */
9323         if (!decc_efs_case_preserve) {
9324             for (c = string; *c; ++c)
9325             if (isupper(*c))
9326                 *c = tolower(*c);
9327         }
9328         if (isunix) trim_unixpath(string,item,1);
9329         add_item(head, tail, string, count);
9330         ++expcount;
9331     }
9332     PerlMem_free(vmsspec);
9333     if (sts != RMS$_NMF)
9334         {
9335         set_vaxc_errno(sts);
9336         switch (sts)
9337             {
9338             case RMS$_FNF: case RMS$_DNF:
9339                 set_errno(ENOENT); break;
9340             case RMS$_DIR:
9341                 set_errno(ENOTDIR); break;
9342             case RMS$_DEV:
9343                 set_errno(ENODEV); break;
9344             case RMS$_FNM: case RMS$_SYN:
9345                 set_errno(EINVAL); break;
9346             case RMS$_PRV:
9347                 set_errno(EACCES); break;
9348             default:
9349                 _ckvmssts_noperl(sts);
9350             }
9351         }
9352     if (expcount == 0)
9353         add_item(head, tail, item, count);
9354     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9355     _ckvmssts_noperl(lib$find_file_end(&context));
9356 }
9357
9358 static int child_st[2];/* Event Flag set when child process completes   */
9359
9360 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9361
9362 static unsigned long int exit_handler(void)
9363 {
9364 short iosb[4];
9365
9366     if (0 == child_st[0])
9367         {
9368 #ifdef ARGPROC_DEBUG
9369         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9370 #endif
9371         fflush(stdout);     /* Have to flush pipe for binary data to    */
9372                             /* terminate properly -- <tp@mccall.com>    */
9373         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9374         sys$dassgn(child_chan);
9375         fclose(stdout);
9376         sys$synch(0, child_st);
9377         }
9378     return(1);
9379 }
9380
9381 static void sig_child(int chan)
9382 {
9383 #ifdef ARGPROC_DEBUG
9384     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9385 #endif
9386     if (child_st[0] == 0)
9387         child_st[0] = 1;
9388 }
9389
9390 static struct exit_control_block exit_block =
9391     {
9392     0,
9393     exit_handler,
9394     1,
9395     &exit_block.exit_status,
9396     0
9397     };
9398
9399 static void
9400 pipe_and_fork(pTHX_ char **cmargv)
9401 {
9402     PerlIO *fp;
9403     struct dsc$descriptor_s *vmscmd;
9404     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9405     int sts, j, l, ismcr, quote, tquote = 0;
9406
9407     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9408     vms_execfree(vmscmd);
9409
9410     j = l = 0;
9411     p = subcmd;
9412     q = cmargv[0];
9413     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9414               && toupper(*(q+2)) == 'R' && !*(q+3);
9415
9416     while (q && l < MAX_DCL_LINE_LENGTH) {
9417         if (!*q) {
9418             if (j > 0 && quote) {
9419                 *p++ = '"';
9420                 l++;
9421             }
9422             q = cmargv[++j];
9423             if (q) {
9424                 if (ismcr && j > 1) quote = 1;
9425                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9426                 *p++ = ' ';
9427                 l++;
9428                 if (quote || tquote) {
9429                     *p++ = '"';
9430                     l++;
9431                 }
9432             }
9433         } else {
9434             if ((quote||tquote) && *q == '"') {
9435                 *p++ = '"';
9436                 l++;
9437             }
9438             *p++ = *q++;
9439             l++;
9440         }
9441     }
9442     *p = '\0';
9443
9444     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9445     if (fp == NULL) {
9446         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9447     }
9448 }
9449
9450 static int background_process(pTHX_ int argc, char **argv)
9451 {
9452 char command[MAX_DCL_SYMBOL + 1] = "$";
9453 $DESCRIPTOR(value, "");
9454 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9455 static $DESCRIPTOR(null, "NLA0:");
9456 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9457 char pidstring[80];
9458 $DESCRIPTOR(pidstr, "");
9459 int pid;
9460 unsigned long int flags = 17, one = 1, retsts;
9461 int len;
9462
9463     len = my_strlcat(command, argv[0], sizeof(command));
9464     while (--argc && (len < MAX_DCL_SYMBOL))
9465         {
9466         my_strlcat(command, " \"", sizeof(command));
9467         my_strlcat(command, *(++argv), sizeof(command));
9468         len = my_strlcat(command, "\"", sizeof(command));
9469         }
9470     value.dsc$a_pointer = command;
9471     value.dsc$w_length = strlen(value.dsc$a_pointer);
9472     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9473     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9474     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9475         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9476     }
9477     else {
9478         _ckvmssts_noperl(retsts);
9479     }
9480 #ifdef ARGPROC_DEBUG
9481     PerlIO_printf(Perl_debug_log, "%s\n", command);
9482 #endif
9483     sprintf(pidstring, "%08X", pid);
9484     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9485     pidstr.dsc$a_pointer = pidstring;
9486     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9487     lib$set_symbol(&pidsymbol, &pidstr);
9488     return(SS$_NORMAL);
9489 }
9490 /*}}}*/
9491 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9492
9493
9494 /* OS-specific initialization at image activation (not thread startup) */
9495 /* Older VAXC header files lack these constants */
9496 #ifndef JPI$_RIGHTS_SIZE
9497 #  define JPI$_RIGHTS_SIZE 817
9498 #endif
9499 #ifndef KGB$M_SUBSYSTEM
9500 #  define KGB$M_SUBSYSTEM 0x8
9501 #endif
9502
9503 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9504
9505 /*{{{void vms_image_init(int *, char ***)*/
9506 void
9507 vms_image_init(int *argcp, char ***argvp)
9508 {
9509   int status;
9510   char eqv[LNM$C_NAMLENGTH+1] = "";
9511   unsigned int len, tabct = 8, tabidx = 0;
9512   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9513   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9514   unsigned short int dummy, rlen;
9515   struct dsc$descriptor_s **tabvec;
9516 #if defined(PERL_IMPLICIT_CONTEXT)
9517   pTHX = NULL;
9518 #endif
9519   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9520                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9521                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9522                                  {          0,                0,    0,      0} };
9523
9524 #ifdef KILL_BY_SIGPRC
9525     Perl_csighandler_init();
9526 #endif
9527
9528 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9529     /* This was moved from the pre-image init handler because on threaded */
9530     /* Perl it was always returning 0 for the default value. */
9531     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9532     if (status > 0) {
9533         int s;
9534         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9535         if (s > 0) {
9536             int initial;
9537             initial = decc$feature_get_value(s, 4);
9538             if (initial > 0) {
9539                 /* initial is: 0 if nothing has set the feature */
9540                 /*            -1 if initialized to default */
9541                 /*             1 if set by logical name */
9542                 /*             2 if set by decc$feature_set_value */
9543                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9544
9545                 /* If the value is not valid, force the feature off */
9546                 if (decc_disable_posix_root < 0) {
9547                     decc$feature_set_value(s, 1, 1);
9548                     decc_disable_posix_root = 1;
9549                 }
9550             }
9551             else {
9552                 /* Nothing has asked for it explicitly, so use our own default. */
9553                 decc_disable_posix_root = 1;
9554                 decc$feature_set_value(s, 1, 1);
9555             }
9556         }
9557     }
9558 #endif
9559
9560   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9561   _ckvmssts_noperl(iosb[0]);
9562   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9563     if (iprv[i]) {           /* Running image installed with privs? */
9564       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9565       will_taint = TRUE;
9566       break;
9567     }
9568   }
9569   /* Rights identifiers might trigger tainting as well. */
9570   if (!will_taint && (rlen || rsz)) {
9571     while (rlen < rsz) {
9572       /* We didn't get all the identifiers on the first pass.  Allocate a
9573        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9574        * were needed to hold all identifiers at time of last call; we'll
9575        * allocate that many unsigned long ints), and go back and get 'em.
9576        * If it gave us less than it wanted to despite ample buffer space,
9577        * something's broken.  Is your system missing a system identifier?
9578        */
9579       if (rsz <= jpilist[1].buflen) {
9580          /* Perl_croak accvios when used this early in startup. */
9581          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9582                          rsz, (unsigned long) jpilist[1].buflen,
9583                          "Check your rights database for corruption.\n");
9584          exit(SS$_ABORT);
9585       }
9586       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9587       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9588       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9589       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9590       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9591       _ckvmssts_noperl(iosb[0]);
9592     }
9593     mask = (unsigned long int *)jpilist[1].bufadr;
9594     /* Check attribute flags for each identifier (2nd longword); protected
9595      * subsystem identifiers trigger tainting.
9596      */
9597     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9598       if (mask[i] & KGB$M_SUBSYSTEM) {
9599         will_taint = TRUE;
9600         break;
9601       }
9602     }
9603     if (mask != rlst) PerlMem_free(mask);
9604   }
9605
9606   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9607    * logical, some versions of the CRTL will add a phanthom /000000/
9608    * directory.  This needs to be removed.
9609    */
9610   if (decc_filename_unix_report) {
9611   char * zeros;
9612   int ulen;
9613     ulen = strlen(argvp[0][0]);
9614     if (ulen > 7) {
9615       zeros = strstr(argvp[0][0], "/000000/");
9616       if (zeros != NULL) {
9617         int mlen;
9618         mlen = ulen - (zeros - argvp[0][0]) - 7;
9619         memmove(zeros, &zeros[7], mlen);
9620         ulen = ulen - 7;
9621         argvp[0][0][ulen] = '\0';
9622       }
9623     }
9624     /* It also may have a trailing dot that needs to be removed otherwise
9625      * it will be converted to VMS mode incorrectly.
9626      */
9627     ulen--;
9628     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9629       argvp[0][0][ulen] = '\0';
9630   }
9631
9632   /* We need to use this hack to tell Perl it should run with tainting,
9633    * since its tainting flag may be part of the PL_curinterp struct, which
9634    * hasn't been allocated when vms_image_init() is called.
9635    */
9636   if (will_taint) {
9637     char **newargv, **oldargv;
9638     oldargv = *argvp;
9639     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9640     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9641     newargv[0] = oldargv[0];
9642     newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9643     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9644     strcpy(newargv[1], "-T");
9645     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9646     (*argcp)++;
9647     newargv[*argcp] = NULL;
9648     /* We orphan the old argv, since we don't know where it's come from,
9649      * so we don't know how to free it.
9650      */
9651     *argvp = newargv;
9652   }
9653   else {  /* Did user explicitly request tainting? */
9654     int i;
9655     char *cp, **av = *argvp;
9656     for (i = 1; i < *argcp; i++) {
9657       if (*av[i] != '-') break;
9658       for (cp = av[i]+1; *cp; cp++) {
9659         if (*cp == 'T') { will_taint = 1; break; }
9660         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9661                   strchr("DFIiMmx",*cp)) break;
9662       }
9663       if (will_taint) break;
9664     }
9665   }
9666
9667   for (tabidx = 0;
9668        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9669        tabidx++) {
9670     if (!tabidx) {
9671       tabvec = (struct dsc$descriptor_s **)
9672             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9673       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9674     }
9675     else if (tabidx >= tabct) {
9676       tabct += 8;
9677       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9678       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9679     }
9680     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9681     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9682     tabvec[tabidx]->dsc$w_length  = len;
9683     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9684     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_S;
9685     tabvec[tabidx]->dsc$a_pointer = PerlMem_malloc(len + 1);
9686     if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9687     my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
9688   }
9689   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9690
9691   getredirection(argcp,argvp);
9692 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9693   {
9694 # include <reentrancy.h>
9695   decc$set_reentrancy(C$C_MULTITHREAD);
9696   }
9697 #endif
9698   return;
9699 }
9700 /*}}}*/
9701
9702
9703 /* trim_unixpath()
9704  * Trim Unix-style prefix off filespec, so it looks like what a shell
9705  * glob expansion would return (i.e. from specified prefix on, not
9706  * full path).  Note that returned filespec is Unix-style, regardless
9707  * of whether input filespec was VMS-style or Unix-style.
9708  *
9709  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9710  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9711  * vector of options; at present, only bit 0 is used, and if set tells
9712  * trim unixpath to try the current default directory as a prefix when
9713  * presented with a possibly ambiguous ... wildcard.
9714  *
9715  * Returns !=0 on success, with trimmed filespec replacing contents of
9716  * fspec, and 0 on failure, with contents of fpsec unchanged.
9717  */
9718 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9719 int
9720 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9721 {
9722   char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9723   int tmplen, reslen = 0, dirs = 0;
9724
9725   if (!wildspec || !fspec) return 0;
9726
9727   unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9728   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9729   tplate = unixwild;
9730   if (strpbrk(wildspec,"]>:") != NULL) {
9731     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9732         PerlMem_free(unixwild);
9733         return 0;
9734     }
9735   }
9736   else {
9737     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9738   }
9739   unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9740   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9741   if (strpbrk(fspec,"]>:") != NULL) {
9742     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9743         PerlMem_free(unixwild);
9744         PerlMem_free(unixified);
9745         return 0;
9746     }
9747     else base = unixified;
9748     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9749      * check to see that final result fits into (isn't longer than) fspec */
9750     reslen = strlen(fspec);
9751   }
9752   else base = fspec;
9753
9754   /* No prefix or absolute path on wildcard, so nothing to remove */
9755   if (!*tplate || *tplate == '/') {
9756     PerlMem_free(unixwild);
9757     if (base == fspec) {
9758         PerlMem_free(unixified);
9759         return 1;
9760     }
9761     tmplen = strlen(unixified);
9762     if (tmplen > reslen) {
9763         PerlMem_free(unixified);
9764         return 0;  /* not enough space */
9765     }
9766     /* Copy unixified resultant, including trailing NUL */
9767     memmove(fspec,unixified,tmplen+1);
9768     PerlMem_free(unixified);
9769     return 1;
9770   }
9771
9772   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9773   if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9774     for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9775     for (cp1 = end ;cp1 >= base; cp1--)
9776       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9777         { cp1++; break; }
9778     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9779     PerlMem_free(unixified);
9780     PerlMem_free(unixwild);
9781     return 1;
9782   }
9783   else {
9784     char *tpl, *lcres;
9785     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9786     int ells = 1, totells, segdirs, match;
9787     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9788                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9789
9790     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9791     totells = ells;
9792     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9793     tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9794     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9795     if (ellipsis == tplate && opts & 1) {
9796       /* Template begins with an ellipsis.  Since we can't tell how many
9797        * directory names at the front of the resultant to keep for an
9798        * arbitrary starting point, we arbitrarily choose the current
9799        * default directory as a starting point.  If it's there as a prefix,
9800        * clip it off.  If not, fall through and act as if the leading
9801        * ellipsis weren't there (i.e. return shortest possible path that
9802        * could match template).
9803        */
9804       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9805           PerlMem_free(tpl);
9806           PerlMem_free(unixified);
9807           PerlMem_free(unixwild);
9808           return 0;
9809       }
9810       if (!decc_efs_case_preserve) {
9811         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9812           if (_tolower(*cp1) != _tolower(*cp2)) break;
9813       }
9814       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9815       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9816       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9817         memmove(fspec,cp2+1,end - cp2);
9818         PerlMem_free(tpl);
9819         PerlMem_free(unixified);
9820         PerlMem_free(unixwild);
9821         return 1;
9822       }
9823     }
9824     /* First off, back up over constant elements at end of path */
9825     if (dirs) {
9826       for (front = end ; front >= base; front--)
9827          if (*front == '/' && !dirs--) { front++; break; }
9828     }
9829     lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9830     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9831     for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9832          cp1++,cp2++) {
9833             if (!decc_efs_case_preserve) {
9834                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9835             }
9836             else {
9837                 *cp2 = *cp1;
9838             }
9839     }
9840     if (cp1 != '\0') {
9841         PerlMem_free(tpl);
9842         PerlMem_free(unixified);
9843         PerlMem_free(unixwild);
9844         PerlMem_free(lcres);
9845         return 0;  /* Path too long. */
9846     }
9847     lcend = cp2;
9848     *cp2 = '\0';  /* Pick up with memcpy later */
9849     lcfront = lcres + (front - base);
9850     /* Now skip over each ellipsis and try to match the path in front of it. */
9851     while (ells--) {
9852       for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9853         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9854             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9855       if (cp1 < tplate) break; /* template started with an ellipsis */
9856       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9857         ellipsis = cp1; continue;
9858       }
9859       wilddsc.dsc$a_pointer = tpl;
9860       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9861       nextell = cp1;
9862       for (segdirs = 0, cp2 = tpl;
9863            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9864            cp1++, cp2++) {
9865          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9866          else {
9867             if (!decc_efs_case_preserve) {
9868               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9869             }
9870             else {
9871               *cp2 = *cp1;  /* else preserve case for match */
9872             }
9873          }
9874          if (*cp2 == '/') segdirs++;
9875       }
9876       if (cp1 != ellipsis - 1) {
9877           PerlMem_free(tpl);
9878           PerlMem_free(unixified);
9879           PerlMem_free(unixwild);
9880           PerlMem_free(lcres);
9881           return 0; /* Path too long */
9882       }
9883       /* Back up at least as many dirs as in template before matching */
9884       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9885         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9886       for (match = 0; cp1 > lcres;) {
9887         resdsc.dsc$a_pointer = cp1;
9888         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9889           match++;
9890           if (match == 1) lcfront = cp1;
9891         }
9892         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9893       }
9894       if (!match) {
9895         PerlMem_free(tpl);
9896         PerlMem_free(unixified);
9897         PerlMem_free(unixwild);
9898         PerlMem_free(lcres);
9899         return 0;  /* Can't find prefix ??? */
9900       }
9901       if (match > 1 && opts & 1) {
9902         /* This ... wildcard could cover more than one set of dirs (i.e.
9903          * a set of similar dir names is repeated).  If the template
9904          * contains more than 1 ..., upstream elements could resolve the
9905          * ambiguity, but it's not worth a full backtracking setup here.
9906          * As a quick heuristic, clip off the current default directory
9907          * if it's present to find the trimmed spec, else use the
9908          * shortest string that this ... could cover.
9909          */
9910         char def[NAM$C_MAXRSS+1], *st;
9911
9912         if (getcwd(def, sizeof def,0) == NULL) {
9913             PerlMem_free(unixified);
9914             PerlMem_free(unixwild);
9915             PerlMem_free(lcres);
9916             PerlMem_free(tpl);
9917             return 0;
9918         }
9919         if (!decc_efs_case_preserve) {
9920           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9921             if (_tolower(*cp1) != _tolower(*cp2)) break;
9922         }
9923         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9924         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9925         if (*cp1 == '\0' && *cp2 == '/') {
9926           memmove(fspec,cp2+1,end - cp2);
9927           PerlMem_free(tpl);
9928           PerlMem_free(unixified);
9929           PerlMem_free(unixwild);
9930           PerlMem_free(lcres);
9931           return 1;
9932         }
9933         /* Nope -- stick with lcfront from above and keep going. */
9934       }
9935     }
9936     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9937     PerlMem_free(tpl);
9938     PerlMem_free(unixified);
9939     PerlMem_free(unixwild);
9940     PerlMem_free(lcres);
9941     return 1;
9942   }
9943
9944 }  /* end of trim_unixpath() */
9945 /*}}}*/
9946
9947
9948 /*
9949  *  VMS readdir() routines.
9950  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9951  *
9952  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9953  *  Minor modifications to original routines.
9954  */
9955
9956 /* readdir may have been redefined by reentr.h, so make sure we get
9957  * the local version for what we do here.
9958  */
9959 #ifdef readdir
9960 # undef readdir
9961 #endif
9962 #if !defined(PERL_IMPLICIT_CONTEXT)
9963 # define readdir Perl_readdir
9964 #else
9965 # define readdir(a) Perl_readdir(aTHX_ a)
9966 #endif
9967
9968     /* Number of elements in vms_versions array */
9969 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9970
9971 /*
9972  *  Open a directory, return a handle for later use.
9973  */
9974 /*{{{ DIR *opendir(char*name) */
9975 DIR *
9976 Perl_opendir(pTHX_ const char *name)
9977 {
9978     DIR *dd;
9979     char *dir;
9980     Stat_t sb;
9981
9982     Newx(dir, VMS_MAXRSS, char);
9983     if (int_tovmspath(name, dir, NULL) == NULL) {
9984       Safefree(dir);
9985       return NULL;
9986     }
9987     /* Check access before stat; otherwise stat does not
9988      * accurately report whether it's a directory.
9989      */
9990     if (!strstr(dir, "::") /* sys$check_access doesn't do remotes */
9991         && !cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9992       /* cando_by_name has already set errno */
9993       Safefree(dir);
9994       return NULL;
9995     }
9996     if (flex_stat(dir,&sb) == -1) return NULL;
9997     if (!S_ISDIR(sb.st_mode)) {
9998       Safefree(dir);
9999       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10000       return NULL;
10001     }
10002     /* Get memory for the handle, and the pattern. */
10003     Newx(dd,1,DIR);
10004     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10005
10006     /* Fill in the fields; mainly playing with the descriptor. */
10007     sprintf(dd->pattern, "%s*.*",dir);
10008     Safefree(dir);
10009     dd->context = 0;
10010     dd->count = 0;
10011     dd->flags = 0;
10012     /* By saying we want the result of readdir() in unix format, we are really
10013      * saying we want all the escapes removed, translating characters that
10014      * must be escaped in a VMS-format name to their unescaped form, which is
10015      * presumably allowed in a Unix-format name.
10016      */
10017     dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
10018     dd->pat.dsc$a_pointer = dd->pattern;
10019     dd->pat.dsc$w_length = strlen(dd->pattern);
10020     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10021     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10022 #if defined(USE_ITHREADS)
10023     Newx(dd->mutex,1,perl_mutex);
10024     MUTEX_INIT( (perl_mutex *) dd->mutex );
10025 #else
10026     dd->mutex = NULL;
10027 #endif
10028
10029     return dd;
10030 }  /* end of opendir() */
10031 /*}}}*/
10032
10033 /*
10034  *  Set the flag to indicate we want versions or not.
10035  */
10036 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10037 void
10038 vmsreaddirversions(DIR *dd, int flag)
10039 {
10040     if (flag)
10041         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10042     else
10043         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10044 }
10045 /*}}}*/
10046
10047 /*
10048  *  Free up an opened directory.
10049  */
10050 /*{{{ void closedir(DIR *dd)*/
10051 void
10052 Perl_closedir(DIR *dd)
10053 {
10054     int sts;
10055
10056     sts = lib$find_file_end(&dd->context);
10057     Safefree(dd->pattern);
10058 #if defined(USE_ITHREADS)
10059     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10060     Safefree(dd->mutex);
10061 #endif
10062     Safefree(dd);
10063 }
10064 /*}}}*/
10065
10066 /*
10067  *  Collect all the version numbers for the current file.
10068  */
10069 static void
10070 collectversions(pTHX_ DIR *dd)
10071 {
10072     struct dsc$descriptor_s     pat;
10073     struct dsc$descriptor_s     res;
10074     struct dirent *e;
10075     char *p, *text, *buff;
10076     int i;
10077     unsigned long context, tmpsts;
10078
10079     /* Convenient shorthand. */
10080     e = &dd->entry;
10081
10082     /* Add the version wildcard, ignoring the "*.*" put on before */
10083     i = strlen(dd->pattern);
10084     Newx(text,i + e->d_namlen + 3,char);
10085     my_strlcpy(text, dd->pattern, i + 1);
10086     sprintf(&text[i - 3], "%s;*", e->d_name);
10087
10088     /* Set up the pattern descriptor. */
10089     pat.dsc$a_pointer = text;
10090     pat.dsc$w_length = i + e->d_namlen - 1;
10091     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10092     pat.dsc$b_class = DSC$K_CLASS_S;
10093
10094     /* Set up result descriptor. */
10095     Newx(buff, VMS_MAXRSS, char);
10096     res.dsc$a_pointer = buff;
10097     res.dsc$w_length = VMS_MAXRSS - 1;
10098     res.dsc$b_dtype = DSC$K_DTYPE_T;
10099     res.dsc$b_class = DSC$K_CLASS_S;
10100
10101     /* Read files, collecting versions. */
10102     for (context = 0, e->vms_verscount = 0;
10103          e->vms_verscount < VERSIZE(e);
10104          e->vms_verscount++) {
10105         unsigned long rsts;
10106         unsigned long flags = 0;
10107
10108 #ifdef VMS_LONGNAME_SUPPORT
10109         flags = LIB$M_FIL_LONG_NAMES;
10110 #endif
10111         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10112         if (tmpsts == RMS$_NMF || context == 0) break;
10113         _ckvmssts(tmpsts);
10114         buff[VMS_MAXRSS - 1] = '\0';
10115         if ((p = strchr(buff, ';')))
10116             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10117         else
10118             e->vms_versions[e->vms_verscount] = -1;
10119     }
10120
10121     _ckvmssts(lib$find_file_end(&context));
10122     Safefree(text);
10123     Safefree(buff);
10124
10125 }  /* end of collectversions() */
10126
10127 /*
10128  *  Read the next entry from the directory.
10129  */
10130 /*{{{ struct dirent *readdir(DIR *dd)*/
10131 struct dirent *
10132 Perl_readdir(pTHX_ DIR *dd)
10133 {
10134     struct dsc$descriptor_s     res;
10135     char *p, *buff;
10136     unsigned long int tmpsts;
10137     unsigned long rsts;
10138     unsigned long flags = 0;
10139     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10140     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10141
10142     /* Set up result descriptor, and get next file. */
10143     Newx(buff, VMS_MAXRSS, char);
10144     res.dsc$a_pointer = buff;
10145     res.dsc$w_length = VMS_MAXRSS - 1;
10146     res.dsc$b_dtype = DSC$K_DTYPE_T;
10147     res.dsc$b_class = DSC$K_CLASS_S;
10148
10149 #ifdef VMS_LONGNAME_SUPPORT
10150     flags = LIB$M_FIL_LONG_NAMES;
10151 #endif
10152
10153     tmpsts = lib$find_file
10154         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10155     if (dd->context == 0)
10156         tmpsts = RMS$_NMF;  /* None left. (should be set, but make sure) */
10157
10158     if (!(tmpsts & 1)) {
10159       switch (tmpsts) {
10160         case RMS$_NMF:
10161           break;  /* no more files considered success */
10162         case RMS$_PRV:
10163           SETERRNO(EACCES, tmpsts); break;
10164         case RMS$_DEV:
10165           SETERRNO(ENODEV, tmpsts); break;
10166         case RMS$_DIR:
10167           SETERRNO(ENOTDIR, tmpsts); break;
10168         case RMS$_FNF: case RMS$_DNF:
10169           SETERRNO(ENOENT, tmpsts); break;
10170         default:
10171           SETERRNO(EVMSERR, tmpsts);
10172       }
10173       Safefree(buff);
10174       return NULL;
10175     }
10176     dd->count++;
10177     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10178     buff[res.dsc$w_length] = '\0';
10179     p = buff + res.dsc$w_length;
10180     while (--p >= buff) if (!isspace(*p)) break;
10181     *p = '\0';
10182     if (!decc_efs_case_preserve) {
10183       for (p = buff; *p; p++) *p = _tolower(*p);
10184     }
10185
10186     /* Skip any directory component and just copy the name. */
10187     sts = vms_split_path
10188        (buff,
10189         &v_spec,
10190         &v_len,
10191         &r_spec,
10192         &r_len,
10193         &d_spec,
10194         &d_len,
10195         &n_spec,
10196         &n_len,
10197         &e_spec,
10198         &e_len,
10199         &vs_spec,
10200         &vs_len);
10201
10202     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10203
10204         /* In Unix report mode, remove the ".dir;1" from the name */
10205         /* if it is a real directory. */
10206         if (decc_filename_unix_report && decc_efs_charset) {
10207             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10208                 Stat_t statbuf;
10209                 int ret_sts;
10210
10211                 ret_sts = flex_lstat(buff, &statbuf);
10212                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10213                     e_len = 0;
10214                     e_spec[0] = 0;
10215                 }
10216             }
10217         }
10218
10219         /* Drop NULL extensions on UNIX file specification */
10220         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10221             e_len = 0;
10222             e_spec[0] = '\0';
10223         }
10224     }
10225
10226     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10227     dd->entry.d_name[n_len + e_len] = '\0';
10228     dd->entry.d_namlen = n_len + e_len;
10229
10230     /* Convert the filename to UNIX format if needed */
10231     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10232
10233         /* Translate the encoded characters. */
10234         /* Fixme: Unicode handling could result in embedded 0 characters */
10235         if (strchr(dd->entry.d_name, '^') != NULL) {
10236             char new_name[256];
10237             char * q;
10238             p = dd->entry.d_name;
10239             q = new_name;
10240             while (*p != 0) {
10241                 int inchars_read, outchars_added;
10242                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10243                 p += inchars_read;
10244                 q += outchars_added;
10245                 /* fix-me */
10246                 /* if outchars_added > 1, then this is a wide file specification */
10247                 /* Wide file specifications need to be passed in Perl */
10248                 /* counted strings apparently with a Unicode flag */
10249             }
10250             *q = 0;
10251             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10252         }
10253     }
10254
10255     dd->entry.vms_verscount = 0;
10256     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10257     Safefree(buff);
10258     return &dd->entry;
10259
10260 }  /* end of readdir() */
10261 /*}}}*/
10262
10263 /*
10264  *  Read the next entry from the directory -- thread-safe version.
10265  */
10266 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10267 int
10268 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10269 {
10270     int retval;
10271
10272     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10273
10274     entry = readdir(dd);
10275     *result = entry;
10276     retval = ( *result == NULL ? errno : 0 );
10277
10278     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10279
10280     return retval;
10281
10282 }  /* end of readdir_r() */
10283 /*}}}*/
10284
10285 /*
10286  *  Return something that can be used in a seekdir later.
10287  */
10288 /*{{{ long telldir(DIR *dd)*/
10289 long
10290 Perl_telldir(DIR *dd)
10291 {
10292     return dd->count;
10293 }
10294 /*}}}*/
10295
10296 /*
10297  *  Return to a spot where we used to be.  Brute force.
10298  */
10299 /*{{{ void seekdir(DIR *dd,long count)*/
10300 void
10301 Perl_seekdir(pTHX_ DIR *dd, long count)
10302 {
10303     int old_flags;
10304
10305     /* If we haven't done anything yet... */
10306     if (dd->count == 0)
10307         return;
10308
10309     /* Remember some state, and clear it. */
10310     old_flags = dd->flags;
10311     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10312     _ckvmssts(lib$find_file_end(&dd->context));
10313     dd->context = 0;
10314
10315     /* The increment is in readdir(). */
10316     for (dd->count = 0; dd->count < count; )
10317         readdir(dd);
10318
10319     dd->flags = old_flags;
10320
10321 }  /* end of seekdir() */
10322 /*}}}*/
10323
10324 /* VMS subprocess management
10325  *
10326  * my_vfork() - just a vfork(), after setting a flag to record that
10327  * the current script is trying a Unix-style fork/exec.
10328  *
10329  * vms_do_aexec() and vms_do_exec() are called in response to the
10330  * perl 'exec' function.  If this follows a vfork call, then they
10331  * call out the regular perl routines in doio.c which do an
10332  * execvp (for those who really want to try this under VMS).
10333  * Otherwise, they do exactly what the perl docs say exec should
10334  * do - terminate the current script and invoke a new command
10335  * (See below for notes on command syntax.)
10336  *
10337  * do_aspawn() and do_spawn() implement the VMS side of the perl
10338  * 'system' function.
10339  *
10340  * Note on command arguments to perl 'exec' and 'system': When handled
10341  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10342  * are concatenated to form a DCL command string.  If the first non-numeric
10343  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10344  * the command string is handed off to DCL directly.  Otherwise,
10345  * the first token of the command is taken as the filespec of an image
10346  * to run.  The filespec is expanded using a default type of '.EXE' and
10347  * the process defaults for device, directory, etc., and if found, the resultant
10348  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10349  * the command string as parameters.  This is perhaps a bit complicated,
10350  * but I hope it will form a happy medium between what VMS folks expect
10351  * from lib$spawn and what Unix folks expect from exec.
10352  */
10353
10354 static int vfork_called;
10355
10356 /*{{{int my_vfork(void)*/
10357 int
10358 my_vfork(void)
10359 {
10360   vfork_called++;
10361   return vfork();
10362 }
10363 /*}}}*/
10364
10365
10366 static void
10367 vms_execfree(struct dsc$descriptor_s *vmscmd)
10368 {
10369   if (vmscmd) {
10370       if (vmscmd->dsc$a_pointer) {
10371           PerlMem_free(vmscmd->dsc$a_pointer);
10372       }
10373       PerlMem_free(vmscmd);
10374   }
10375 }
10376
10377 static char *
10378 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10379 {
10380   char *junk, *tmps = NULL;
10381   size_t cmdlen = 0;
10382   size_t rlen;
10383   SV **idx;
10384   STRLEN n_a;
10385
10386   idx = mark;
10387   if (really) {
10388     tmps = SvPV(really,rlen);
10389     if (*tmps) {
10390       cmdlen += rlen + 1;
10391       idx++;
10392     }
10393   }
10394
10395   for (idx++; idx <= sp; idx++) {
10396     if (*idx) {
10397       junk = SvPVx(*idx,rlen);
10398       cmdlen += rlen ? rlen + 1 : 0;
10399     }
10400   }
10401   Newx(PL_Cmd, cmdlen+1, char);
10402
10403   if (tmps && *tmps) {
10404     my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10405     mark++;
10406   }
10407   else *PL_Cmd = '\0';
10408   while (++mark <= sp) {
10409     if (*mark) {
10410       char *s = SvPVx(*mark,n_a);
10411       if (!*s) continue;
10412       if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10413       my_strlcat(PL_Cmd, s, cmdlen+1);
10414     }
10415   }
10416   return PL_Cmd;
10417
10418 }  /* end of setup_argstr() */
10419
10420
10421 static unsigned long int
10422 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10423                    struct dsc$descriptor_s **pvmscmd)
10424 {
10425   char * vmsspec;
10426   char * resspec;
10427   char image_name[NAM$C_MAXRSS+1];
10428   char image_argv[NAM$C_MAXRSS+1];
10429   $DESCRIPTOR(defdsc,".EXE");
10430   $DESCRIPTOR(defdsc2,".");
10431   struct dsc$descriptor_s resdsc;
10432   struct dsc$descriptor_s *vmscmd;
10433   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10434   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10435   char *s, *rest, *cp, *wordbreak;
10436   char * cmd;
10437   int cmdlen;
10438   int isdcl;
10439
10440   vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10441   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10442
10443   /* vmsspec is a DCL command buffer, not just a filename */
10444   vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10445   if (vmsspec == NULL)
10446       _ckvmssts_noperl(SS$_INSFMEM);
10447
10448   resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10449   if (resspec == NULL)
10450       _ckvmssts_noperl(SS$_INSFMEM);
10451
10452   /* Make a copy for modification */
10453   cmdlen = strlen(incmd);
10454   cmd = (char *)PerlMem_malloc(cmdlen+1);
10455   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10456   my_strlcpy(cmd, incmd, cmdlen + 1);
10457   image_name[0] = 0;
10458   image_argv[0] = 0;
10459
10460   resdsc.dsc$a_pointer = resspec;
10461   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10462   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10463   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10464
10465   vmscmd->dsc$a_pointer = NULL;
10466   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10467   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10468   vmscmd->dsc$w_length = 0;
10469   if (pvmscmd) *pvmscmd = vmscmd;
10470
10471   if (suggest_quote) *suggest_quote = 0;
10472
10473   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10474     PerlMem_free(cmd);
10475     PerlMem_free(vmsspec);
10476     PerlMem_free(resspec);
10477     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10478   }
10479
10480   s = cmd;
10481
10482   while (*s && isspace(*s)) s++;
10483
10484   if (*s == '@' || *s == '$') {
10485     vmsspec[0] = *s;  rest = s + 1;
10486     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10487   }
10488   else { cp = vmsspec; rest = s; }
10489
10490   /* If the first word is quoted, then we need to unquote it and
10491    * escape spaces within it.  We'll expand into the resspec buffer,
10492    * then copy back into the cmd buffer, expanding the latter if
10493    * necessary.
10494    */
10495   if (*rest == '"') {
10496     char *cp2;
10497     char *r = rest;
10498     bool in_quote = 0;
10499     int clen = cmdlen;
10500     int soff = s - cmd;
10501
10502     for (cp2 = resspec;
10503          *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10504          rest++) {
10505
10506       if (*rest == ' ') {    /* Escape ' ' to '^_'. */
10507         *cp2 = '^';
10508         *(++cp2) = '_';
10509         cp2++;
10510         clen++;
10511       }
10512       else if (*rest == '"') {
10513         clen--;
10514         if (in_quote) {     /* Must be closing quote. */
10515           rest++;
10516           break;
10517         }
10518         in_quote = 1;
10519       }
10520       else {
10521         *cp2 = *rest;
10522         cp2++;
10523       }
10524     }
10525     *cp2 = '\0';
10526
10527     /* Expand the command buffer if necessary. */
10528     if (clen > cmdlen) {
10529       cmd = (char *)PerlMem_realloc(cmd, clen);
10530       if (cmd == NULL)
10531         _ckvmssts_noperl(SS$_INSFMEM);
10532       /* Where we are may have changed, so recompute offsets */
10533       r = cmd + (r - s - soff);
10534       rest = cmd + (rest - s - soff);
10535       s = cmd + soff;
10536     }
10537
10538     /* Shift the non-verb portion of the command (if any) up or
10539      * down as necessary.
10540      */
10541     if (*rest)
10542       memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10543
10544     /* Copy the unquoted and escaped command verb into place. */
10545     memcpy(r, resspec, cp2 - resspec);
10546     cmd[clen] = '\0';
10547     cmdlen = clen;
10548     rest = r;         /* Rewind for subsequent operations. */
10549   }
10550
10551   if (*rest == '.' || *rest == '/') {
10552     char *cp2;
10553     for (cp2 = resspec;
10554          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10555          rest++, cp2++) *cp2 = *rest;
10556     *cp2 = '\0';
10557     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10558       s = vmsspec;
10559
10560       /* When a UNIX spec with no file type is translated to VMS, */
10561       /* A trailing '.' is appended under ODS-5 rules.            */
10562       /* Here we do not want that trailing "." as it prevents     */
10563       /* Looking for a implied ".exe" type. */
10564       if (decc_efs_charset) {
10565           int i;
10566           i = strlen(vmsspec);
10567           if (vmsspec[i-1] == '.') {
10568               vmsspec[i-1] = '\0';
10569           }
10570       }
10571
10572       if (*rest) {
10573         for (cp2 = vmsspec + strlen(vmsspec);
10574              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10575              rest++, cp2++) *cp2 = *rest;
10576         *cp2 = '\0';
10577       }
10578     }
10579   }
10580   /* Intuit whether verb (first word of cmd) is a DCL command:
10581    *   - if first nonspace char is '@', it's a DCL indirection
10582    * otherwise
10583    *   - if verb contains a filespec separator, it's not a DCL command
10584    *   - if it doesn't, caller tells us whether to default to a DCL
10585    *     command, or to a local image unless told it's DCL (by leading '$')
10586    */
10587   if (*s == '@') {
10588       isdcl = 1;
10589       if (suggest_quote) *suggest_quote = 1;
10590   } else {
10591     char *filespec = strpbrk(s,":<[.;");
10592     rest = wordbreak = strpbrk(s," \"\t/");
10593     if (!wordbreak) wordbreak = s + strlen(s);
10594     if (*s == '$') check_img = 0;
10595     if (filespec && (filespec < wordbreak)) isdcl = 0;
10596     else isdcl = !check_img;
10597   }
10598
10599   if (!isdcl) {
10600     int rsts;
10601     imgdsc.dsc$a_pointer = s;
10602     imgdsc.dsc$w_length = wordbreak - s;
10603     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10604     if (!(retsts&1)) {
10605         _ckvmssts_noperl(lib$find_file_end(&cxt));
10606         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10607       if (!(retsts & 1) && *s == '$') {
10608         _ckvmssts_noperl(lib$find_file_end(&cxt));
10609         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10610         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10611         if (!(retsts&1)) {
10612           _ckvmssts_noperl(lib$find_file_end(&cxt));
10613           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10614         }
10615       }
10616     }
10617     _ckvmssts_noperl(lib$find_file_end(&cxt));
10618
10619     if (retsts & 1) {
10620       FILE *fp;
10621       s = resspec;
10622       while (*s && !isspace(*s)) s++;
10623       *s = '\0';
10624
10625       /* check that it's really not DCL with no file extension */
10626       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10627       if (fp) {
10628         char b[256] = {0,0,0,0};
10629         read(fileno(fp), b, 256);
10630         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10631         if (isdcl) {
10632           int shebang_len;
10633
10634           /* Check for script */
10635           shebang_len = 0;
10636           if ((b[0] == '#') && (b[1] == '!'))
10637              shebang_len = 2;
10638 #ifdef ALTERNATE_SHEBANG
10639           else {
10640             shebang_len = strlen(ALTERNATE_SHEBANG);
10641             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10642               char * perlstr;
10643                 perlstr = strstr("perl",b);
10644                 if (perlstr == NULL)
10645                   shebang_len = 0;
10646             }
10647             else
10648               shebang_len = 0;
10649           }
10650 #endif
10651
10652           if (shebang_len > 0) {
10653           int i;
10654           int j;
10655           char tmpspec[NAM$C_MAXRSS + 1];
10656
10657             i = shebang_len;
10658              /* Image is following after white space */
10659             /*--------------------------------------*/
10660             while (isprint(b[i]) && isspace(b[i]))
10661                 i++;
10662
10663             j = 0;
10664             while (isprint(b[i]) && !isspace(b[i])) {
10665                 tmpspec[j++] = b[i++];
10666                 if (j >= NAM$C_MAXRSS)
10667                    break;
10668             }
10669             tmpspec[j] = '\0';
10670
10671              /* There may be some default parameters to the image */
10672             /*---------------------------------------------------*/
10673             j = 0;
10674             while (isprint(b[i])) {
10675                 image_argv[j++] = b[i++];
10676                 if (j >= NAM$C_MAXRSS)
10677                    break;
10678             }
10679             while ((j > 0) && !isprint(image_argv[j-1]))
10680                 j--;
10681             image_argv[j] = 0;
10682
10683             /* It will need to be converted to VMS format and validated */
10684             if (tmpspec[0] != '\0') {
10685               char * iname;
10686
10687                /* Try to find the exact program requested to be run */
10688               /*---------------------------------------------------*/
10689               iname = int_rmsexpand
10690                  (tmpspec, image_name, ".exe",
10691                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10692               if (iname != NULL) {
10693                 if (cando_by_name_int
10694                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10695                   /* MCR prefix needed */
10696                   isdcl = 0;
10697                 }
10698                 else {
10699                    /* Try again with a null type */
10700                   /*----------------------------*/
10701                   iname = int_rmsexpand
10702                     (tmpspec, image_name, ".",
10703                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10704                   if (iname != NULL) {
10705                     if (cando_by_name_int
10706                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10707                       /* MCR prefix needed */
10708                       isdcl = 0;
10709                     }
10710                   }
10711                 }
10712
10713                  /* Did we find the image to run the script? */
10714                 /*------------------------------------------*/
10715                 if (isdcl) {
10716                   char *tchr;
10717
10718                    /* Assume DCL or foreign command exists */
10719                   /*--------------------------------------*/
10720                   tchr = strrchr(tmpspec, '/');
10721                   if (tchr != NULL) {
10722                     tchr++;
10723                   }
10724                   else {
10725                     tchr = tmpspec;
10726                   }
10727                   my_strlcpy(image_name, tchr, sizeof(image_name));
10728                 }
10729               }
10730             }
10731           }
10732         }
10733         fclose(fp);
10734       }
10735       if (check_img && isdcl) {
10736           PerlMem_free(cmd);
10737           PerlMem_free(resspec);
10738           PerlMem_free(vmsspec);
10739           return RMS$_FNF;
10740       }
10741
10742       if (cando_by_name(S_IXUSR,0,resspec)) {
10743         vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10744         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10745         if (!isdcl) {
10746             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10747             if (image_name[0] != 0) {
10748                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10749                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10750             }
10751         } else if (image_name[0] != 0) {
10752             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10753             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10754         } else {
10755             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10756         }
10757         if (suggest_quote) *suggest_quote = 1;
10758
10759         /* If there is an image name, use original command */
10760         if (image_name[0] == 0)
10761             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10762         else {
10763             rest = cmd;
10764             while (*rest && isspace(*rest)) rest++;
10765         }
10766
10767         if (image_argv[0] != 0) {
10768           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10769           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10770         }
10771         if (rest) {
10772            int rest_len;
10773            int vmscmd_len;
10774
10775            rest_len = strlen(rest);
10776            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10777            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10778               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10779            else
10780              retsts = CLI$_BUFOVF;
10781         }
10782         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10783         PerlMem_free(cmd);
10784         PerlMem_free(vmsspec);
10785         PerlMem_free(resspec);
10786         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10787       }
10788       else
10789         retsts = RMS$_PRV;
10790     }
10791   }
10792   /* It's either a DCL command or we couldn't find a suitable image */
10793   vmscmd->dsc$w_length = strlen(cmd);
10794
10795   vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10796   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10797
10798   PerlMem_free(cmd);
10799   PerlMem_free(resspec);
10800   PerlMem_free(vmsspec);
10801
10802   /* check if it's a symbol (for quoting purposes) */
10803   if (suggest_quote && !*suggest_quote) {
10804     int iss;
10805     char equiv[LNM$C_NAMLENGTH];
10806     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10807     eqvdsc.dsc$a_pointer = equiv;
10808
10809     iss = lib$get_symbol(vmscmd,&eqvdsc);
10810     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10811   }
10812   if (!(retsts & 1)) {
10813     /* just hand off status values likely to be due to user error */
10814     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10815         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10816        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10817     else { _ckvmssts_noperl(retsts); }
10818   }
10819
10820   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10821
10822 }  /* end of setup_cmddsc() */
10823
10824
10825 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10826 bool
10827 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10828 {
10829 bool exec_sts;
10830 char * cmd;
10831
10832   if (sp > mark) {
10833     if (vfork_called) {           /* this follows a vfork - act Unixish */
10834       vfork_called--;
10835       if (vfork_called < 0) {
10836         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10837         vfork_called = 0;
10838       }
10839       else return do_aexec(really,mark,sp);
10840     }
10841                                            /* no vfork - act VMSish */
10842     cmd = setup_argstr(aTHX_ really,mark,sp);
10843     exec_sts = vms_do_exec(cmd);
10844     Safefree(cmd);  /* Clean up from setup_argstr() */
10845     return exec_sts;
10846   }
10847
10848   return FALSE;
10849 }  /* end of vms_do_aexec() */
10850 /*}}}*/
10851
10852 /* {{{bool vms_do_exec(char *cmd) */
10853 bool
10854 Perl_vms_do_exec(pTHX_ const char *cmd)
10855 {
10856   struct dsc$descriptor_s *vmscmd;
10857
10858   if (vfork_called) {             /* this follows a vfork - act Unixish */
10859     vfork_called--;
10860     if (vfork_called < 0) {
10861       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10862       vfork_called = 0;
10863     }
10864     else return do_exec(cmd);
10865   }
10866
10867   {                               /* no vfork - act VMSish */
10868     unsigned long int retsts;
10869
10870     TAINT_ENV();
10871     TAINT_PROPER("exec");
10872     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10873       retsts = lib$do_command(vmscmd);
10874
10875     switch (retsts) {
10876       case RMS$_FNF: case RMS$_DNF:
10877         set_errno(ENOENT); break;
10878       case RMS$_DIR:
10879         set_errno(ENOTDIR); break;
10880       case RMS$_DEV:
10881         set_errno(ENODEV); break;
10882       case RMS$_PRV:
10883         set_errno(EACCES); break;
10884       case RMS$_SYN:
10885         set_errno(EINVAL); break;
10886       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10887         set_errno(E2BIG); break;
10888       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10889         _ckvmssts_noperl(retsts); /* fall through */
10890       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10891         set_errno(EVMSERR);
10892     }
10893     set_vaxc_errno(retsts);
10894     if (ckWARN(WARN_EXEC)) {
10895       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10896              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10897     }
10898     vms_execfree(vmscmd);
10899   }
10900
10901   return FALSE;
10902
10903 }  /* end of vms_do_exec() */
10904 /*}}}*/
10905
10906 int do_spawn2(pTHX_ const char *, int);
10907
10908 int
10909 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10910 {
10911 unsigned long int sts;
10912 char * cmd;
10913 int flags = 0;
10914
10915   if (sp > mark) {
10916
10917     /* We'll copy the (undocumented?) Win32 behavior and allow a
10918      * numeric first argument.  But the only value we'll support
10919      * through do_aspawn is a value of 1, which means spawn without
10920      * waiting for completion -- other values are ignored.
10921      */
10922     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10923         ++mark;
10924         flags = SvIVx(*mark);
10925     }
10926
10927     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10928         flags = CLI$M_NOWAIT;
10929     else
10930         flags = 0;
10931
10932     cmd = setup_argstr(aTHX_ really, mark, sp);
10933     sts = do_spawn2(aTHX_ cmd, flags);
10934     /* pp_sys will clean up cmd */
10935     return sts;
10936   }
10937   return SS$_ABORT;
10938 }  /* end of do_aspawn() */
10939 /*}}}*/
10940
10941
10942 /* {{{int do_spawn(char* cmd) */
10943 int
10944 Perl_do_spawn(pTHX_ char* cmd)
10945 {
10946     PERL_ARGS_ASSERT_DO_SPAWN;
10947
10948     return do_spawn2(aTHX_ cmd, 0);
10949 }
10950 /*}}}*/
10951
10952 /* {{{int do_spawn_nowait(char* cmd) */
10953 int
10954 Perl_do_spawn_nowait(pTHX_ char* cmd)
10955 {
10956     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10957
10958     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10959 }
10960 /*}}}*/
10961
10962 /* {{{int do_spawn2(char *cmd) */
10963 int
10964 do_spawn2(pTHX_ const char *cmd, int flags)
10965 {
10966   unsigned long int sts, substs;
10967
10968   /* The caller of this routine expects to Safefree(PL_Cmd) */
10969   Newx(PL_Cmd,10,char);
10970
10971   TAINT_ENV();
10972   TAINT_PROPER("spawn");
10973   if (!cmd || !*cmd) {
10974     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10975     if (!(sts & 1)) {
10976       switch (sts) {
10977         case RMS$_FNF:  case RMS$_DNF:
10978           set_errno(ENOENT); break;
10979         case RMS$_DIR:
10980           set_errno(ENOTDIR); break;
10981         case RMS$_DEV:
10982           set_errno(ENODEV); break;
10983         case RMS$_PRV:
10984           set_errno(EACCES); break;
10985         case RMS$_SYN:
10986           set_errno(EINVAL); break;
10987         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10988           set_errno(E2BIG); break;
10989         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10990           _ckvmssts_noperl(sts); /* fall through */
10991         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10992           set_errno(EVMSERR);
10993       }
10994       set_vaxc_errno(sts);
10995       if (ckWARN(WARN_EXEC)) {
10996         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10997                     Strerror(errno));
10998       }
10999     }
11000     sts = substs;
11001   }
11002   else {
11003     char mode[3];
11004     PerlIO * fp;
11005     if (flags & CLI$M_NOWAIT)
11006         strcpy(mode, "n");
11007     else
11008         strcpy(mode, "nW");
11009
11010     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11011     if (fp != NULL)
11012       my_pclose(fp);
11013     /* sts will be the pid in the nowait case */
11014   }
11015   return sts;
11016 }  /* end of do_spawn2() */
11017 /*}}}*/
11018
11019
11020 static unsigned int *sockflags, sockflagsize;
11021
11022 /*
11023  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11024  * routines found in some versions of the CRTL can't deal with sockets.
11025  * We don't shim the other file open routines since a socket isn't
11026  * likely to be opened by a name.
11027  */
11028 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11029 FILE *my_fdopen(int fd, const char *mode)
11030 {
11031   FILE *fp = fdopen(fd, mode);
11032
11033   if (fp) {
11034     unsigned int fdoff = fd / sizeof(unsigned int);
11035     Stat_t sbuf; /* native stat; we don't need flex_stat */
11036     if (!sockflagsize || fdoff > sockflagsize) {
11037       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11038       else           Newx  (sockflags,fdoff+2,unsigned int);
11039       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11040       sockflagsize = fdoff + 2;
11041     }
11042     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11043       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11044   }
11045   return fp;
11046
11047 }
11048 /*}}}*/
11049
11050
11051 /*
11052  * Clear the corresponding bit when the (possibly) socket stream is closed.
11053  * There still a small hole: we miss an implicit close which might occur
11054  * via freopen().  >> Todo
11055  */
11056 /*{{{ int my_fclose(FILE *fp)*/
11057 int my_fclose(FILE *fp) {
11058   if (fp) {
11059     unsigned int fd = fileno(fp);
11060     unsigned int fdoff = fd / sizeof(unsigned int);
11061
11062     if (sockflagsize && fdoff < sockflagsize)
11063       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11064   }
11065   return fclose(fp);
11066 }
11067 /*}}}*/
11068
11069
11070 /*
11071  * A simple fwrite replacement which outputs itmsz*nitm chars without
11072  * introducing record boundaries every itmsz chars.
11073  * We are using fputs, which depends on a terminating null.  We may
11074  * well be writing binary data, so we need to accommodate not only
11075  * data with nulls sprinkled in the middle but also data with no null
11076  * byte at the end.
11077  */
11078 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11079 int
11080 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11081 {
11082   char *cp, *end, *cpd;
11083   char *data;
11084   unsigned int fd = fileno(dest);
11085   unsigned int fdoff = fd / sizeof(unsigned int);
11086   int retval;
11087   int bufsize = itmsz * nitm + 1;
11088
11089   if (fdoff < sockflagsize &&
11090       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11091     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11092     return nitm;
11093   }
11094
11095   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11096   memcpy( data, src, itmsz*nitm );
11097   data[itmsz*nitm] = '\0';
11098
11099   end = data + itmsz * nitm;
11100   retval = (int) nitm; /* on success return # items written */
11101
11102   cpd = data;
11103   while (cpd <= end) {
11104     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11105     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11106     if (cp < end)
11107       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11108     cpd = cp + 1;
11109   }
11110
11111   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11112   return retval;
11113
11114 }  /* end of my_fwrite() */
11115 /*}}}*/
11116
11117 /*{{{ int my_flush(FILE *fp)*/
11118 int
11119 Perl_my_flush(pTHX_ FILE *fp)
11120 {
11121     int res;
11122     if ((res = fflush(fp)) == 0 && fp) {
11123 #ifdef VMS_DO_SOCKETS
11124         Stat_t s;
11125         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11126 #endif
11127             res = fsync(fileno(fp));
11128     }
11129 /*
11130  * If the flush succeeded but set end-of-file, we need to clear
11131  * the error because our caller may check ferror().  BTW, this
11132  * probably means we just flushed an empty file.
11133  */
11134     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11135
11136     return res;
11137 }
11138 /*}}}*/
11139
11140 /* fgetname() is not returning the correct file specifications when
11141  * decc_filename_unix_report mode is active.  So we have to have it
11142  * aways return filenames in VMS mode and convert it ourselves.
11143  */
11144
11145 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11146 char *
11147 Perl_my_fgetname(FILE *fp, char * buf) {
11148     char * retname;
11149     char * vms_name;
11150
11151     retname = fgetname(fp, buf, 1);
11152
11153     /* If we are in VMS mode, then we are done */
11154     if (!decc_filename_unix_report || (retname == NULL)) {
11155        return retname;
11156     }
11157
11158     /* Convert this to Unix format */
11159     vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11160     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11161     retname = int_tounixspec(vms_name, buf, NULL);
11162     PerlMem_free(vms_name);
11163
11164     return retname;
11165 }
11166 /*}}}*/
11167
11168 /*
11169  * Here are replacements for the following Unix routines in the VMS environment:
11170  *      getpwuid    Get information for a particular UIC or UID
11171  *      getpwnam    Get information for a named user
11172  *      getpwent    Get information for each user in the rights database
11173  *      setpwent    Reset search to the start of the rights database
11174  *      endpwent    Finish searching for users in the rights database
11175  *
11176  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11177  * (defined in pwd.h), which contains the following fields:-
11178  *      struct passwd {
11179  *              char        *pw_name;    Username (in lower case)
11180  *              char        *pw_passwd;  Hashed password
11181  *              unsigned int pw_uid;     UIC
11182  *              unsigned int pw_gid;     UIC group  number
11183  *              char        *pw_unixdir; Default device/directory (VMS-style)
11184  *              char        *pw_gecos;   Owner name
11185  *              char        *pw_dir;     Default device/directory (Unix-style)
11186  *              char        *pw_shell;   Default CLI name (eg. DCL)
11187  *      };
11188  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11189  *
11190  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11191  * not the UIC member number (eg. what's returned by getuid()),
11192  * getpwuid() can accept either as input (if uid is specified, the caller's
11193  * UIC group is used), though it won't recognise gid=0.
11194  *
11195  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11196  * information about other users in your group or in other groups, respectively.
11197  * If the required privilege is not available, then these routines fill only
11198  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11199  * string).
11200  *
11201  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11202  */
11203
11204 /* sizes of various UAF record fields */
11205 #define UAI$S_USERNAME 12
11206 #define UAI$S_IDENT    31
11207 #define UAI$S_OWNER    31
11208 #define UAI$S_DEFDEV   31
11209 #define UAI$S_DEFDIR   63
11210 #define UAI$S_DEFCLI   31
11211 #define UAI$S_PWD       8
11212
11213 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11214                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11215                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11216
11217 static char __empty[]= "";
11218 static struct passwd __passwd_empty=
11219     {(char *) __empty, (char *) __empty, 0, 0,
11220      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11221 static int contxt= 0;
11222 static struct passwd __pwdcache;
11223 static char __pw_namecache[UAI$S_IDENT+1];
11224
11225 /*
11226  * This routine does most of the work extracting the user information.
11227  */
11228 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11229 {
11230     static struct {
11231         unsigned char length;
11232         char pw_gecos[UAI$S_OWNER+1];
11233     } owner;
11234     static union uicdef uic;
11235     static struct {
11236         unsigned char length;
11237         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11238     } defdev;
11239     static struct {
11240         unsigned char length;
11241         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11242     } defdir;
11243     static struct {
11244         unsigned char length;
11245         char pw_shell[UAI$S_DEFCLI+1];
11246     } defcli;
11247     static char pw_passwd[UAI$S_PWD+1];
11248
11249     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11250     struct dsc$descriptor_s name_desc;
11251     unsigned long int sts;
11252
11253     static struct itmlst_3 itmlst[]= {
11254         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11255         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11256         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11257         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11258         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11259         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11260         {0,                0,           NULL,    NULL}};
11261
11262     name_desc.dsc$w_length=  strlen(name);
11263     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11264     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11265     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11266
11267 /*  Note that sys$getuai returns many fields as counted strings. */
11268     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11269     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11270       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11271     }
11272     else { _ckvmssts(sts); }
11273     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11274
11275     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11276     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11277     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11278     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11279     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11280     owner.pw_gecos[lowner]=            '\0';
11281     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11282     defcli.pw_shell[ldefcli]=          '\0';
11283     if (valid_uic(uic)) {
11284         pwd->pw_uid= uic.uic$l_uic;
11285         pwd->pw_gid= uic.uic$v_group;
11286     }
11287     else
11288       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11289     pwd->pw_passwd=  pw_passwd;
11290     pwd->pw_gecos=   owner.pw_gecos;
11291     pwd->pw_dir=     defdev.pw_dir;
11292     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11293     pwd->pw_shell=   defcli.pw_shell;
11294     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11295         int ldir;
11296         ldir= strlen(pwd->pw_unixdir) - 1;
11297         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11298     }
11299     else
11300         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11301     if (!decc_efs_case_preserve)
11302         __mystrtolower(pwd->pw_unixdir);
11303     return 1;
11304 }
11305
11306 /*
11307  * Get information for a named user.
11308 */
11309 /*{{{struct passwd *getpwnam(char *name)*/
11310 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11311 {
11312     struct dsc$descriptor_s name_desc;
11313     union uicdef uic;
11314     unsigned long int sts;
11315
11316     __pwdcache = __passwd_empty;
11317     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11318       /* We still may be able to determine pw_uid and pw_gid */
11319       name_desc.dsc$w_length=  strlen(name);
11320       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11321       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11322       name_desc.dsc$a_pointer= (char *) name;
11323       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11324         __pwdcache.pw_uid= uic.uic$l_uic;
11325         __pwdcache.pw_gid= uic.uic$v_group;
11326       }
11327       else {
11328         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11329           set_vaxc_errno(sts);
11330           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11331           return NULL;
11332         }
11333         else { _ckvmssts(sts); }
11334       }
11335     }
11336     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11337     __pwdcache.pw_name= __pw_namecache;
11338     return &__pwdcache;
11339 }  /* end of my_getpwnam() */
11340 /*}}}*/
11341
11342 /*
11343  * Get information for a particular UIC or UID.
11344  * Called by my_getpwent with uid=-1 to list all users.
11345 */
11346 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11347 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11348 {
11349     const $DESCRIPTOR(name_desc,__pw_namecache);
11350     unsigned short lname;
11351     union uicdef uic;
11352     unsigned long int status;
11353
11354     if (uid == (unsigned int) -1) {
11355       do {
11356         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11357         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11358           set_vaxc_errno(status);
11359           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11360           my_endpwent();
11361           return NULL;
11362         }
11363         else { _ckvmssts(status); }
11364       } while (!valid_uic (uic));
11365     }
11366     else {
11367       uic.uic$l_uic= uid;
11368       if (!uic.uic$v_group)
11369         uic.uic$v_group= PerlProc_getgid();
11370       if (valid_uic(uic))
11371         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11372       else status = SS$_IVIDENT;
11373       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11374           status == RMS$_PRV) {
11375         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11376         return NULL;
11377       }
11378       else { _ckvmssts(status); }
11379     }
11380     __pw_namecache[lname]= '\0';
11381     __mystrtolower(__pw_namecache);
11382
11383     __pwdcache = __passwd_empty;
11384     __pwdcache.pw_name = __pw_namecache;
11385
11386 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11387     The identifier's value is usually the UIC, but it doesn't have to be,
11388     so if we can, we let fillpasswd update this. */
11389     __pwdcache.pw_uid =  uic.uic$l_uic;
11390     __pwdcache.pw_gid =  uic.uic$v_group;
11391
11392     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11393     return &__pwdcache;
11394
11395 }  /* end of my_getpwuid() */
11396 /*}}}*/
11397
11398 /*
11399  * Get information for next user.
11400 */
11401 /*{{{struct passwd *my_getpwent()*/
11402 struct passwd *Perl_my_getpwent(pTHX)
11403 {
11404     return (my_getpwuid((unsigned int) -1));
11405 }
11406 /*}}}*/
11407
11408 /*
11409  * Finish searching rights database for users.
11410 */
11411 /*{{{void my_endpwent()*/
11412 void Perl_my_endpwent(pTHX)
11413 {
11414     if (contxt) {
11415       _ckvmssts(sys$finish_rdb(&contxt));
11416       contxt= 0;
11417     }
11418 }
11419 /*}}}*/
11420
11421 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11422  * my_utime(), and flex_stat(), all of which operate on UTC unless
11423  * VMSISH_TIMES is true.
11424  */
11425 /* method used to handle UTC conversions:
11426  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11427  */
11428 static int gmtime_emulation_type;
11429 /* number of secs to add to UTC POSIX-style time to get local time */
11430 static long int utc_offset_secs;
11431
11432 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11433  * in vmsish.h.  #undef them here so we can call the CRTL routines
11434  * directly.
11435  */
11436 #undef gmtime
11437 #undef localtime
11438 #undef time
11439
11440
11441 static time_t toutc_dst(time_t loc) {
11442   struct tm *rsltmp;
11443
11444   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11445   loc -= utc_offset_secs;
11446   if (rsltmp->tm_isdst) loc -= 3600;
11447   return loc;
11448 }
11449 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11450        ((gmtime_emulation_type || my_time(NULL)), \
11451        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11452        ((secs) - utc_offset_secs))))
11453
11454 static time_t toloc_dst(time_t utc) {
11455   struct tm *rsltmp;
11456
11457   utc += utc_offset_secs;
11458   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11459   if (rsltmp->tm_isdst) utc += 3600;
11460   return utc;
11461 }
11462 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11463        ((gmtime_emulation_type || my_time(NULL)), \
11464        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11465        ((secs) + utc_offset_secs))))
11466
11467 /* my_time(), my_localtime(), my_gmtime()
11468  * By default traffic in UTC time values, using CRTL gmtime() or
11469  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11470  * Note: We need to use these functions even when the CRTL has working
11471  * UTC support, since they also handle C<use vmsish qw(times);>
11472  *
11473  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11474  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11475  */
11476
11477 /*{{{time_t my_time(time_t *timep)*/
11478 time_t Perl_my_time(pTHX_ time_t *timep)
11479 {
11480   time_t when;
11481   struct tm *tm_p;
11482
11483   if (gmtime_emulation_type == 0) {
11484     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11485                               /* results of calls to gmtime() and localtime() */
11486                               /* for same &base */
11487
11488     gmtime_emulation_type++;
11489     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11490       char off[LNM$C_NAMLENGTH+1];;
11491
11492       gmtime_emulation_type++;
11493       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11494         gmtime_emulation_type++;
11495         utc_offset_secs = 0;
11496         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11497       }
11498       else { utc_offset_secs = atol(off); }
11499     }
11500     else { /* We've got a working gmtime() */
11501       struct tm gmt, local;
11502
11503       gmt = *tm_p;
11504       tm_p = localtime(&base);
11505       local = *tm_p;
11506       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11507       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11508       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11509       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11510     }
11511   }
11512
11513   when = time(NULL);
11514 # ifdef VMSISH_TIME
11515   if (VMSISH_TIME) when = _toloc(when);
11516 # endif
11517   if (timep != NULL) *timep = when;
11518   return when;
11519
11520 }  /* end of my_time() */
11521 /*}}}*/
11522
11523
11524 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11525 struct tm *
11526 Perl_my_gmtime(pTHX_ const time_t *timep)
11527 {
11528   time_t when;
11529   struct tm *rsltmp;
11530
11531   if (timep == NULL) {
11532     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11533     return NULL;
11534   }
11535   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11536
11537   when = *timep;
11538 # ifdef VMSISH_TIME
11539   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11540 #  endif
11541   return gmtime(&when);
11542 }  /* end of my_gmtime() */
11543 /*}}}*/
11544
11545
11546 /*{{{struct tm *my_localtime(const time_t *timep)*/
11547 struct tm *
11548 Perl_my_localtime(pTHX_ const time_t *timep)
11549 {
11550   time_t when;
11551
11552   if (timep == NULL) {
11553     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11554     return NULL;
11555   }
11556   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11557   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11558
11559   when = *timep;
11560 # ifdef VMSISH_TIME
11561   if (VMSISH_TIME) when = _toutc(when);
11562 # endif
11563   /* CRTL localtime() wants UTC as input, does tz correction itself */
11564   return localtime(&when);
11565 } /*  end of my_localtime() */
11566 /*}}}*/
11567
11568 /* Reset definitions for later calls */
11569 #define gmtime(t)    my_gmtime(t)
11570 #define localtime(t) my_localtime(t)
11571 #define time(t)      my_time(t)
11572
11573
11574 /* my_utime - update modification/access time of a file
11575  *
11576  * VMS 7.3 and later implementation
11577  * Only the UTC translation is home-grown. The rest is handled by the
11578  * CRTL utime(), which will take into account the relevant feature
11579  * logicals and ODS-5 volume characteristics for true access times.
11580  *
11581  * pre VMS 7.3 implementation:
11582  * The calling sequence is identical to POSIX utime(), but under
11583  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11584  * not maintain access times.  Restrictions differ from the POSIX
11585  * definition in that the time can be changed as long as the
11586  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11587  * no separate checks are made to insure that the caller is the
11588  * owner of the file or has special privs enabled.
11589  * Code here is based on Joe Meadows' FILE utility.
11590  *
11591  */
11592
11593 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11594  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11595  * in 100 ns intervals.
11596  */
11597 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11598
11599 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11600 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11601 {
11602 #if __CRTL_VER >= 70300000
11603   struct utimbuf utc_utimes, *utc_utimesp;
11604
11605   if (utimes != NULL) {
11606     utc_utimes.actime = utimes->actime;
11607     utc_utimes.modtime = utimes->modtime;
11608 # ifdef VMSISH_TIME
11609     /* If input was local; convert to UTC for sys svc */
11610     if (VMSISH_TIME) {
11611       utc_utimes.actime = _toutc(utimes->actime);
11612       utc_utimes.modtime = _toutc(utimes->modtime);
11613     }
11614 # endif
11615     utc_utimesp = &utc_utimes;
11616   }
11617   else {
11618     utc_utimesp = NULL;
11619   }
11620
11621   return utime(file, utc_utimesp);
11622
11623 #else /* __CRTL_VER < 70300000 */
11624
11625   int i;
11626   int sts;
11627   long int bintime[2], len = 2, lowbit, unixtime,
11628            secscale = 10000000; /* seconds --> 100 ns intervals */
11629   unsigned long int chan, iosb[2], retsts;
11630   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11631   struct FAB myfab = cc$rms_fab;
11632   struct NAM mynam = cc$rms_nam;
11633 #if defined (__DECC) && defined (__VAX)
11634   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11635    * at least through VMS V6.1, which causes a type-conversion warning.
11636    */
11637 #  pragma message save
11638 #  pragma message disable cvtdiftypes
11639 #endif
11640   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11641   struct fibdef myfib;
11642 #if defined (__DECC) && defined (__VAX)
11643   /* This should be right after the declaration of myatr, but due
11644    * to a bug in VAX DEC C, this takes effect a statement early.
11645    */
11646 #  pragma message restore
11647 #endif
11648   /* cast ok for read only parameter */
11649   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11650                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11651                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11652
11653   if (file == NULL || *file == '\0') {
11654     SETERRNO(ENOENT, LIB$_INVARG);
11655     return -1;
11656   }
11657
11658   /* Convert to VMS format ensuring that it will fit in 255 characters */
11659   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11660       SETERRNO(ENOENT, LIB$_INVARG);
11661       return -1;
11662   }
11663   if (utimes != NULL) {
11664     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11665      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11666      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11667      * as input, we force the sign bit to be clear by shifting unixtime right
11668      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11669      */
11670     lowbit = (utimes->modtime & 1) ? secscale : 0;
11671     unixtime = (long int) utimes->modtime;
11672 #   ifdef VMSISH_TIME
11673     /* If input was UTC; convert to local for sys svc */
11674     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11675 #   endif
11676     unixtime >>= 1;  secscale <<= 1;
11677     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11678     if (!(retsts & 1)) {
11679       SETERRNO(EVMSERR, retsts);
11680       return -1;
11681     }
11682     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11683     if (!(retsts & 1)) {
11684       SETERRNO(EVMSERR, retsts);
11685       return -1;
11686     }
11687   }
11688   else {
11689     /* Just get the current time in VMS format directly */
11690     retsts = sys$gettim(bintime);
11691     if (!(retsts & 1)) {
11692       SETERRNO(EVMSERR, retsts);
11693       return -1;
11694     }
11695   }
11696
11697   myfab.fab$l_fna = vmsspec;
11698   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11699   myfab.fab$l_nam = &mynam;
11700   mynam.nam$l_esa = esa;
11701   mynam.nam$b_ess = (unsigned char) sizeof esa;
11702   mynam.nam$l_rsa = rsa;
11703   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11704   if (decc_efs_case_preserve)
11705       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11706
11707   /* Look for the file to be affected, letting RMS parse the file
11708    * specification for us as well.  I have set errno using only
11709    * values documented in the utime() man page for VMS POSIX.
11710    */
11711   retsts = sys$parse(&myfab,0,0);
11712   if (!(retsts & 1)) {
11713     set_vaxc_errno(retsts);
11714     if      (retsts == RMS$_PRV) set_errno(EACCES);
11715     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11716     else                         set_errno(EVMSERR);
11717     return -1;
11718   }
11719   retsts = sys$search(&myfab,0,0);
11720   if (!(retsts & 1)) {
11721     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11722     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11723     set_vaxc_errno(retsts);
11724     if      (retsts == RMS$_PRV) set_errno(EACCES);
11725     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11726     else                         set_errno(EVMSERR);
11727     return -1;
11728   }
11729
11730   devdsc.dsc$w_length = mynam.nam$b_dev;
11731   /* cast ok for read only parameter */
11732   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11733
11734   retsts = sys$assign(&devdsc,&chan,0,0);
11735   if (!(retsts & 1)) {
11736     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11737     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11738     set_vaxc_errno(retsts);
11739     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11740     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11741     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11742     else                               set_errno(EVMSERR);
11743     return -1;
11744   }
11745
11746   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11747   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11748
11749   memset((void *) &myfib, 0, sizeof myfib);
11750 #if defined(__DECC) || defined(__DECCXX)
11751   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11752   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11753   /* This prevents the revision time of the file being reset to the current
11754    * time as a result of our IO$_MODIFY $QIO. */
11755   myfib.fib$l_acctl = FIB$M_NORECORD;
11756 #else
11757   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11758   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11759   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11760 #endif
11761   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11762   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11763   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11764   _ckvmssts(sys$dassgn(chan));
11765   if (retsts & 1) retsts = iosb[0];
11766   if (!(retsts & 1)) {
11767     set_vaxc_errno(retsts);
11768     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11769     else                      set_errno(EVMSERR);
11770     return -1;
11771   }
11772
11773   return 0;
11774
11775 #endif /* #if __CRTL_VER >= 70300000 */
11776
11777 }  /* end of my_utime() */
11778 /*}}}*/
11779
11780 /*
11781  * flex_stat, flex_lstat, flex_fstat
11782  * basic stat, but gets it right when asked to stat
11783  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11784  */
11785
11786 #ifndef _USE_STD_STAT
11787 /* encode_dev packs a VMS device name string into an integer to allow
11788  * simple comparisons. This can be used, for example, to check whether two
11789  * files are located on the same device, by comparing their encoded device
11790  * names. Even a string comparison would not do, because stat() reuses the
11791  * device name buffer for each call; so without encode_dev, it would be
11792  * necessary to save the buffer and use strcmp (this would mean a number of
11793  * changes to the standard Perl code, to say nothing of what a Perl script
11794  * would have to do.
11795  *
11796  * The device lock id, if it exists, should be unique (unless perhaps compared
11797  * with lock ids transferred from other nodes). We have a lock id if the disk is
11798  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11799  * device names. Thus we use the lock id in preference, and only if that isn't
11800  * available, do we try to pack the device name into an integer (flagged by
11801  * the sign bit (LOCKID_MASK) being set).
11802  *
11803  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11804  * name and its encoded form, but it seems very unlikely that we will find
11805  * two files on different disks that share the same encoded device names,
11806  * and even more remote that they will share the same file id (if the test
11807  * is to check for the same file).
11808  *
11809  * A better method might be to use sys$device_scan on the first call, and to
11810  * search for the device, returning an index into the cached array.
11811  * The number returned would be more intelligible.
11812  * This is probably not worth it, and anyway would take quite a bit longer
11813  * on the first call.
11814  */
11815 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11816 static mydev_t encode_dev (pTHX_ const char *dev)
11817 {
11818   int i;
11819   unsigned long int f;
11820   mydev_t enc;
11821   char c;
11822   const char *q;
11823
11824   if (!dev || !dev[0]) return 0;
11825
11826 #if LOCKID_MASK
11827   {
11828     struct dsc$descriptor_s dev_desc;
11829     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11830
11831     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11832        can try that first. */
11833     dev_desc.dsc$w_length =  strlen (dev);
11834     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11835     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11836     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11837     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11838     if (!$VMS_STATUS_SUCCESS(status)) {
11839       switch (status) {
11840         case SS$_NOSUCHDEV:
11841           SETERRNO(ENODEV, status);
11842           return 0;
11843         default:
11844           _ckvmssts(status);
11845       }
11846     }
11847     if (lockid) return (lockid & ~LOCKID_MASK);
11848   }
11849 #endif
11850
11851   /* Otherwise we try to encode the device name */
11852   enc = 0;
11853   f = 1;
11854   i = 0;
11855   for (q = dev + strlen(dev); q--; q >= dev) {
11856     if (*q == ':')
11857         break;
11858     if (isdigit (*q))
11859       c= (*q) - '0';
11860     else if (isalpha (toupper (*q)))
11861       c= toupper (*q) - 'A' + (char)10;
11862     else
11863       continue; /* Skip '$'s */
11864     i++;
11865     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11866     if (i>1) f *= 36;
11867     enc += f * (unsigned long int) c;
11868   }
11869   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11870
11871 }  /* end of encode_dev() */
11872 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11873         device_no = encode_dev(aTHX_ devname)
11874 #else
11875 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11876         device_no = new_dev_no
11877 #endif
11878
11879 static int
11880 is_null_device(const char *name)
11881 {
11882   if (decc_bug_devnull != 0) {
11883     if (strncmp("/dev/null", name, 9) == 0)
11884       return 1;
11885   }
11886     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11887        The underscore prefix, controller letter, and unit number are
11888        independently optional; for our purposes, the colon punctuation
11889        is not.  The colon can be trailed by optional directory and/or
11890        filename, but two consecutive colons indicates a nodename rather
11891        than a device.  [pr]  */
11892   if (*name == '_') ++name;
11893   if (tolower(*name++) != 'n') return 0;
11894   if (tolower(*name++) != 'l') return 0;
11895   if (tolower(*name) == 'a') ++name;
11896   if (*name == '0') ++name;
11897   return (*name++ == ':') && (*name != ':');
11898 }
11899
11900 static int
11901 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11902
11903 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11904
11905 static I32
11906 Perl_cando_by_name_int
11907    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11908 {
11909   char usrname[L_cuserid];
11910   struct dsc$descriptor_s usrdsc =
11911          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11912   char *vmsname = NULL, *fileified = NULL;
11913   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11914   unsigned short int retlen, trnlnm_iter_count;
11915   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11916   union prvdef curprv;
11917   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11918          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11919          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11920   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11921          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11922          {0,0,0,0}};
11923   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11924          {0,0,0,0}};
11925   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11926   Stat_t st;
11927   static int profile_context = -1;
11928
11929   if (!fname || !*fname) return FALSE;
11930
11931   /* Make sure we expand logical names, since sys$check_access doesn't */
11932   fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11933   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11934   if (!strpbrk(fname,"/]>:")) {
11935       my_strlcpy(fileified, fname, VMS_MAXRSS);
11936       trnlnm_iter_count = 0;
11937       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11938         trnlnm_iter_count++;
11939         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11940       }
11941       fname = fileified;
11942   }
11943
11944   vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11945   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11946   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11947     /* Don't know if already in VMS format, so make sure */
11948     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11949       PerlMem_free(fileified);
11950       PerlMem_free(vmsname);
11951       return FALSE;
11952     }
11953   }
11954   else {
11955     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11956   }
11957
11958   /* sys$check_access needs a file spec, not a directory spec.
11959    * flex_stat now will handle a null thread context during startup.
11960    */
11961
11962   retlen = namdsc.dsc$w_length = strlen(vmsname);
11963   if (vmsname[retlen-1] == ']'
11964       || vmsname[retlen-1] == '>'
11965       || vmsname[retlen-1] == ':'
11966       || (!flex_stat_int(vmsname, &st, 1) &&
11967           S_ISDIR(st.st_mode))) {
11968
11969       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11970         PerlMem_free(fileified);
11971         PerlMem_free(vmsname);
11972         return FALSE;
11973       }
11974       fname = fileified;
11975   }
11976   else {
11977       fname = vmsname;
11978   }
11979
11980   retlen = namdsc.dsc$w_length = strlen(fname);
11981   namdsc.dsc$a_pointer = (char *)fname;
11982
11983   switch (bit) {
11984     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11985       access = ARM$M_EXECUTE;
11986       flags = CHP$M_READ;
11987       break;
11988     case S_IRUSR: case S_IRGRP: case S_IROTH:
11989       access = ARM$M_READ;
11990       flags = CHP$M_READ | CHP$M_USEREADALL;
11991       break;
11992     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11993       access = ARM$M_WRITE;
11994       flags = CHP$M_READ | CHP$M_WRITE;
11995       break;
11996     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11997       access = ARM$M_DELETE;
11998       flags = CHP$M_READ | CHP$M_WRITE;
11999       break;
12000     default:
12001       if (fileified != NULL)
12002         PerlMem_free(fileified);
12003       if (vmsname != NULL)
12004         PerlMem_free(vmsname);
12005       return FALSE;
12006   }
12007
12008   /* Before we call $check_access, create a user profile with the current
12009    * process privs since otherwise it just uses the default privs from the
12010    * UAF and might give false positives or negatives.  This only works on
12011    * VMS versions v6.0 and later since that's when sys$create_user_profile
12012    * became available.
12013    */
12014
12015   /* get current process privs and username */
12016   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12017   _ckvmssts_noperl(iosb[0]);
12018
12019   /* find out the space required for the profile */
12020   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12021                                     &usrprodsc.dsc$w_length,&profile_context));
12022
12023   /* allocate space for the profile and get it filled in */
12024   usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
12025   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12026   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12027                                     &usrprodsc.dsc$w_length,&profile_context));
12028
12029   /* use the profile to check access to the file; free profile & analyze results */
12030   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12031   PerlMem_free(usrprodsc.dsc$a_pointer);
12032   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12033
12034   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12035       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12036       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12037     set_vaxc_errno(retsts);
12038     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12039     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12040     else set_errno(ENOENT);
12041     if (fileified != NULL)
12042       PerlMem_free(fileified);
12043     if (vmsname != NULL)
12044       PerlMem_free(vmsname);
12045     return FALSE;
12046   }
12047   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12048     if (fileified != NULL)
12049       PerlMem_free(fileified);
12050     if (vmsname != NULL)
12051       PerlMem_free(vmsname);
12052     return TRUE;
12053   }
12054   _ckvmssts_noperl(retsts);
12055
12056   if (fileified != NULL)
12057     PerlMem_free(fileified);
12058   if (vmsname != NULL)
12059     PerlMem_free(vmsname);
12060   return FALSE;  /* Should never get here */
12061
12062 }
12063
12064 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12065 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12066  * subset of the applicable information.
12067  */
12068 bool
12069 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12070 {
12071   return cando_by_name_int
12072         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12073 }  /* end of cando() */
12074 /*}}}*/
12075
12076
12077 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12078 I32
12079 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12080 {
12081    return cando_by_name_int(bit, effective, fname, 0);
12082
12083 }  /* end of cando_by_name() */
12084 /*}}}*/
12085
12086
12087 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12088 int
12089 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12090 {
12091   dSAVE_ERRNO; /* fstat may set this even on success */
12092   if (!fstat(fd, &statbufp->crtl_stat)) {
12093     char *cptr;
12094     char *vms_filename;
12095     vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12096     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12097
12098     /* Save name for cando by name in VMS format */
12099     cptr = getname(fd, vms_filename, 1);
12100
12101     /* This should not happen, but just in case */
12102     if (cptr == NULL) {
12103         statbufp->st_devnam[0] = 0;
12104     }
12105     else {
12106         /* Make sure that the saved name fits in 255 characters */
12107         cptr = int_rmsexpand_vms
12108                        (vms_filename,
12109                         statbufp->st_devnam,
12110                         0);
12111         if (cptr == NULL)
12112             statbufp->st_devnam[0] = 0;
12113     }
12114     PerlMem_free(vms_filename);
12115
12116     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12117     VMS_DEVICE_ENCODE
12118         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12119
12120 #   ifdef VMSISH_TIME
12121     if (VMSISH_TIME) {
12122       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12123       statbufp->st_atime = _toloc(statbufp->st_atime);
12124       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12125     }
12126 #   endif
12127     RESTORE_ERRNO;
12128     return 0;
12129   }
12130   return -1;
12131
12132 }  /* end of flex_fstat() */
12133 /*}}}*/
12134
12135 static int
12136 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12137 {
12138     char *temp_fspec = NULL;
12139     char *fileified = NULL;
12140     const char *save_spec;
12141     char *ret_spec;
12142     int retval = -1;
12143     char efs_hack = 0;
12144     char already_fileified = 0;
12145     dSAVEDERRNO;
12146
12147     if (!fspec) {
12148         errno = EINVAL;
12149         return retval;
12150     }
12151
12152     if (decc_bug_devnull != 0) {
12153       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12154         memset(statbufp,0,sizeof *statbufp);
12155         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12156         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12157         statbufp->st_uid = 0x00010001;
12158         statbufp->st_gid = 0x0001;
12159         time((time_t *)&statbufp->st_mtime);
12160         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12161         return 0;
12162       }
12163     }
12164
12165     SAVE_ERRNO;
12166
12167 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12168   /*
12169    * If we are in POSIX filespec mode, accept the filename as is.
12170    */
12171   if (decc_posix_compliant_pathnames == 0) {
12172 #endif
12173
12174     /* Try for a simple stat first.  If fspec contains a filename without
12175      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12176      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12177      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12178      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12179      * the file with null type, specify this by calling flex_stat() with
12180      * a '.' at the end of fspec.
12181      */
12182
12183     if (lstat_flag == 0)
12184         retval = stat(fspec, &statbufp->crtl_stat);
12185     else
12186         retval = lstat(fspec, &statbufp->crtl_stat);
12187
12188     if (!retval) {
12189         save_spec = fspec;
12190     }
12191     else {
12192         /* In the odd case where we have write but not read access
12193          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12194          */
12195         fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12196         if (fileified == NULL)
12197               _ckvmssts_noperl(SS$_INSFMEM);
12198
12199         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12200         if (ret_spec != NULL) {
12201             if (lstat_flag == 0)
12202                 retval = stat(fileified, &statbufp->crtl_stat);
12203             else
12204                 retval = lstat(fileified, &statbufp->crtl_stat);
12205             save_spec = fileified;
12206             already_fileified = 1;
12207         }
12208     }
12209
12210     if (retval && vms_bug_stat_filename) {
12211
12212         temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12213         if (temp_fspec == NULL)
12214             _ckvmssts_noperl(SS$_INSFMEM);
12215
12216         /* We should try again as a vmsified file specification. */
12217
12218         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12219         if (ret_spec != NULL) {
12220             if (lstat_flag == 0)
12221                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12222             else
12223                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12224             save_spec = temp_fspec;
12225         }
12226     }
12227
12228     if (retval) {
12229         /* Last chance - allow multiple dots without EFS CHARSET */
12230         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12231          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12232          * enable it if it isn't already.
12233          */
12234 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12235         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12236             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12237 #endif
12238         if (lstat_flag == 0)
12239             retval = stat(fspec, &statbufp->crtl_stat);
12240         else
12241             retval = lstat(fspec, &statbufp->crtl_stat);
12242         save_spec = fspec;
12243 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12244         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12245             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12246             efs_hack = 1;
12247         }
12248 #endif
12249     }
12250
12251 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12252   } else {
12253     if (lstat_flag == 0)
12254       retval = stat(temp_fspec, &statbufp->crtl_stat);
12255     else
12256       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12257       save_spec = temp_fspec;
12258   }
12259 #endif
12260
12261 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12262   /* As you were... */
12263   if (!decc_efs_charset)
12264     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12265 #endif
12266
12267     if (!retval) {
12268       char *cptr;
12269       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12270
12271       /* If this is an lstat, do not follow the link */
12272       if (lstat_flag)
12273         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12274
12275 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12276       /* If we used the efs_hack above, we must also use it here for */
12277       /* perl_cando to work */
12278       if (efs_hack && (decc_efs_charset_index > 0)) {
12279           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12280       }
12281 #endif
12282
12283       /* If we've got a directory, save a fileified, expanded version of it
12284        * in st_devnam.  If not a directory, just an expanded version.
12285        */
12286       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12287           fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12288           if (fileified == NULL)
12289               _ckvmssts_noperl(SS$_INSFMEM);
12290
12291           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12292           if (cptr != NULL)
12293               save_spec = fileified;
12294       }
12295
12296       cptr = int_rmsexpand(save_spec,
12297                            statbufp->st_devnam,
12298                            NULL,
12299                            rmsex_flags,
12300                            0,
12301                            0);
12302
12303 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12304       if (efs_hack && (decc_efs_charset_index > 0)) {
12305           decc$feature_set_value(decc_efs_charset, 1, 0);
12306       }
12307 #endif
12308
12309       /* Fix me: If this is NULL then stat found a file, and we could */
12310       /* not convert the specification to VMS - Should never happen */
12311       if (cptr == NULL)
12312         statbufp->st_devnam[0] = 0;
12313
12314       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12315       VMS_DEVICE_ENCODE
12316         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12317 #     ifdef VMSISH_TIME
12318       if (VMSISH_TIME) {
12319         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12320         statbufp->st_atime = _toloc(statbufp->st_atime);
12321         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12322       }
12323 #     endif
12324     }
12325     /* If we were successful, leave errno where we found it */
12326     if (retval == 0) RESTORE_ERRNO;
12327     if (temp_fspec)
12328         PerlMem_free(temp_fspec);
12329     if (fileified)
12330         PerlMem_free(fileified);
12331     return retval;
12332
12333 }  /* end of flex_stat_int() */
12334
12335
12336 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12337 int
12338 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12339 {
12340    return flex_stat_int(fspec, statbufp, 0);
12341 }
12342 /*}}}*/
12343
12344 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12345 int
12346 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12347 {
12348    return flex_stat_int(fspec, statbufp, 1);
12349 }
12350 /*}}}*/
12351
12352
12353 /*{{{char *my_getlogin()*/
12354 /* VMS cuserid == Unix getlogin, except calling sequence */
12355 char *
12356 my_getlogin(void)
12357 {
12358     static char user[L_cuserid];
12359     return cuserid(user);
12360 }
12361 /*}}}*/
12362
12363
12364 /*  rmscopy - copy a file using VMS RMS routines
12365  *
12366  *  Copies contents and attributes of spec_in to spec_out, except owner
12367  *  and protection information.  Name and type of spec_in are used as
12368  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12369  *  should try to propagate timestamps from the input file to the output file.
12370  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12371  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12372  *  propagated to the output file at creation iff the output file specification
12373  *  did not contain an explicit name or type, and the revision date is always
12374  *  updated at the end of the copy operation.  If it is greater than 0, then
12375  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12376  *  other than the revision date should be propagated, and bit 1 indicates
12377  *  that the revision date should be propagated.
12378  *
12379  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12380  *
12381  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12382  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12383  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12384  * as part of the Perl standard distribution under the terms of the
12385  * GNU General Public License or the Perl Artistic License.  Copies
12386  * of each may be found in the Perl standard distribution.
12387  */ /* FIXME */
12388 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12389 int
12390 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12391 {
12392     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12393          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12394     unsigned long int sts;
12395     int dna_len;
12396     struct FAB fab_in, fab_out;
12397     struct RAB rab_in, rab_out;
12398     rms_setup_nam(nam);
12399     rms_setup_nam(nam_out);
12400     struct XABDAT xabdat;
12401     struct XABFHC xabfhc;
12402     struct XABRDT xabrdt;
12403     struct XABSUM xabsum;
12404
12405     vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12406     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12407     vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12408     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12409     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12410         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12411       PerlMem_free(vmsin);
12412       PerlMem_free(vmsout);
12413       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12414       return 0;
12415     }
12416
12417     esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12418     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12419     esal = NULL;
12420 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12421     esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12422     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12423 #endif
12424     fab_in = cc$rms_fab;
12425     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12426     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12427     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12428     fab_in.fab$l_fop = FAB$M_SQO;
12429     rms_bind_fab_nam(fab_in, nam);
12430     fab_in.fab$l_xab = (void *) &xabdat;
12431
12432     rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12433     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12434     rsal = NULL;
12435 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12436     rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12437     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12438 #endif
12439     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12440     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12441     rms_nam_esl(nam) = 0;
12442     rms_nam_rsl(nam) = 0;
12443     rms_nam_esll(nam) = 0;
12444     rms_nam_rsll(nam) = 0;
12445 #ifdef NAM$M_NO_SHORT_UPCASE
12446     if (decc_efs_case_preserve)
12447         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12448 #endif
12449
12450     xabdat = cc$rms_xabdat;        /* To get creation date */
12451     xabdat.xab$l_nxt = (void *) &xabfhc;
12452
12453     xabfhc = cc$rms_xabfhc;        /* To get record length */
12454     xabfhc.xab$l_nxt = (void *) &xabsum;
12455
12456     xabsum = cc$rms_xabsum;        /* To get key and area information */
12457
12458     if (!((sts = sys$open(&fab_in)) & 1)) {
12459       PerlMem_free(vmsin);
12460       PerlMem_free(vmsout);
12461       PerlMem_free(esa);
12462       if (esal != NULL)
12463         PerlMem_free(esal);
12464       PerlMem_free(rsa);
12465       if (rsal != NULL)
12466         PerlMem_free(rsal);
12467       set_vaxc_errno(sts);
12468       switch (sts) {
12469         case RMS$_FNF: case RMS$_DNF:
12470           set_errno(ENOENT); break;
12471         case RMS$_DIR:
12472           set_errno(ENOTDIR); break;
12473         case RMS$_DEV:
12474           set_errno(ENODEV); break;
12475         case RMS$_SYN:
12476           set_errno(EINVAL); break;
12477         case RMS$_PRV:
12478           set_errno(EACCES); break;
12479         default:
12480           set_errno(EVMSERR);
12481       }
12482       return 0;
12483     }
12484
12485     nam_out = nam;
12486     fab_out = fab_in;
12487     fab_out.fab$w_ifi = 0;
12488     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12489     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12490     fab_out.fab$l_fop = FAB$M_SQO;
12491     rms_bind_fab_nam(fab_out, nam_out);
12492     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12493     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12494     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12495     esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12496     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12497     rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12498     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12499     esal_out = NULL;
12500     rsal_out = NULL;
12501 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12502     esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12503     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12504     rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12505     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12506 #endif
12507     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12508     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12509
12510     if (preserve_dates == 0) {  /* Act like DCL COPY */
12511       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12512       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12513       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12514         PerlMem_free(vmsin);
12515         PerlMem_free(vmsout);
12516         PerlMem_free(esa);
12517         if (esal != NULL)
12518             PerlMem_free(esal);
12519         PerlMem_free(rsa);
12520         if (rsal != NULL)
12521             PerlMem_free(rsal);
12522         PerlMem_free(esa_out);
12523         if (esal_out != NULL)
12524             PerlMem_free(esal_out);
12525         PerlMem_free(rsa_out);
12526         if (rsal_out != NULL)
12527             PerlMem_free(rsal_out);
12528         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12529         set_vaxc_errno(sts);
12530         return 0;
12531       }
12532       fab_out.fab$l_xab = (void *) &xabdat;
12533       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12534         preserve_dates = 1;
12535     }
12536     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12537       preserve_dates =0;      /* bitmask from this point forward   */
12538
12539     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12540     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12541       PerlMem_free(vmsin);
12542       PerlMem_free(vmsout);
12543       PerlMem_free(esa);
12544       if (esal != NULL)
12545           PerlMem_free(esal);
12546       PerlMem_free(rsa);
12547       if (rsal != NULL)
12548           PerlMem_free(rsal);
12549       PerlMem_free(esa_out);
12550       if (esal_out != NULL)
12551           PerlMem_free(esal_out);
12552       PerlMem_free(rsa_out);
12553       if (rsal_out != NULL)
12554           PerlMem_free(rsal_out);
12555       set_vaxc_errno(sts);
12556       switch (sts) {
12557         case RMS$_DNF:
12558           set_errno(ENOENT); break;
12559         case RMS$_DIR:
12560           set_errno(ENOTDIR); break;
12561         case RMS$_DEV:
12562           set_errno(ENODEV); break;
12563         case RMS$_SYN:
12564           set_errno(EINVAL); break;
12565         case RMS$_PRV:
12566           set_errno(EACCES); break;
12567         default:
12568           set_errno(EVMSERR);
12569       }
12570       return 0;
12571     }
12572     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12573     if (preserve_dates & 2) {
12574       /* sys$close() will process xabrdt, not xabdat */
12575       xabrdt = cc$rms_xabrdt;
12576 #ifndef __GNUC__
12577       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12578 #else
12579       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12580        * is unsigned long[2], while DECC & VAXC use a struct */
12581       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12582 #endif
12583       fab_out.fab$l_xab = (void *) &xabrdt;
12584     }
12585
12586     ubf = (char *)PerlMem_malloc(32256);
12587     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12588     rab_in = cc$rms_rab;
12589     rab_in.rab$l_fab = &fab_in;
12590     rab_in.rab$l_rop = RAB$M_BIO;
12591     rab_in.rab$l_ubf = ubf;
12592     rab_in.rab$w_usz = 32256;
12593     if (!((sts = sys$connect(&rab_in)) & 1)) {
12594       sys$close(&fab_in); sys$close(&fab_out);
12595       PerlMem_free(vmsin);
12596       PerlMem_free(vmsout);
12597       PerlMem_free(ubf);
12598       PerlMem_free(esa);
12599       if (esal != NULL)
12600           PerlMem_free(esal);
12601       PerlMem_free(rsa);
12602       if (rsal != NULL)
12603           PerlMem_free(rsal);
12604       PerlMem_free(esa_out);
12605       if (esal_out != NULL)
12606           PerlMem_free(esal_out);
12607       PerlMem_free(rsa_out);
12608       if (rsal_out != NULL)
12609           PerlMem_free(rsal_out);
12610       set_errno(EVMSERR); set_vaxc_errno(sts);
12611       return 0;
12612     }
12613
12614     rab_out = cc$rms_rab;
12615     rab_out.rab$l_fab = &fab_out;
12616     rab_out.rab$l_rbf = ubf;
12617     if (!((sts = sys$connect(&rab_out)) & 1)) {
12618       sys$close(&fab_in); sys$close(&fab_out);
12619       PerlMem_free(vmsin);
12620       PerlMem_free(vmsout);
12621       PerlMem_free(ubf);
12622       PerlMem_free(esa);
12623       if (esal != NULL)
12624           PerlMem_free(esal);
12625       PerlMem_free(rsa);
12626       if (rsal != NULL)
12627           PerlMem_free(rsal);
12628       PerlMem_free(esa_out);
12629       if (esal_out != NULL)
12630           PerlMem_free(esal_out);
12631       PerlMem_free(rsa_out);
12632       if (rsal_out != NULL)
12633           PerlMem_free(rsal_out);
12634       set_errno(EVMSERR); set_vaxc_errno(sts);
12635       return 0;
12636     }
12637
12638     while ((sts = sys$read(&rab_in))) {  /* always true  */
12639       if (sts == RMS$_EOF) break;
12640       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12641       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12642         sys$close(&fab_in); sys$close(&fab_out);
12643         PerlMem_free(vmsin);
12644         PerlMem_free(vmsout);
12645         PerlMem_free(ubf);
12646         PerlMem_free(esa);
12647         if (esal != NULL)
12648             PerlMem_free(esal);
12649         PerlMem_free(rsa);
12650         if (rsal != NULL)
12651             PerlMem_free(rsal);
12652         PerlMem_free(esa_out);
12653         if (esal_out != NULL)
12654             PerlMem_free(esal_out);
12655         PerlMem_free(rsa_out);
12656         if (rsal_out != NULL)
12657             PerlMem_free(rsal_out);
12658         set_errno(EVMSERR); set_vaxc_errno(sts);
12659         return 0;
12660       }
12661     }
12662
12663
12664     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12665     sys$close(&fab_in);  sys$close(&fab_out);
12666     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12667
12668     PerlMem_free(vmsin);
12669     PerlMem_free(vmsout);
12670     PerlMem_free(ubf);
12671     PerlMem_free(esa);
12672     if (esal != NULL)
12673         PerlMem_free(esal);
12674     PerlMem_free(rsa);
12675     if (rsal != NULL)
12676         PerlMem_free(rsal);
12677     PerlMem_free(esa_out);
12678     if (esal_out != NULL)
12679         PerlMem_free(esal_out);
12680     PerlMem_free(rsa_out);
12681     if (rsal_out != NULL)
12682         PerlMem_free(rsal_out);
12683
12684     if (!(sts & 1)) {
12685       set_errno(EVMSERR); set_vaxc_errno(sts);
12686       return 0;
12687     }
12688
12689     return 1;
12690
12691 }  /* end of rmscopy() */
12692 /*}}}*/
12693
12694
12695 /***  The following glue provides 'hooks' to make some of the routines
12696  * from this file available from Perl.  These routines are sufficiently
12697  * basic, and are required sufficiently early in the build process,
12698  * that's it's nice to have them available to miniperl as well as the
12699  * full Perl, so they're set up here instead of in an extension.  The
12700  * Perl code which handles importation of these names into a given
12701  * package lives in [.VMS]Filespec.pm in @INC.
12702  */
12703
12704 void
12705 rmsexpand_fromperl(pTHX_ CV *cv)
12706 {
12707   dXSARGS;
12708   char *fspec, *defspec = NULL, *rslt;
12709   STRLEN n_a;
12710   int fs_utf8, dfs_utf8;
12711
12712   fs_utf8 = 0;
12713   dfs_utf8 = 0;
12714   if (!items || items > 2)
12715     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12716   fspec = SvPV(ST(0),n_a);
12717   fs_utf8 = SvUTF8(ST(0));
12718   if (!fspec || !*fspec) XSRETURN_UNDEF;
12719   if (items == 2) {
12720     defspec = SvPV(ST(1),n_a);
12721     dfs_utf8 = SvUTF8(ST(1));
12722   }
12723   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12724   ST(0) = sv_newmortal();
12725   if (rslt != NULL) {
12726     sv_usepvn(ST(0),rslt,strlen(rslt));
12727     if (fs_utf8) {
12728         SvUTF8_on(ST(0));
12729     }
12730   }
12731   XSRETURN(1);
12732 }
12733
12734 void
12735 vmsify_fromperl(pTHX_ CV *cv)
12736 {
12737   dXSARGS;
12738   char *vmsified;
12739   STRLEN n_a;
12740   int utf8_fl;
12741
12742   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12743   utf8_fl = SvUTF8(ST(0));
12744   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12745   ST(0) = sv_newmortal();
12746   if (vmsified != NULL) {
12747     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12748     if (utf8_fl) {
12749         SvUTF8_on(ST(0));
12750     }
12751   }
12752   XSRETURN(1);
12753 }
12754
12755 void
12756 unixify_fromperl(pTHX_ CV *cv)
12757 {
12758   dXSARGS;
12759   char *unixified;
12760   STRLEN n_a;
12761   int utf8_fl;
12762
12763   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12764   utf8_fl = SvUTF8(ST(0));
12765   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12766   ST(0) = sv_newmortal();
12767   if (unixified != NULL) {
12768     sv_usepvn(ST(0),unixified,strlen(unixified));
12769     if (utf8_fl) {
12770         SvUTF8_on(ST(0));
12771     }
12772   }
12773   XSRETURN(1);
12774 }
12775
12776 void
12777 fileify_fromperl(pTHX_ CV *cv)
12778 {
12779   dXSARGS;
12780   char *fileified;
12781   STRLEN n_a;
12782   int utf8_fl;
12783
12784   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12785   utf8_fl = SvUTF8(ST(0));
12786   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12787   ST(0) = sv_newmortal();
12788   if (fileified != NULL) {
12789     sv_usepvn(ST(0),fileified,strlen(fileified));
12790     if (utf8_fl) {
12791         SvUTF8_on(ST(0));
12792     }
12793   }
12794   XSRETURN(1);
12795 }
12796
12797 void
12798 pathify_fromperl(pTHX_ CV *cv)
12799 {
12800   dXSARGS;
12801   char *pathified;
12802   STRLEN n_a;
12803   int utf8_fl;
12804
12805   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12806   utf8_fl = SvUTF8(ST(0));
12807   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12808   ST(0) = sv_newmortal();
12809   if (pathified != NULL) {
12810     sv_usepvn(ST(0),pathified,strlen(pathified));
12811     if (utf8_fl) {
12812         SvUTF8_on(ST(0));
12813     }
12814   }
12815   XSRETURN(1);
12816 }
12817
12818 void
12819 vmspath_fromperl(pTHX_ CV *cv)
12820 {
12821   dXSARGS;
12822   char *vmspath;
12823   STRLEN n_a;
12824   int utf8_fl;
12825
12826   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12827   utf8_fl = SvUTF8(ST(0));
12828   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12829   ST(0) = sv_newmortal();
12830   if (vmspath != NULL) {
12831     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12832     if (utf8_fl) {
12833         SvUTF8_on(ST(0));
12834     }
12835   }
12836   XSRETURN(1);
12837 }
12838
12839 void
12840 unixpath_fromperl(pTHX_ CV *cv)
12841 {
12842   dXSARGS;
12843   char *unixpath;
12844   STRLEN n_a;
12845   int utf8_fl;
12846
12847   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12848   utf8_fl = SvUTF8(ST(0));
12849   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12850   ST(0) = sv_newmortal();
12851   if (unixpath != NULL) {
12852     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12853     if (utf8_fl) {
12854         SvUTF8_on(ST(0));
12855     }
12856   }
12857   XSRETURN(1);
12858 }
12859
12860 void
12861 candelete_fromperl(pTHX_ CV *cv)
12862 {
12863   dXSARGS;
12864   char *fspec, *fsp;
12865   SV *mysv;
12866   IO *io;
12867   STRLEN n_a;
12868
12869   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12870
12871   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12872   Newx(fspec, VMS_MAXRSS, char);
12873   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12874   if (isGV_with_GP(mysv)) {
12875     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12876       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12877       ST(0) = &PL_sv_no;
12878       Safefree(fspec);
12879       XSRETURN(1);
12880     }
12881     fsp = fspec;
12882   }
12883   else {
12884     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12885       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12886       ST(0) = &PL_sv_no;
12887       Safefree(fspec);
12888       XSRETURN(1);
12889     }
12890   }
12891
12892   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12893   Safefree(fspec);
12894   XSRETURN(1);
12895 }
12896
12897 void
12898 rmscopy_fromperl(pTHX_ CV *cv)
12899 {
12900   dXSARGS;
12901   char *inspec, *outspec, *inp, *outp;
12902   int date_flag;
12903   SV *mysv;
12904   IO *io;
12905   STRLEN n_a;
12906
12907   if (items < 2 || items > 3)
12908     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12909
12910   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12911   Newx(inspec, VMS_MAXRSS, char);
12912   if (isGV_with_GP(mysv)) {
12913     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12914       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12915       ST(0) = sv_2mortal(newSViv(0));
12916       Safefree(inspec);
12917       XSRETURN(1);
12918     }
12919     inp = inspec;
12920   }
12921   else {
12922     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12923       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12924       ST(0) = sv_2mortal(newSViv(0));
12925       Safefree(inspec);
12926       XSRETURN(1);
12927     }
12928   }
12929   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12930   Newx(outspec, VMS_MAXRSS, char);
12931   if (isGV_with_GP(mysv)) {
12932     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12933       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12934       ST(0) = sv_2mortal(newSViv(0));
12935       Safefree(inspec);
12936       Safefree(outspec);
12937       XSRETURN(1);
12938     }
12939     outp = outspec;
12940   }
12941   else {
12942     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12943       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12944       ST(0) = sv_2mortal(newSViv(0));
12945       Safefree(inspec);
12946       Safefree(outspec);
12947       XSRETURN(1);
12948     }
12949   }
12950   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12951
12952   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12953   Safefree(inspec);
12954   Safefree(outspec);
12955   XSRETURN(1);
12956 }
12957
12958 /* The mod2fname is limited to shorter filenames by design, so it should
12959  * not be modified to support longer EFS pathnames
12960  */
12961 void
12962 mod2fname(pTHX_ CV *cv)
12963 {
12964   dXSARGS;
12965   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12966        workbuff[NAM$C_MAXRSS*1 + 1];
12967   SSize_t counter, num_entries;
12968   /* ODS-5 ups this, but we want to be consistent, so... */
12969   int max_name_len = 39;
12970   AV *in_array = (AV *)SvRV(ST(0));
12971
12972   num_entries = av_tindex(in_array);
12973
12974   /* All the names start with PL_. */
12975   strcpy(ultimate_name, "PL_");
12976
12977   /* Clean up our working buffer */
12978   Zero(work_name, sizeof(work_name), char);
12979
12980   /* Run through the entries and build up a working name */
12981   for(counter = 0; counter <= num_entries; counter++) {
12982     /* If it's not the first name then tack on a __ */
12983     if (counter) {
12984       my_strlcat(work_name, "__", sizeof(work_name));
12985     }
12986     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12987   }
12988
12989   /* Check to see if we actually have to bother...*/
12990   if (strlen(work_name) + 3 <= max_name_len) {
12991     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12992   } else {
12993     /* It's too darned big, so we need to go strip. We use the same */
12994     /* algorithm as xsubpp does. First, strip out doubled __ */
12995     char *source, *dest, last;
12996     dest = workbuff;
12997     last = 0;
12998     for (source = work_name; *source; source++) {
12999       if (last == *source && last == '_') {
13000         continue;
13001       }
13002       *dest++ = *source;
13003       last = *source;
13004     }
13005     /* Go put it back */
13006     my_strlcpy(work_name, workbuff, sizeof(work_name));
13007     /* Is it still too big? */
13008     if (strlen(work_name) + 3 > max_name_len) {
13009       /* Strip duplicate letters */
13010       last = 0;
13011       dest = workbuff;
13012       for (source = work_name; *source; source++) {
13013         if (last == toupper(*source)) {
13014         continue;
13015         }
13016         *dest++ = *source;
13017         last = toupper(*source);
13018       }
13019       my_strlcpy(work_name, workbuff, sizeof(work_name));
13020     }
13021
13022     /* Is it *still* too big? */
13023     if (strlen(work_name) + 3 > max_name_len) {
13024       /* Too bad, we truncate */
13025       work_name[max_name_len - 2] = 0;
13026     }
13027     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
13028   }
13029
13030   /* Okay, return it */
13031   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13032   XSRETURN(1);
13033 }
13034
13035 void
13036 hushexit_fromperl(pTHX_ CV *cv)
13037 {
13038     dXSARGS;
13039
13040     if (items > 0) {
13041         VMSISH_HUSHED = SvTRUE(ST(0));
13042     }
13043     ST(0) = boolSV(VMSISH_HUSHED);
13044     XSRETURN(1);
13045 }
13046
13047
13048 PerlIO *
13049 Perl_vms_start_glob
13050    (pTHX_ SV *tmpglob,
13051     IO *io)
13052 {
13053     PerlIO *fp;
13054     struct vs_str_st *rslt;
13055     char *vmsspec;
13056     char *rstr;
13057     char *begin, *cp;
13058     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13059     PerlIO *tmpfp;
13060     STRLEN i;
13061     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13062     struct dsc$descriptor_vs rsdsc;
13063     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13064     unsigned long hasver = 0, isunix = 0;
13065     unsigned long int lff_flags = 0;
13066     int rms_sts;
13067     int vms_old_glob = 1;
13068
13069     if (!SvOK(tmpglob)) {
13070         SETERRNO(ENOENT,RMS$_FNF);
13071         return NULL;
13072     }
13073
13074     vms_old_glob = !decc_filename_unix_report;
13075
13076 #ifdef VMS_LONGNAME_SUPPORT
13077     lff_flags = LIB$M_FIL_LONG_NAMES;
13078 #endif
13079     /* The Newx macro will not allow me to assign a smaller array
13080      * to the rslt pointer, so we will assign it to the begin char pointer
13081      * and then copy the value into the rslt pointer.
13082      */
13083     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13084     rslt = (struct vs_str_st *)begin;
13085     rslt->length = 0;
13086     rstr = &rslt->str[0];
13087     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13088     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13089     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13090     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13091
13092     Newx(vmsspec, VMS_MAXRSS, char);
13093
13094         /* We could find out if there's an explicit dev/dir or version
13095            by peeking into lib$find_file's internal context at
13096            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13097            but that's unsupported, so I don't want to do it now and
13098            have it bite someone in the future. */
13099         /* Fix-me: vms_split_path() is the only way to do this, the
13100            existing method will fail with many legal EFS or UNIX specifications
13101          */
13102
13103     cp = SvPV(tmpglob,i);
13104
13105     for (; i; i--) {
13106         if (cp[i] == ';') hasver = 1;
13107         if (cp[i] == '.') {
13108             if (sts) hasver = 1;
13109             else sts = 1;
13110         }
13111         if (cp[i] == '/') {
13112             hasdir = isunix = 1;
13113             break;
13114         }
13115         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13116             hasdir = 1;
13117             break;
13118         }
13119     }
13120
13121     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13122     if ((hasdir == 0) && decc_filename_unix_report) {
13123         isunix = 1;
13124     }
13125
13126     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13127         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13128         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13129         int wildstar = 0;
13130         int wildquery = 0;
13131         int found = 0;
13132         Stat_t st;
13133         int stat_sts;
13134         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13135         if (!stat_sts && S_ISDIR(st.st_mode)) {
13136             char * vms_dir;
13137             const char * fname;
13138             STRLEN fname_len;
13139
13140             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13141             /* path delimiter of ':>]', if so, then the old behavior has */
13142             /* obviously been specifically requested */
13143
13144             fname = SvPVX_const(tmpglob);
13145             fname_len = strlen(fname);
13146             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13147             if (vms_old_glob || (vms_dir != NULL)) {
13148                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13149                                             SvPVX(tmpglob),vmsspec,NULL);
13150                 ok = (wilddsc.dsc$a_pointer != NULL);
13151                 /* maybe passed 'foo' rather than '[.foo]', thus not
13152                    detected above */
13153                 hasdir = 1;
13154             } else {
13155                 /* Operate just on the directory, the special stat/fstat for */
13156                 /* leaves the fileified  specification in the st_devnam */
13157                 /* member. */
13158                 wilddsc.dsc$a_pointer = st.st_devnam;
13159                 ok = 1;
13160             }
13161         }
13162         else {
13163             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13164             ok = (wilddsc.dsc$a_pointer != NULL);
13165         }
13166         if (ok)
13167             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13168
13169         /* If not extended character set, replace ? with % */
13170         /* With extended character set, ? is a wildcard single character */
13171         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13172             if (*cp == '?') {
13173                 wildquery = 1;
13174                 if (!decc_efs_charset)
13175                     *cp = '%';
13176             } else if (*cp == '%') {
13177                 wildquery = 1;
13178             } else if (*cp == '*') {
13179                 wildstar = 1;
13180             }
13181         }
13182
13183         if (ok) {
13184             wv_sts = vms_split_path(
13185                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13186                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13187                 &wvs_spec, &wvs_len);
13188         } else {
13189             wn_spec = NULL;
13190             wn_len = 0;
13191             we_spec = NULL;
13192             we_len = 0;
13193         }
13194
13195         sts = SS$_NORMAL;
13196         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13197          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13198          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13199          int valid_find;
13200
13201             valid_find = 0;
13202             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13203                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13204             if (!$VMS_STATUS_SUCCESS(sts))
13205                 break;
13206
13207             /* with varying string, 1st word of buffer contains result length */
13208             rstr[rslt->length] = '\0';
13209
13210              /* Find where all the components are */
13211              v_sts = vms_split_path
13212                        (rstr,
13213                         &v_spec,
13214                         &v_len,
13215                         &r_spec,
13216                         &r_len,
13217                         &d_spec,
13218                         &d_len,
13219                         &n_spec,
13220                         &n_len,
13221                         &e_spec,
13222                         &e_len,
13223                         &vs_spec,
13224                         &vs_len);
13225
13226             /* If no version on input, truncate the version on output */
13227             if (!hasver && (vs_len > 0)) {
13228                 *vs_spec = '\0';
13229                 vs_len = 0;
13230             }
13231
13232             if (isunix) {
13233
13234                 /* In Unix report mode, remove the ".dir;1" from the name */
13235                 /* if it is a real directory */
13236                 if (decc_filename_unix_report && decc_efs_charset) {
13237                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13238                         Stat_t statbuf;
13239                         int ret_sts;
13240
13241                         ret_sts = flex_lstat(rstr, &statbuf);
13242                         if ((ret_sts == 0) &&
13243                             S_ISDIR(statbuf.st_mode)) {
13244                             e_len = 0;
13245                             e_spec[0] = 0;
13246                         }
13247                     }
13248                 }
13249
13250                 /* No version & a null extension on UNIX handling */
13251                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13252                     e_len = 0;
13253                     *e_spec = '\0';
13254                 }
13255             }
13256
13257             if (!decc_efs_case_preserve) {
13258                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13259             }
13260
13261             /* Find File treats a Null extension as return all extensions */
13262             /* This is contrary to Perl expectations */
13263
13264             if (wildstar || wildquery || vms_old_glob) {
13265                 /* really need to see if the returned file name matched */
13266                 /* but for now will assume that it matches */
13267                 valid_find = 1;
13268             } else {
13269                 /* Exact Match requested */
13270                 /* How are directories handled? - like a file */
13271                 if ((e_len == we_len) && (n_len == wn_len)) {
13272                     int t1;
13273                     t1 = e_len;
13274                     if (t1 > 0)
13275                         t1 = strncmp(e_spec, we_spec, e_len);
13276                     if (t1 == 0) {
13277                        t1 = n_len;
13278                        if (t1 > 0)
13279                            t1 = strncmp(n_spec, we_spec, n_len);
13280                        if (t1 == 0)
13281                            valid_find = 1;
13282                     }
13283                 }
13284             }
13285
13286             if (valid_find) {
13287                 found++;
13288
13289                 if (hasdir) {
13290                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13291                     begin = rstr;
13292                 }
13293                 else {
13294                     /* Start with the name */
13295                     begin = n_spec;
13296                 }
13297                 strcat(begin,"\n");
13298                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13299             }
13300         }
13301         if (cxt) (void)lib$find_file_end(&cxt);
13302
13303         if (!found) {
13304             /* Be POSIXish: return the input pattern when no matches */
13305             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13306             strcat(rstr,"\n");
13307             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13308         }
13309
13310         if (ok && sts != RMS$_NMF &&
13311             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13312         if (!ok) {
13313             if (!(sts & 1)) {
13314                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13315             }
13316             PerlIO_close(tmpfp);
13317             fp = NULL;
13318         }
13319         else {
13320             PerlIO_rewind(tmpfp);
13321             IoTYPE(io) = IoTYPE_RDONLY;
13322             IoIFP(io) = fp = tmpfp;
13323             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13324         }
13325     }
13326     Safefree(vmsspec);
13327     Safefree(rslt);
13328     return fp;
13329 }
13330
13331
13332 static char *
13333 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13334                    int *utf8_fl);
13335
13336 void
13337 unixrealpath_fromperl(pTHX_ CV *cv)
13338 {
13339     dXSARGS;
13340     char *fspec, *rslt_spec, *rslt;
13341     STRLEN n_a;
13342
13343     if (!items || items != 1)
13344         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13345
13346     fspec = SvPV(ST(0),n_a);
13347     if (!fspec || !*fspec) XSRETURN_UNDEF;
13348
13349     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13350     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13351
13352     ST(0) = sv_newmortal();
13353     if (rslt != NULL)
13354         sv_usepvn(ST(0),rslt,strlen(rslt));
13355     else
13356         Safefree(rslt_spec);
13357         XSRETURN(1);
13358 }
13359
13360 static char *
13361 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13362                    int *utf8_fl);
13363
13364 void
13365 vmsrealpath_fromperl(pTHX_ CV *cv)
13366 {
13367     dXSARGS;
13368     char *fspec, *rslt_spec, *rslt;
13369     STRLEN n_a;
13370
13371     if (!items || items != 1)
13372         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13373
13374     fspec = SvPV(ST(0),n_a);
13375     if (!fspec || !*fspec) XSRETURN_UNDEF;
13376
13377     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13378     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13379
13380     ST(0) = sv_newmortal();
13381     if (rslt != NULL)
13382         sv_usepvn(ST(0),rslt,strlen(rslt));
13383     else
13384         Safefree(rslt_spec);
13385         XSRETURN(1);
13386 }
13387
13388 #ifdef HAS_SYMLINK
13389 /*
13390  * A thin wrapper around decc$symlink to make sure we follow the
13391  * standard and do not create a symlink with a zero-length name,
13392  * and convert the target to Unix format, as the CRTL can't handle
13393  * targets in VMS format.
13394  */
13395 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13396 int
13397 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13398 {
13399     int sts;
13400     char * utarget;
13401
13402     if (!link_name || !*link_name) {
13403       SETERRNO(ENOENT, SS$_NOSUCHFILE);
13404       return -1;
13405     }
13406
13407     utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13408     /* An untranslatable filename should be passed through. */
13409     (void) int_tounixspec(contents, utarget, NULL);
13410     sts = symlink(utarget, link_name);
13411     PerlMem_free(utarget);
13412     return sts;
13413 }
13414 /*}}}*/
13415
13416 #endif /* HAS_SYMLINK */
13417
13418 int do_vms_case_tolerant(void);
13419
13420 void
13421 case_tolerant_process_fromperl(pTHX_ CV *cv)
13422 {
13423   dXSARGS;
13424   ST(0) = boolSV(do_vms_case_tolerant());
13425   XSRETURN(1);
13426 }
13427
13428 #ifdef USE_ITHREADS
13429
13430 void
13431 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13432                           struct interp_intern *dst)
13433 {
13434     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13435
13436     memcpy(dst,src,sizeof(struct interp_intern));
13437 }
13438
13439 #endif
13440
13441 void
13442 Perl_sys_intern_clear(pTHX)
13443 {
13444 }
13445
13446 void
13447 Perl_sys_intern_init(pTHX)
13448 {
13449     unsigned int ix = RAND_MAX;
13450     double x;
13451
13452     VMSISH_HUSHED = 0;
13453
13454     MY_POSIX_EXIT = vms_posix_exit;
13455
13456     x = (float)ix;
13457     MY_INV_RAND_MAX = 1./x;
13458 }
13459
13460 void
13461 init_os_extras(void)
13462 {
13463   dTHX;
13464   char* file = __FILE__;
13465   if (decc_disable_to_vms_logname_translation) {
13466     no_translate_barewords = TRUE;
13467   } else {
13468     no_translate_barewords = FALSE;
13469   }
13470
13471   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13472   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13473   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13474   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13475   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13476   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13477   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13478   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13479   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13480   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13481   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13482   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13483   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13484   newXSproto("VMS::Filespec::case_tolerant_process",
13485       case_tolerant_process_fromperl,file,"");
13486
13487   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13488
13489   return;
13490 }
13491
13492 #if __CRTL_VER == 80200000
13493 /* This missed getting in to the DECC SDK for 8.2 */
13494 char *realpath(const char *file_name, char * resolved_name, ...);
13495 #endif
13496
13497 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13498 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13499  * The perl fallback routine to provide realpath() is not as efficient
13500  * on OpenVMS.
13501  */
13502
13503 #ifdef __cplusplus
13504 extern "C" {
13505 #endif
13506
13507 /* Hack, use old stat() as fastest way of getting ino_t and device */
13508 int decc$stat(const char *name, void * statbuf);
13509 #if !defined(__VAX) && __CRTL_VER >= 80200000
13510 int decc$lstat(const char *name, void * statbuf);
13511 #else
13512 #define decc$lstat decc$stat
13513 #endif
13514
13515 #ifdef __cplusplus
13516 }
13517 #endif
13518
13519
13520 /* Realpath is fragile.  In 8.3 it does not work if the feature
13521  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13522  * links are implemented in RMS, not the CRTL. It also can fail if the
13523  * user does not have read/execute access to some of the directories.
13524  * So in order for Do What I Mean mode to work, if realpath() fails,
13525  * fall back to looking up the filename by the device name and FID.
13526  */
13527
13528 int vms_fid_to_name(char * outname, int outlen,
13529                     const char * name, int lstat_flag, mode_t * mode)
13530 {
13531 #pragma message save
13532 #pragma message disable MISALGNDSTRCT
13533 #pragma message disable MISALGNDMEM
13534 #pragma member_alignment save
13535 #pragma nomember_alignment
13536 struct statbuf_t {
13537     char           * st_dev;
13538     unsigned short st_ino[3];
13539     unsigned short old_st_mode;
13540     unsigned long  padl[30];  /* plenty of room */
13541 } statbuf;
13542 #pragma message restore
13543 #pragma member_alignment restore
13544
13545     int sts;
13546     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13547     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13548     char *fileified;
13549     char *temp_fspec;
13550     char *ret_spec;
13551
13552     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13553      * unexpected answers
13554      */
13555
13556     fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13557     if (fileified == NULL)
13558         _ckvmssts_noperl(SS$_INSFMEM);
13559
13560     temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13561     if (temp_fspec == NULL)
13562         _ckvmssts_noperl(SS$_INSFMEM);
13563
13564     sts = -1;
13565     /* First need to try as a directory */
13566     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13567     if (ret_spec != NULL) {
13568         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13569         if (ret_spec != NULL) {
13570             if (lstat_flag == 0)
13571                 sts = decc$stat(fileified, &statbuf);
13572             else
13573                 sts = decc$lstat(fileified, &statbuf);
13574         }
13575     }
13576
13577     /* Then as a VMS file spec */
13578     if (sts != 0) {
13579         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13580         if (ret_spec != NULL) {
13581             if (lstat_flag == 0) {
13582                 sts = decc$stat(temp_fspec, &statbuf);
13583             } else {
13584                 sts = decc$lstat(temp_fspec, &statbuf);
13585             }
13586         }
13587     }
13588
13589     if (sts) {
13590         /* Next try - allow multiple dots with out EFS CHARSET */
13591         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13592          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13593          * enable it if it isn't already.
13594          */
13595 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13596         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13597             decc$feature_set_value(decc_efs_charset_index, 1, 1);
13598 #endif
13599         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13600         if (lstat_flag == 0) {
13601             sts = decc$stat(name, &statbuf);
13602         } else {
13603             sts = decc$lstat(name, &statbuf);
13604         }
13605 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13606         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13607             decc$feature_set_value(decc_efs_charset_index, 1, 0);
13608 #endif
13609     }
13610
13611
13612     /* and then because the Perl Unix to VMS conversion is not perfect */
13613     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13614     /* characters from filenames so we need to try it as-is */
13615     if (sts) {
13616         if (lstat_flag == 0) {
13617             sts = decc$stat(name, &statbuf);
13618         } else {
13619             sts = decc$lstat(name, &statbuf);
13620         }
13621     }
13622
13623     if (sts == 0) {
13624         int vms_sts;
13625
13626         dvidsc.dsc$a_pointer=statbuf.st_dev;
13627         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13628
13629         specdsc.dsc$a_pointer = outname;
13630         specdsc.dsc$w_length = outlen-1;
13631
13632         vms_sts = lib$fid_to_name
13633             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13634         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13635             outname[specdsc.dsc$w_length] = 0;
13636
13637             /* Return the mode */
13638             if (mode) {
13639                 *mode = statbuf.old_st_mode;
13640             }
13641         }
13642     }
13643     PerlMem_free(temp_fspec);
13644     PerlMem_free(fileified);
13645     return sts;
13646 }
13647
13648
13649
13650 static char *
13651 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13652                    int *utf8_fl)
13653 {
13654     char * rslt = NULL;
13655
13656 #ifdef HAS_SYMLINK
13657     if (decc_posix_compliant_pathnames > 0 ) {
13658         /* realpath currently only works if posix compliant pathnames are
13659          * enabled.  It may start working when they are not, but in that
13660          * case we still want the fallback behavior for backwards compatibility
13661          */
13662         rslt = realpath(filespec, outbuf);
13663     }
13664 #endif
13665
13666     if (rslt == NULL) {
13667         char * vms_spec;
13668         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13669         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13670         mode_t my_mode;
13671
13672         /* Fall back to fid_to_name */
13673
13674         Newx(vms_spec, VMS_MAXRSS + 1, char);
13675
13676         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13677         if (sts == 0) {
13678
13679
13680             /* Now need to trim the version off */
13681             sts = vms_split_path
13682                   (vms_spec,
13683                    &v_spec,
13684                    &v_len,
13685                    &r_spec,
13686                    &r_len,
13687                    &d_spec,
13688                    &d_len,
13689                    &n_spec,
13690                    &n_len,
13691                    &e_spec,
13692                    &e_len,
13693                    &vs_spec,
13694                    &vs_len);
13695
13696
13697                 if (sts == 0) {
13698                     int haslower = 0;
13699                     const char *cp;
13700
13701                     /* Trim off the version */
13702                     int file_len = v_len + r_len + d_len + n_len + e_len;
13703                     vms_spec[file_len] = 0;
13704
13705                     /* Trim off the .DIR if this is a directory */
13706                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13707                         if (S_ISDIR(my_mode)) {
13708                             e_len = 0;
13709                             e_spec[0] = 0;
13710                         }
13711                     }
13712
13713                     /* Drop NULL extensions on UNIX file specification */
13714                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
13715                         e_len = 0;
13716                         e_spec[0] = '\0';
13717                     }
13718
13719                     /* The result is expected to be in UNIX format */
13720                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13721
13722                     /* Downcase if input had any lower case letters and
13723                      * case preservation is not in effect.
13724                      */
13725                     if (!decc_efs_case_preserve) {
13726                         for (cp = filespec; *cp; cp++)
13727                             if (islower(*cp)) { haslower = 1; break; }
13728
13729                         if (haslower) __mystrtolower(rslt);
13730                     }
13731                 }
13732         } else {
13733
13734             /* Now for some hacks to deal with backwards and forward */
13735             /* compatibility */
13736             if (!decc_efs_charset) {
13737
13738                 /* 1. ODS-2 mode wants to do a syntax only translation */
13739                 rslt = int_rmsexpand(filespec, outbuf,
13740                                     NULL, 0, NULL, utf8_fl);
13741
13742             } else {
13743                 if (decc_filename_unix_report) {
13744                     char * dir_name;
13745                     char * vms_dir_name;
13746                     char * file_name;
13747
13748                     /* 2. ODS-5 / UNIX report mode should return a failure */
13749                     /*    if the parent directory also does not exist */
13750                     /*    Otherwise, get the real path for the parent */
13751                     /*    and add the child to it. */
13752
13753                     /* basename / dirname only available for VMS 7.0+ */
13754                     /* So we may need to implement them as common routines */
13755
13756                     Newx(dir_name, VMS_MAXRSS + 1, char);
13757                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13758                     dir_name[0] = '\0';
13759                     file_name = NULL;
13760
13761                     /* First try a VMS parse */
13762                     sts = vms_split_path
13763                           (filespec,
13764                            &v_spec,
13765                            &v_len,
13766                            &r_spec,
13767                            &r_len,
13768                            &d_spec,
13769                            &d_len,
13770                            &n_spec,
13771                            &n_len,
13772                            &e_spec,
13773                            &e_len,
13774                            &vs_spec,
13775                            &vs_len);
13776
13777                     if (sts == 0) {
13778                         /* This is VMS */
13779
13780                         int dir_len = v_len + r_len + d_len + n_len;
13781                         if (dir_len > 0) {
13782                            memcpy(dir_name, filespec, dir_len);
13783                            dir_name[dir_len] = '\0';
13784                            file_name = (char *)&filespec[dir_len + 1];
13785                         }
13786                     } else {
13787                         /* This must be UNIX */
13788                         char * tchar;
13789
13790                         tchar = strrchr(filespec, '/');
13791
13792                         if (tchar != NULL) {
13793                             int dir_len = tchar - filespec;
13794                             memcpy(dir_name, filespec, dir_len);
13795                             dir_name[dir_len] = '\0';
13796                             file_name = (char *) &filespec[dir_len + 1];
13797                         }
13798                     }
13799
13800                     /* Dir name is defaulted */
13801                     if (dir_name[0] == 0) {
13802                         dir_name[0] = '.';
13803                         dir_name[1] = '\0';
13804                     }
13805
13806                     /* Need realpath for the directory */
13807                     sts = vms_fid_to_name(vms_dir_name,
13808                                           VMS_MAXRSS + 1,
13809                                           dir_name, 0, NULL);
13810
13811                     if (sts == 0) {
13812                         /* Now need to pathify it. */
13813                         char *tdir = int_pathify_dirspec(vms_dir_name,
13814                                                          outbuf);
13815
13816                         /* And now add the original filespec to it */
13817                         if (file_name != NULL) {
13818                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13819                         }
13820                         return outbuf;
13821                     }
13822                     Safefree(vms_dir_name);
13823                     Safefree(dir_name);
13824                 }
13825             }
13826         }
13827         Safefree(vms_spec);
13828     }
13829     return rslt;
13830 }
13831
13832 static char *
13833 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13834                    int *utf8_fl)
13835 {
13836     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13837     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13838
13839     /* Fall back to fid_to_name */
13840
13841     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13842     if (sts != 0) {
13843         return NULL;
13844     }
13845     else {
13846
13847
13848         /* Now need to trim the version off */
13849         sts = vms_split_path
13850                   (outbuf,
13851                    &v_spec,
13852                    &v_len,
13853                    &r_spec,
13854                    &r_len,
13855                    &d_spec,
13856                    &d_len,
13857                    &n_spec,
13858                    &n_len,
13859                    &e_spec,
13860                    &e_len,
13861                    &vs_spec,
13862                    &vs_len);
13863
13864
13865         if (sts == 0) {
13866             int haslower = 0;
13867             const char *cp;
13868
13869             /* Trim off the version */
13870             int file_len = v_len + r_len + d_len + n_len + e_len;
13871             outbuf[file_len] = 0;
13872
13873             /* Downcase if input had any lower case letters and
13874              * case preservation is not in effect.
13875              */
13876             if (!decc_efs_case_preserve) {
13877                 for (cp = filespec; *cp; cp++)
13878                     if (islower(*cp)) { haslower = 1; break; }
13879
13880                 if (haslower) __mystrtolower(outbuf);
13881             }
13882         }
13883     }
13884     return outbuf;
13885 }
13886
13887
13888 /*}}}*/
13889 /* External entry points */
13890 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13891 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13892
13893 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13894 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13895
13896 /* case_tolerant */
13897
13898 /*{{{int do_vms_case_tolerant(void)*/
13899 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13900  * controlled by a process setting.
13901  */
13902 int do_vms_case_tolerant(void)
13903 {
13904     return vms_process_case_tolerant;
13905 }
13906 /*}}}*/
13907 /* External entry points */
13908 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13909 int Perl_vms_case_tolerant(void)
13910 { return do_vms_case_tolerant(); }
13911 #else
13912 int Perl_vms_case_tolerant(void)
13913 { return vms_process_case_tolerant; }
13914 #endif
13915
13916
13917  /* Start of DECC RTL Feature handling */
13918
13919 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13920
13921 static int
13922 set_feature_default(const char *name, int value)
13923 {
13924     int status;
13925     int index;
13926     char val_str[10];
13927
13928     /* If the feature has been explicitly disabled in the environment,
13929      * then don't enable it here.
13930      */
13931     if (value > 0) {
13932         status = simple_trnlnm(name, val_str, sizeof(val_str));
13933         if ($VMS_STATUS_SUCCESS(status)) {
13934             val_str[0] = _toupper(val_str[0]);
13935             if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
13936                 return 0;
13937         }
13938     }
13939
13940     index = decc$feature_get_index(name);
13941
13942     status = decc$feature_set_value(index, 1, value);
13943     if (index == -1 || (status == -1)) {
13944       return -1;
13945     }
13946
13947     status = decc$feature_get_value(index, 1);
13948     if (status != value) {
13949       return -1;
13950     }
13951
13952     /* Various things may check for an environment setting
13953      * rather than the feature directly, so set that too.
13954      */
13955     vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13956
13957     return 0;
13958 }
13959 #endif
13960
13961
13962 /* C RTL Feature settings */
13963
13964 #if defined(__DECC) || defined(__DECCXX)
13965
13966 #ifdef __cplusplus
13967 extern "C" {
13968 #endif
13969
13970 extern void
13971 vmsperl_set_features(void)
13972 {
13973     int status;
13974     int s;
13975     char val_str[10];
13976 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13977     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13978     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13979     unsigned long case_perm;
13980     unsigned long case_image;
13981 #endif
13982
13983     /* Allow an exception to bring Perl into the VMS debugger */
13984     vms_debug_on_exception = 0;
13985     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13986     if ($VMS_STATUS_SUCCESS(status)) {
13987        val_str[0] = _toupper(val_str[0]);
13988        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13989          vms_debug_on_exception = 1;
13990        else
13991          vms_debug_on_exception = 0;
13992     }
13993
13994     /* Debug unix/vms file translation routines */
13995     vms_debug_fileify = 0;
13996     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13997     if ($VMS_STATUS_SUCCESS(status)) {
13998         val_str[0] = _toupper(val_str[0]);
13999         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14000             vms_debug_fileify = 1;
14001         else
14002             vms_debug_fileify = 0;
14003     }
14004
14005
14006     /* Historically PERL has been doing vmsify / stat differently than */
14007     /* the CRTL.  In particular, under some conditions the CRTL will   */
14008     /* remove some illegal characters like spaces from filenames       */
14009     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14010     /* been reporting such file names as invalid and fails to stat them */
14011     /* fixing this bug so that stat()/lstat() accept these like the     */
14012     /* CRTL does will result in several tests failing.                  */
14013     /* This should really be fixed, but for now, set up a feature to    */
14014     /* enable it so that the impact can be studied.                     */
14015     vms_bug_stat_filename = 0;
14016     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14017     if ($VMS_STATUS_SUCCESS(status)) {
14018         val_str[0] = _toupper(val_str[0]);
14019         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14020             vms_bug_stat_filename = 1;
14021         else
14022             vms_bug_stat_filename = 0;
14023     }
14024
14025
14026     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14027     vms_vtf7_filenames = 0;
14028     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14029     if ($VMS_STATUS_SUCCESS(status)) {
14030        val_str[0] = _toupper(val_str[0]);
14031        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14032          vms_vtf7_filenames = 1;
14033        else
14034          vms_vtf7_filenames = 0;
14035     }
14036
14037     /* unlink all versions on unlink() or rename() */
14038     vms_unlink_all_versions = 0;
14039     status = simple_trnlnm
14040         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14041     if ($VMS_STATUS_SUCCESS(status)) {
14042        val_str[0] = _toupper(val_str[0]);
14043        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14044          vms_unlink_all_versions = 1;
14045        else
14046          vms_unlink_all_versions = 0;
14047     }
14048
14049 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14050     /* Detect running under GNV Bash or other UNIX like shell */
14051     gnv_unix_shell = 0;
14052     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14053     if ($VMS_STATUS_SUCCESS(status)) {
14054          gnv_unix_shell = 1;
14055          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14056          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14057          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14058          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14059          vms_unlink_all_versions = 1;
14060          vms_posix_exit = 1;
14061     }
14062     /* Some reasonable defaults that are not CRTL defaults */
14063     set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14064     set_feature_default("DECC$ARGV_PARSE_STYLE", 1);     /* Requires extended parse. */
14065     set_feature_default("DECC$EFS_CHARSET", 1);
14066 #endif
14067
14068     /* hacks to see if known bugs are still present for testing */
14069
14070     /* PCP mode requires creating /dev/null special device file */
14071     decc_bug_devnull = 0;
14072     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14073     if ($VMS_STATUS_SUCCESS(status)) {
14074        val_str[0] = _toupper(val_str[0]);
14075        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14076           decc_bug_devnull = 1;
14077        else
14078           decc_bug_devnull = 0;
14079     }
14080
14081 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14082     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14083     if (s >= 0) {
14084         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14085         if (decc_disable_to_vms_logname_translation < 0)
14086             decc_disable_to_vms_logname_translation = 0;
14087     }
14088
14089     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14090     if (s >= 0) {
14091         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14092         if (decc_efs_case_preserve < 0)
14093             decc_efs_case_preserve = 0;
14094     }
14095
14096     s = decc$feature_get_index("DECC$EFS_CHARSET");
14097     decc_efs_charset_index = s;
14098     if (s >= 0) {
14099         decc_efs_charset = decc$feature_get_value(s, 1);
14100         if (decc_efs_charset < 0)
14101             decc_efs_charset = 0;
14102     }
14103
14104     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14105     if (s >= 0) {
14106         decc_filename_unix_report = decc$feature_get_value(s, 1);
14107         if (decc_filename_unix_report > 0) {
14108             decc_filename_unix_report = 1;
14109             vms_posix_exit = 1;
14110         }
14111         else
14112             decc_filename_unix_report = 0;
14113     }
14114
14115     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14116     if (s >= 0) {
14117         decc_filename_unix_only = decc$feature_get_value(s, 1);
14118         if (decc_filename_unix_only > 0) {
14119             decc_filename_unix_only = 1;
14120         }
14121         else {
14122             decc_filename_unix_only = 0;
14123         }
14124     }
14125
14126     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14127     if (s >= 0) {
14128         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14129         if (decc_filename_unix_no_version < 0)
14130             decc_filename_unix_no_version = 0;
14131     }
14132
14133     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14134     if (s >= 0) {
14135         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14136         if (decc_readdir_dropdotnotype < 0)
14137             decc_readdir_dropdotnotype = 0;
14138     }
14139
14140 #if __CRTL_VER >= 80200000
14141     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14142     if (s >= 0) {
14143         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14144         if (decc_posix_compliant_pathnames < 0)
14145             decc_posix_compliant_pathnames = 0;
14146         if (decc_posix_compliant_pathnames > 4)
14147             decc_posix_compliant_pathnames = 0;
14148     }
14149
14150 #endif
14151 #else
14152     status = simple_trnlnm
14153         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14154     if ($VMS_STATUS_SUCCESS(status)) {
14155         val_str[0] = _toupper(val_str[0]);
14156         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14157            decc_disable_to_vms_logname_translation = 1;
14158         }
14159     }
14160
14161 #ifndef __VAX
14162     status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14163     if ($VMS_STATUS_SUCCESS(status)) {
14164         val_str[0] = _toupper(val_str[0]);
14165         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14166            decc_efs_case_preserve = 1;
14167         }
14168     }
14169 #endif
14170
14171     status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14172     if ($VMS_STATUS_SUCCESS(status)) {
14173         val_str[0] = _toupper(val_str[0]);
14174         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14175            decc_filename_unix_report = 1;
14176         }
14177     }
14178     status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14179     if ($VMS_STATUS_SUCCESS(status)) {
14180         val_str[0] = _toupper(val_str[0]);
14181         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14182            decc_filename_unix_only = 1;
14183            decc_filename_unix_report = 1;
14184         }
14185     }
14186     status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14187     if ($VMS_STATUS_SUCCESS(status)) {
14188         val_str[0] = _toupper(val_str[0]);
14189         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14190            decc_filename_unix_no_version = 1;
14191         }
14192     }
14193     status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14194     if ($VMS_STATUS_SUCCESS(status)) {
14195         val_str[0] = _toupper(val_str[0]);
14196         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14197            decc_readdir_dropdotnotype = 1;
14198         }
14199     }
14200 #endif
14201
14202 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14203
14204      /* Report true case tolerance */
14205     /*----------------------------*/
14206     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14207     if (!$VMS_STATUS_SUCCESS(status))
14208         case_perm = PPROP$K_CASE_BLIND;
14209     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14210     if (!$VMS_STATUS_SUCCESS(status))
14211         case_image = PPROP$K_CASE_BLIND;
14212     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14213         (case_image == PPROP$K_CASE_SENSITIVE))
14214         vms_process_case_tolerant = 0;
14215
14216 #endif
14217
14218     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14219     /* for strict backward compatibility */
14220     status = simple_trnlnm
14221         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14222     if ($VMS_STATUS_SUCCESS(status)) {
14223        val_str[0] = _toupper(val_str[0]);
14224        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14225          vms_posix_exit = 1;
14226        else
14227          vms_posix_exit = 0;
14228     }
14229 }
14230
14231 /* Use 32-bit pointers because that's what the image activator
14232  * assumes for the LIB$INITIALZE psect.
14233  */
14234 #if __INITIAL_POINTER_SIZE
14235 #pragma pointer_size save
14236 #pragma pointer_size 32
14237 #endif
14238
14239 /* Create a reference to the LIB$INITIALIZE function. */
14240 extern void LIB$INITIALIZE(void);
14241 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14242
14243 /* Create an array of pointers to the init functions in the special
14244  * LIB$INITIALIZE section. In our case, the array only has one entry.
14245  */
14246 #pragma extern_model save
14247 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
14248 extern void (* const vmsperl_unused_global_2[])() =
14249 {
14250    vmsperl_set_features,
14251 };
14252 #pragma extern_model restore
14253
14254 #if __INITIAL_POINTER_SIZE
14255 #pragma pointer_size restore
14256 #endif
14257
14258 #ifdef __cplusplus
14259 }
14260 #endif
14261
14262 #endif /* defined(__DECC) || defined(__DECCXX) */
14263 /*  End of vms.c */