vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
   6  *    2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
   7  *
   8  *    You may distribute under the terms of either the GNU General Public
   9  *    License or the Artistic License, as specified in the README file.
  10  *
  11  *    Please see Changes*.* or the Perl Repository Browser for revision history.
  12  */
  13
  14 /*
  15  *   Yet small as was their hunted band
  16  *   still fell and fearless was each hand,
  17  *   and strong deeds they wrought yet oft,
  18  *   and loved the woods, whose ways more soft
  19  *   them seemed than thralls of that black throne
  20  *   to live and languish in halls of stone.
  21  *        "The Lay of Leithian", Canto II, lines 135-40
  22  *
  23  *     [p.162 of _The Lays of Beleriand_]
  24  */
  25
  26 #include <acedef.h>
  27 #include <acldef.h>
  28 #include <armdef.h>
  29 #if __CRTL_VER < 70300000
  30 /* needed for home-rolled utime() */
  31 #include <atrdef.h>
  32 #include <fibdef.h>
  33 #endif
  34 #include <chpdef.h>
  35 #include <clidef.h>
  36 #include <climsgdef.h>
  37 #include <dcdef.h>
  38 #include <descrip.h>
  39 #include <devdef.h>
  40 #include <dvidef.h>
  41 #include <float.h>
  42 #include <fscndef.h>
  43 #include <iodef.h>
  44 #include <jpidef.h>
  45 #include <kgbdef.h>
  46 #include <libclidef.h>
  47 #include <libdef.h>
  48 #include <lib$routines.h>
  49 #include <lnmdef.h>
  50 #include <ossdef.h>
  51 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  52 #include <ppropdef.h>
  53 #endif
  54 #include <prvdef.h>
  55 #include <psldef.h>
  56 #include <rms.h>
  57 #include <shrdef.h>
  58 #include <ssdef.h>
  59 #include <starlet.h>
  60 #include <strdef.h>
  61 #include <str$routines.h>
  62 #include <syidef.h>
  63 #include <uaidef.h>
  64 #include <uicdef.h>
  65 #include <stsdef.h>
  66 #include <efndef.h>
  67 #define NO_EFN EFN$C_ENF
  68
  69 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  70 int   decc$feature_get_index(const char *name);
  71 char* decc$feature_get_name(int index);
  72 int   decc$feature_get_value(int index, int mode);
  73 int   decc$feature_set_value(int index, int mode, int value);
  74 #else
  75 #include <unixlib.h>
  76 #endif
  77
  78 #pragma member_alignment save
  79 #pragma nomember_alignment longword
  80 struct item_list_3 {
  81         unsigned short len;
  82         unsigned short code;
  83         void * bufadr;
  84         unsigned short * retadr;
  85 };
  86 #pragma member_alignment restore
  87
  88 /* Older versions of ssdef.h don't have these */
  89 #ifndef SS$_INVFILFOROP
  90 #  define SS$_INVFILFOROP 3930
  91 #endif
  92 #ifndef SS$_NOSUCHOBJECT
  93 #  define SS$_NOSUCHOBJECT 2696
  94 #endif
  95
  96 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
  97 #define PERLIO_NOT_STDIO 0
  98
  99 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 100  * code below needs to get to the underlying CRTL routines. */
 101 #define DONT_MASK_RTL_CALLS
 102 #include "EXTERN.h"
 103 #include "perl.h"
 104 #include "XSUB.h"
 105 /* Anticipating future expansion in lexical warnings . . . */
 106 #ifndef WARN_INTERNAL
 107 #  define WARN_INTERNAL WARN_MISC
 108 #endif
 109
 110 #ifdef VMS_LONGNAME_SUPPORT
 111 #include <libfildef.h>
 112 #endif
 113
 114 #if !defined(__VAX) && __CRTL_VER >= 80200000
 115 #ifdef lstat
 116 #undef lstat
 117 #endif
 118 #else
 119 #ifdef lstat
 120 #undef lstat
 121 #endif
 122 #define lstat(_x, _y) stat(_x, _y)
 123 #endif
 124
 125 /* Routine to create a decterm for use with the Perl debugger */
 126 /* No headers, this information was found in the Programming Concepts Manual */
 127
 128 static int (*decw_term_port)
 129    (const struct dsc$descriptor_s * display,
 130     const struct dsc$descriptor_s * setup_file,
 131     const struct dsc$descriptor_s * customization,
 132     struct dsc$descriptor_s * result_device_name,
 133     unsigned short * result_device_name_length,
 134     void * controller,
 135     void * char_buffer,
 136     void * char_change_buffer) = 0;
 137
 138 /* gcc's header files don't #define direct access macros
 139  * corresponding to VAXC's variant structs */
 140 #ifdef __GNUC__
 141 #  define uic$v_format uic$r_uic_form.uic$v_format
 142 #  define uic$v_group uic$r_uic_form.uic$v_group
 143 #  define uic$v_member uic$r_uic_form.uic$v_member
 144 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 145 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 146 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 147 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 148 #endif
 149
 150 #if defined(NEED_AN_H_ERRNO)
 151 dEXT int h_errno;
 152 #endif
 153
 154 #if defined(__DECC) || defined(__DECCXX)
 155 #pragma member_alignment save
 156 #pragma nomember_alignment longword
 157 #pragma message save
 158 #pragma message disable misalgndmem
 159 #endif
 160 struct itmlst_3 {
 161   unsigned short int buflen;
 162   unsigned short int itmcode;
 163   void *bufadr;
 164   unsigned short int *retlen;
 165 };
 166
 167 struct filescan_itmlst_2 {
 168     unsigned short length;
 169     unsigned short itmcode;
 170     char * component;
 171 };
 172
 173 struct vs_str_st {
 174     unsigned short length;
 175     char str[VMS_MAXRSS];
 176     unsigned short pad; /* for longword struct alignment */
 177 };
 178
 179 #if defined(__DECC) || defined(__DECCXX)
 180 #pragma message restore
 181 #pragma member_alignment restore
 182 #endif
 183
 184 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 185 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 186 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 187 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 188 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 189 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 190 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 191 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 192 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 193 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 194 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 195 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 196
 197 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 198 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 199 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 200 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 201
 202 static char *  int_rmsexpand_vms(
 203     const char * filespec, char * outbuf, unsigned opts);
 204 static char * int_rmsexpand_tovms(
 205     const char * filespec, char * outbuf, unsigned opts);
 206 static char *int_tovmsspec
 207    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 208 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 209 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 210 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 211
 212 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 213 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 214
 215 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 216  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 217  * the Perl facility.
 218  */
 219 #define PERL_LNM_MAX_ITER 10
 220
 221   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 222 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 223 #define MAX_DCL_SYMBOL          (8192)
 224 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 225 #else
 226 #define MAX_DCL_SYMBOL          (1024)
 227 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 228 #endif
 229
 230 static char *__mystrtolower(char *str)
 231 {
 232   if (str) for (; *str; ++str) *str= tolower(*str);
 233   return str;
 234 }
 235
 236 static struct dsc$descriptor_s fildevdsc =
 237   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 238 static struct dsc$descriptor_s crtlenvdsc =
 239   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 240 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 241 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 242 static struct dsc$descriptor_s **env_tables = defenv;
 243 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 244
 245 /* True if we shouldn't treat barewords as logicals during directory */
 246 /* munching */
 247 static int no_translate_barewords;
 248
 249 /* DECC Features that may need to affect how Perl interprets
 250  * displays filename information
 251  */
 252 static int decc_disable_to_vms_logname_translation = 1;
 253 static int decc_disable_posix_root = 1;
 254 int decc_efs_case_preserve = 0;
 255 static int decc_efs_charset = 0;
 256 static int decc_efs_charset_index = -1;
 257 static int decc_filename_unix_no_version = 0;
 258 static int decc_filename_unix_only = 0;
 259 int decc_filename_unix_report = 0;
 260 int decc_posix_compliant_pathnames = 0;
 261 int decc_readdir_dropdotnotype = 0;
 262 static int vms_process_case_tolerant = 1;
 263 int vms_vtf7_filenames = 0;
 264 int gnv_unix_shell = 0;
 265 static int vms_unlink_all_versions = 0;
 266 static int vms_posix_exit = 0;
 267
 268 /* bug workarounds if needed */
 269 int decc_bug_devnull = 1;
 270 int decc_dir_barename = 0;
 271 int vms_bug_stat_filename = 0;
 272
 273 static int vms_debug_on_exception = 0;
 274 static int vms_debug_fileify = 0;
 275
 276 /* Simple logical name translation */
 277 static int simple_trnlnm
 278    (const char * logname,
 279     char * value,
 280     int value_len)
 281 {
 282     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 283     const unsigned long attr = LNM$M_CASE_BLIND;
 284     struct dsc$descriptor_s name_dsc;
 285     int status;
 286     unsigned short result;
 287     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 288                                 {0, 0, 0, 0}};
 289
 290     name_dsc.dsc$w_length = strlen(logname);
 291     name_dsc.dsc$a_pointer = (char *)logname;
 292     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 293     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 294
 295     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 296
 297     if ($VMS_STATUS_SUCCESS(status)) {
 298
 299          /* Null terminate and return the string */
 300         /*--------------------------------------*/
 301         value[result] = 0;
 302         return result;
 303     }
 304
 305     return 0;
 306 }
 307
 308
 309 /* Is this a UNIX file specification?
 310  *   No longer a simple check with EFS file specs
 311  *   For now, not a full check, but need to
 312  *   handle POSIX ^UP^ specifications
 313  *   Fixing to handle ^/ cases would require
 314  *   changes to many other conversion routines.
 315  */
 316
 317 static int is_unix_filespec(const char *path)
 318 {
 319 int ret_val;
 320 const char * pch1;
 321
 322     ret_val = 0;
 323     if (strncmp(path,"\"^UP^",5) != 0) {
 324         pch1 = strchr(path, '/');
 325         if (pch1 != NULL)
 326             ret_val = 1;
 327         else {
 328
 329             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 330             if (decc_filename_unix_report || decc_filename_unix_only) {
 331             if (strcmp(path,".") == 0)
 332                 ret_val = 1;
 333             }
 334         }
 335     }
 336     return ret_val;
 337 }
 338
 339 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 340  */
 341
 342 static void ucs2_to_vtf7
 343    (char *outspec,
 344     unsigned long ucs2_char,
 345     int * output_cnt)
 346 {
 347 unsigned char * ucs_ptr;
 348 int hex;
 349
 350     ucs_ptr = (unsigned char *)&ucs2_char;
 351
 352     outspec[0] = '^';
 353     outspec[1] = 'U';
 354     hex = (ucs_ptr[1] >> 4) & 0xf;
 355     if (hex < 0xA)
 356         outspec[2] = hex + '0';
 357     else
 358         outspec[2] = (hex - 9) + 'A';
 359     hex = ucs_ptr[1] & 0xF;
 360     if (hex < 0xA)
 361         outspec[3] = hex + '0';
 362     else {
 363         outspec[3] = (hex - 9) + 'A';
 364     }
 365     hex = (ucs_ptr[0] >> 4) & 0xf;
 366     if (hex < 0xA)
 367         outspec[4] = hex + '0';
 368     else
 369         outspec[4] = (hex - 9) + 'A';
 370     hex = ucs_ptr[1] & 0xF;
 371     if (hex < 0xA)
 372         outspec[5] = hex + '0';
 373     else {
 374         outspec[5] = (hex - 9) + 'A';
 375     }
 376     *output_cnt = 6;
 377 }
 378
 379
 380 /* This handles the conversion of a UNIX extended character set to a ^
 381  * escaped VMS character.
 382  * in a UNIX file specification.
 383  *
 384  * The output count variable contains the number of characters added
 385  * to the output string.
 386  *
 387  * The return value is the number of characters read from the input string
 388  */
 389 static int copy_expand_unix_filename_escape
 390   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 391 {
 392 int count;
 393 int utf8_flag;
 394
 395     utf8_flag = 0;
 396     if (utf8_fl)
 397       utf8_flag = *utf8_fl;
 398
 399     count = 0;
 400     *output_cnt = 0;
 401     if (*inspec >= 0x80) {
 402         if (utf8_fl && vms_vtf7_filenames) {
 403         unsigned long ucs_char;
 404
 405             ucs_char = 0;
 406
 407             if ((*inspec & 0xE0) == 0xC0) {
 408                 /* 2 byte Unicode */
 409                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 410                 if (ucs_char >= 0x80) {
 411                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 412                     return 2;
 413                 }
 414             } else if ((*inspec & 0xF0) == 0xE0) {
 415                 /* 3 byte Unicode */
 416                 ucs_char = ((inspec[0] & 0xF) << 12) +
 417                    ((inspec[1] & 0x3f) << 6) +
 418                    (inspec[2] & 0x3f);
 419                 if (ucs_char >= 0x800) {
 420                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 421                     return 3;
 422                 }
 423
 424 #if 0 /* I do not see longer sequences supported by OpenVMS */
 425       /* Maybe some one can fix this later */
 426             } else if ((*inspec & 0xF8) == 0xF0) {
 427                 /* 4 byte Unicode */
 428                 /* UCS-4 to UCS-2 */
 429             } else if ((*inspec & 0xFC) == 0xF8) {
 430                 /* 5 byte Unicode */
 431                 /* UCS-4 to UCS-2 */
 432             } else if ((*inspec & 0xFE) == 0xFC) {
 433                 /* 6 byte Unicode */
 434                 /* UCS-4 to UCS-2 */
 435 #endif
 436             }
 437         }
 438
 439         /* High bit set, but not a Unicode character! */
 440
 441         /* Non printing DECMCS or ISO Latin-1 character? */
 442         if ((unsigned char)*inspec <= 0x9F) {
 443             int hex;
 444             outspec[0] = '^';
 445             outspec++;
 446             hex = (*inspec >> 4) & 0xF;
 447             if (hex < 0xA)
 448                 outspec[1] = hex + '0';
 449             else {
 450                 outspec[1] = (hex - 9) + 'A';
 451             }
 452             hex = *inspec & 0xF;
 453             if (hex < 0xA)
 454                 outspec[2] = hex + '0';
 455             else {
 456                 outspec[2] = (hex - 9) + 'A';
 457             }
 458             *output_cnt = 3;
 459             return 1;
 460         } else if ((unsigned char)*inspec == 0xA0) {
 461             outspec[0] = '^';
 462             outspec[1] = 'A';
 463             outspec[2] = '0';
 464             *output_cnt = 3;
 465             return 1;
 466         } else if ((unsigned char)*inspec == 0xFF) {
 467             outspec[0] = '^';
 468             outspec[1] = 'F';
 469             outspec[2] = 'F';
 470             *output_cnt = 3;
 471             return 1;
 472         }
 473         *outspec = *inspec;
 474         *output_cnt = 1;
 475         return 1;
 476     }
 477
 478     /* Is this a macro that needs to be passed through?
 479      * Macros start with $( and an alpha character, followed
 480      * by a string of alpha numeric characters ending with a )
 481      * If this does not match, then encode it as ODS-5.
 482      */
 483     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 484     int tcnt;
 485
 486         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 487             tcnt = 3;
 488             outspec[0] = inspec[0];
 489             outspec[1] = inspec[1];
 490             outspec[2] = inspec[2];
 491
 492             while(isalnum(inspec[tcnt]) ||
 493                   (inspec[2] == '.') || (inspec[2] == '_')) {
 494                 outspec[tcnt] = inspec[tcnt];
 495                 tcnt++;
 496             }
 497             if (inspec[tcnt] == ')') {
 498                 outspec[tcnt] = inspec[tcnt];
 499                 tcnt++;
 500                 *output_cnt = tcnt;
 501                 return tcnt;
 502             }
 503         }
 504     }
 505
 506     switch (*inspec) {
 507     case 0x7f:
 508         outspec[0] = '^';
 509         outspec[1] = '7';
 510         outspec[2] = 'F';
 511         *output_cnt = 3;
 512         return 1;
 513         break;
 514     case '?':
 515         if (decc_efs_charset == 0)
 516           outspec[0] = '%';
 517         else
 518           outspec[0] = '?';
 519         *output_cnt = 1;
 520         return 1;
 521         break;
 522     case '.':
 523     case '~':
 524     case '!':
 525     case '#':
 526     case '&':
 527     case '\'':
 528     case '`':
 529     case '(':
 530     case ')':
 531     case '+':
 532     case '@':
 533     case '{':
 534     case '}':
 535     case ',':
 536     case ';':
 537     case '[':
 538     case ']':
 539     case '%':
 540     case '^':
 541     case '\\':
 542         /* Don't escape again if following character is
 543          * already something we escape.
 544          */
 545         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 546             *outspec = *inspec;
 547             *output_cnt = 1;
 548             return 1;
 549             break;
 550         }
 551         /* But otherwise fall through and escape it. */
 552     case '=':
 553         /* Assume that this is to be escaped */
 554         outspec[0] = '^';
 555         outspec[1] = *inspec;
 556         *output_cnt = 2;
 557         return 1;
 558         break;
 559     case ' ': /* space */
 560         /* Assume that this is to be escaped */
 561         outspec[0] = '^';
 562         outspec[1] = '_';
 563         *output_cnt = 2;
 564         return 1;
 565         break;
 566     default:
 567         *outspec = *inspec;
 568         *output_cnt = 1;
 569         return 1;
 570         break;
 571     }
 572     return 0;
 573 }
 574
 575
 576 /* This handles the expansion of a '^' prefix to the proper character
 577  * in a UNIX file specification.
 578  *
 579  * The output count variable contains the number of characters added
 580  * to the output string.
 581  *
 582  * The return value is the number of characters read from the input
 583  * string
 584  */
 585 static int copy_expand_vms_filename_escape
 586   (char *outspec, const char *inspec, int *output_cnt)
 587 {
 588 int count;
 589 int scnt;
 590
 591     count = 0;
 592     *output_cnt = 0;
 593     if (*inspec == '^') {
 594         inspec++;
 595         switch (*inspec) {
 596         /* Spaces and non-trailing dots should just be passed through,
 597          * but eat the escape character.
 598          */
 599         case '.':
 600             *outspec = *inspec;
 601             count += 2;
 602             (*output_cnt)++;
 603             break;
 604         case '_': /* space */
 605             *outspec = ' ';
 606             count += 2;
 607             (*output_cnt)++;
 608             break;
 609         case '^':
 610             /* Hmm.  Better leave the escape escaped. */
 611             outspec[0] = '^';
 612             outspec[1] = '^';
 613             count += 2;
 614             (*output_cnt) += 2;
 615             break;
 616         case 'U': /* Unicode - FIX-ME this is wrong. */
 617             inspec++;
 618             count++;
 619             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 620             if (scnt == 4) {
 621                 unsigned int c1, c2;
 622                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 623                 outspec[0] = c1 & 0xff;
 624                 outspec[1] = c2 & 0xff;
 625                 if (scnt > 1) {
 626                     (*output_cnt) += 2;
 627                     count += 4;
 628                 }
 629             }
 630             else {
 631                 /* Error - do best we can to continue */
 632                 *outspec = 'U';
 633                 outspec++;
 634                 (*output_cnt++);
 635                 *outspec = *inspec;
 636                 count++;
 637                 (*output_cnt++);
 638             }
 639             break;
 640         default:
 641             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 642             if (scnt == 2) {
 643                 /* Hex encoded */
 644                 unsigned int c1;
 645                 scnt = sscanf(inspec, "%2x", &c1);
 646                 outspec[0] = c1 & 0xff;
 647                 if (scnt > 0) {
 648                     (*output_cnt++);
 649                     count += 2;
 650                 }
 651             }
 652             else {
 653                 *outspec = *inspec;
 654                 count++;
 655                 (*output_cnt++);
 656             }
 657         }
 658     }
 659     else {
 660         *outspec = *inspec;
 661         count++;
 662         (*output_cnt)++;
 663     }
 664     return count;
 665 }
 666
 667 /* vms_split_path - Verify that the input file specification is a
 668  * VMS format file specification, and provide pointers to the components of
 669  * it.  With EFS format filenames, this is virtually the only way to
 670  * parse a VMS path specification into components.
 671  *
 672  * If the sum of the components do not add up to the length of the
 673  * string, then the passed file specification is probably a UNIX style
 674  * path.
 675  */
 676 static int vms_split_path
 677    (const char * path,
 678     char * * volume,
 679     int * vol_len,
 680     char * * root,
 681     int * root_len,
 682     char * * dir,
 683     int * dir_len,
 684     char * * name,
 685     int * name_len,
 686     char * * ext,
 687     int * ext_len,
 688     char * * version,
 689     int * ver_len)
 690 {
 691 struct dsc$descriptor path_desc;
 692 int status;
 693 unsigned long flags;
 694 int ret_stat;
 695 struct filescan_itmlst_2 item_list[9];
 696 const int filespec = 0;
 697 const int nodespec = 1;
 698 const int devspec = 2;
 699 const int rootspec = 3;
 700 const int dirspec = 4;
 701 const int namespec = 5;
 702 const int typespec = 6;
 703 const int verspec = 7;
 704
 705     /* Assume the worst for an easy exit */
 706     ret_stat = -1;
 707     *volume = NULL;
 708     *vol_len = 0;
 709     *root = NULL;
 710     *root_len = 0;
 711     *dir = NULL;
 712     *name = NULL;
 713     *name_len = 0;
 714     *ext = NULL;
 715     *ext_len = 0;
 716     *version = NULL;
 717     *ver_len = 0;
 718
 719     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 720     path_desc.dsc$w_length = strlen(path);
 721     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 722     path_desc.dsc$b_class = DSC$K_CLASS_S;
 723
 724     /* Get the total length, if it is shorter than the string passed
 725      * then this was probably not a VMS formatted file specification
 726      */
 727     item_list[filespec].itmcode = FSCN$_FILESPEC;
 728     item_list[filespec].length = 0;
 729     item_list[filespec].component = NULL;
 730
 731     /* If the node is present, then it gets considered as part of the
 732      * volume name to hopefully make things simple.
 733      */
 734     item_list[nodespec].itmcode = FSCN$_NODE;
 735     item_list[nodespec].length = 0;
 736     item_list[nodespec].component = NULL;
 737
 738     item_list[devspec].itmcode = FSCN$_DEVICE;
 739     item_list[devspec].length = 0;
 740     item_list[devspec].component = NULL;
 741
 742     /* root is a special case,  adding it to either the directory or
 743      * the device components will probably complicate things for the
 744      * callers of this routine, so leave it separate.
 745      */
 746     item_list[rootspec].itmcode = FSCN$_ROOT;
 747     item_list[rootspec].length = 0;
 748     item_list[rootspec].component = NULL;
 749
 750     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 751     item_list[dirspec].length = 0;
 752     item_list[dirspec].component = NULL;
 753
 754     item_list[namespec].itmcode = FSCN$_NAME;
 755     item_list[namespec].length = 0;
 756     item_list[namespec].component = NULL;
 757
 758     item_list[typespec].itmcode = FSCN$_TYPE;
 759     item_list[typespec].length = 0;
 760     item_list[typespec].component = NULL;
 761
 762     item_list[verspec].itmcode = FSCN$_VERSION;
 763     item_list[verspec].length = 0;
 764     item_list[verspec].component = NULL;
 765
 766     item_list[8].itmcode = 0;
 767     item_list[8].length = 0;
 768     item_list[8].component = NULL;
 769
 770     status = sys$filescan
 771        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 772         &flags, NULL, NULL);
 773     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 774
 775     /* If we parsed it successfully these two lengths should be the same */
 776     if (path_desc.dsc$w_length != item_list[filespec].length)
 777         return ret_stat;
 778
 779     /* If we got here, then it is a VMS file specification */
 780     ret_stat = 0;
 781
 782     /* set the volume name */
 783     if (item_list[nodespec].length > 0) {
 784         *volume = item_list[nodespec].component;
 785         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 786     }
 787     else {
 788         *volume = item_list[devspec].component;
 789         *vol_len = item_list[devspec].length;
 790     }
 791
 792     *root = item_list[rootspec].component;
 793     *root_len = item_list[rootspec].length;
 794
 795     *dir = item_list[dirspec].component;
 796     *dir_len = item_list[dirspec].length;
 797
 798     /* Now fun with versions and EFS file specifications
 799      * The parser can not tell the difference when a "." is a version
 800      * delimiter or a part of the file specification.
 801      */
 802     if ((decc_efs_charset) &&
 803         (item_list[verspec].length > 0) &&
 804         (item_list[verspec].component[0] == '.')) {
 805         *name = item_list[namespec].component;
 806         *name_len = item_list[namespec].length + item_list[typespec].length;
 807         *ext = item_list[verspec].component;
 808         *ext_len = item_list[verspec].length;
 809         *version = NULL;
 810         *ver_len = 0;
 811     }
 812     else {
 813         *name = item_list[namespec].component;
 814         *name_len = item_list[namespec].length;
 815         *ext = item_list[typespec].component;
 816         *ext_len = item_list[typespec].length;
 817         *version = item_list[verspec].component;
 818         *ver_len = item_list[verspec].length;
 819     }
 820     return ret_stat;
 821 }
 822
 823 /* Routine to determine if the file specification ends with .dir */
 824 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 825
 826     /* e_len must be 4, and version must be <= 2 characters */
 827     if (e_len != 4 || vs_len > 2)
 828         return 0;
 829
 830     /* If a version number is present, it needs to be one */
 831     if ((vs_len == 2) && (vs_spec[1] != '1'))
 832         return 0;
 833
 834     /* Look for the DIR on the extension */
 835     if (vms_process_case_tolerant) {
 836         if ((toupper(e_spec[1]) == 'D') &&
 837             (toupper(e_spec[2]) == 'I') &&
 838             (toupper(e_spec[3]) == 'R')) {
 839             return 1;
 840         }
 841     } else {
 842         /* Directory extensions are supposed to be in upper case only */
 843         /* I would not be surprised if this rule can not be enforced */
 844         /* if and when someone fully debugs the case sensitive mode */
 845         if ((e_spec[1] == 'D') &&
 846             (e_spec[2] == 'I') &&
 847             (e_spec[3] == 'R')) {
 848             return 1;
 849         }
 850     }
 851     return 0;
 852 }
 853
 854
 855 /* my_maxidx
 856  * Routine to retrieve the maximum equivalence index for an input
 857  * logical name.  Some calls to this routine have no knowledge if
 858  * the variable is a logical or not.  So on error we return a max
 859  * index of zero.
 860  */
 861 /*{{{int my_maxidx(const char *lnm) */
 862 static int
 863 my_maxidx(const char *lnm)
 864 {
 865     int status;
 866     int midx;
 867     int attr = LNM$M_CASE_BLIND;
 868     struct dsc$descriptor lnmdsc;
 869     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 870                                 {0, 0, 0, 0}};
 871
 872     lnmdsc.dsc$w_length = strlen(lnm);
 873     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 874     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 875     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 876
 877     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 878     if ((status & 1) == 0)
 879        midx = 0;
 880
 881     return (midx);
 882 }
 883 /*}}}*/
 884
 885 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 886 int
 887 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 888   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 889 {
 890     const char *cp1;
 891     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 892     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 893     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 894     int midx;
 895     unsigned char acmode;
 896     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 897                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 898     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 899                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 900                                  {0, 0, 0, 0}};
 901     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 902 #if defined(PERL_IMPLICIT_CONTEXT)
 903     pTHX = NULL;
 904     if (PL_curinterp) {
 905       aTHX = PERL_GET_INTERP;
 906     } else {
 907       aTHX = NULL;
 908     }
 909 #endif
 910
 911     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 912       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 913     }
 914     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 915       *cp2 = _toupper(*cp1);
 916       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 917         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 918         return 0;
 919       }
 920     }
 921     lnmdsc.dsc$w_length = cp1 - lnm;
 922     lnmdsc.dsc$a_pointer = uplnm;
 923     uplnm[lnmdsc.dsc$w_length] = '\0';
 924     secure = flags & PERL__TRNENV_SECURE;
 925     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 926     if (!tabvec || !*tabvec) tabvec = env_tables;
 927
 928     for (curtab = 0; tabvec[curtab]; curtab++) {
 929       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 930         if (!ivenv && !secure) {
 931           char *eq;
 932           int i;
 933           if (!environ) {
 934             ivenv = 1;
 935 #if defined(PERL_IMPLICIT_CONTEXT)
 936             if (aTHX == NULL) {
 937                 fprintf(stderr,
 938                     "Can't read CRTL environ\n");
 939             } else
 940 #endif
 941                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 942             continue;
 943           }
 944           retsts = SS$_NOLOGNAM;
 945           for (i = 0; environ[i]; i++) {
 946             if ((eq = strchr(environ[i],'=')) &&
 947                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 948                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 949               eq++;
 950               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 951               if (!eqvlen) continue;
 952               retsts = SS$_NORMAL;
 953               break;
 954             }
 955           }
 956           if (retsts != SS$_NOLOGNAM) break;
 957         }
 958       }
 959       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 960                !str$case_blind_compare(&tmpdsc,&clisym)) {
 961         if (!ivsym && !secure) {
 962           unsigned short int deflen = LNM$C_NAMLENGTH;
 963           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 964           /* dynamic dsc to accommodate possible long value */
 965           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 966           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 967           if (retsts & 1) {
 968             if (eqvlen > MAX_DCL_SYMBOL) {
 969               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 970               eqvlen = MAX_DCL_SYMBOL;
 971               /* Special hack--we might be called before the interpreter's */
 972               /* fully initialized, in which case either thr or PL_curcop */
 973               /* might be bogus. We have to check, since ckWARN needs them */
 974               /* both to be valid if running threaded */
 975 #if defined(PERL_IMPLICIT_CONTEXT)
 976               if (aTHX == NULL) {
 977                   fprintf(stderr,
 978                      "Value of CLI symbol \"%s\" too long",lnm);
 979               } else
 980 #endif
 981                 if (ckWARN(WARN_MISC)) {
 982                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 983                 }
 984             }
 985             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 986           }
 987           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
 988           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 989           if (retsts == LIB$_NOSUCHSYM) continue;
 990           break;
 991         }
 992       }
 993       else if (!ivlnm) {
 994         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 995           midx = my_maxidx(lnm);
 996           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 997             lnmlst[1].bufadr = cp2;
 998             eqvlen = 0;
 999             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1000             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1001             if (retsts == SS$_NOLOGNAM) break;
1002             /* PPFs have a prefix */
1003             if (
1004 #if INTSIZE == 4
1005                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1006 #endif
1007                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1008                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1009                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1010                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1011                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1012               memmove(eqv,eqv+4,eqvlen-4);
1013               eqvlen -= 4;
1014             }
1015             cp2 += eqvlen;
1016             *cp2 = '\0';
1017           }
1018           if ((retsts == SS$_IVLOGNAM) ||
1019               (retsts == SS$_NOLOGNAM)) { continue; }
1020         }
1021         else {
1022           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1023           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1024           if (retsts == SS$_NOLOGNAM) continue;
1025           eqv[eqvlen] = '\0';
1026         }
1027         eqvlen = strlen(eqv);
1028         break;
1029       }
1030     }
1031     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1032     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1033              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1034              retsts == SS$_NOLOGNAM) {
1035       set_errno(EINVAL);  set_vaxc_errno(retsts);
1036     }
1037     else _ckvmssts_noperl(retsts);
1038     return 0;
1039 }  /* end of vmstrnenv */
1040 /*}}}*/
1041
1042 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1043 /* Define as a function so we can access statics. */
1044 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1045 {
1046     int flags = 0;
1047
1048 #if defined(PERL_IMPLICIT_CONTEXT)
1049     if (aTHX != NULL)
1050 #endif
1051 #ifdef SECURE_INTERNAL_GETENV
1052         flags = (PL_curinterp ? TAINTING_get : will_taint) ?
1053                  PERL__TRNENV_SECURE : 0;
1054 #endif
1055
1056     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1057 }
1058 /*}}}*/
1059
1060 /* my_getenv
1061  * Note: Uses Perl temp to store result so char * can be returned to
1062  * caller; this pointer will be invalidated at next Perl statement
1063  * transition.
1064  * We define this as a function rather than a macro in terms of my_getenv_len()
1065  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1066  * allocate SVs).
1067  */
1068 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1069 char *
1070 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1071 {
1072     const char *cp1;
1073     static char *__my_getenv_eqv = NULL;
1074     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1075     unsigned long int idx = 0;
1076     int success, secure, saverr, savvmserr;
1077     int midx, flags;
1078     SV *tmpsv;
1079
1080     midx = my_maxidx(lnm) + 1;
1081
1082     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1083       /* Set up a temporary buffer for the return value; Perl will
1084        * clean it up at the next statement transition */
1085       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1086       if (!tmpsv) return NULL;
1087       eqv = SvPVX(tmpsv);
1088     }
1089     else {
1090       /* Assume no interpreter ==> single thread */
1091       if (__my_getenv_eqv != NULL) {
1092         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1093       }
1094       else {
1095         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1096       }
1097       eqv = __my_getenv_eqv;
1098     }
1099
1100     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1101     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1102       int len;
1103       getcwd(eqv,LNM$C_NAMLENGTH);
1104
1105       len = strlen(eqv);
1106
1107       /* Get rid of "000000/ in rooted filespecs */
1108       if (len > 7) {
1109         char * zeros;
1110         zeros = strstr(eqv, "/000000/");
1111         if (zeros != NULL) {
1112           int mlen;
1113           mlen = len - (zeros - eqv) - 7;
1114           memmove(zeros, &zeros[7], mlen);
1115           len = len - 7;
1116           eqv[len] = '\0';
1117         }
1118       }
1119       return eqv;
1120     }
1121     else {
1122       /* Impose security constraints only if tainting */
1123       if (sys) {
1124         /* Impose security constraints only if tainting */
1125         secure = PL_curinterp ? TAINTING_get : will_taint;
1126         saverr = errno;  savvmserr = vaxc$errno;
1127       }
1128       else {
1129         secure = 0;
1130       }
1131
1132       flags =
1133 #ifdef SECURE_INTERNAL_GETENV
1134               secure ? PERL__TRNENV_SECURE : 0
1135 #else
1136               0
1137 #endif
1138       ;
1139
1140       /* For the getenv interface we combine all the equivalence names
1141        * of a search list logical into one value to acquire a maximum
1142        * value length of 255*128 (assuming %ENV is using logicals).
1143        */
1144       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1145
1146       /* If the name contains a semicolon-delimited index, parse it
1147        * off and make sure we only retrieve the equivalence name for
1148        * that index.  */
1149       if ((cp2 = strchr(lnm,';')) != NULL) {
1150         my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1151         idx = strtoul(cp2+1,NULL,0);
1152         lnm = uplnm;
1153         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1154       }
1155
1156       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1157
1158       /* Discard NOLOGNAM on internal calls since we're often looking
1159        * for an optional name, and this "error" often shows up as the
1160        * (bogus) exit status for a die() call later on.  */
1161       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1162       return success ? eqv : NULL;
1163     }
1164
1165 }  /* end of my_getenv() */
1166 /*}}}*/
1167
1168
1169 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1170 char *
1171 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1172 {
1173     const char *cp1;
1174     char *buf, *cp2;
1175     unsigned long idx = 0;
1176     int midx, flags;
1177     static char *__my_getenv_len_eqv = NULL;
1178     int secure, saverr, savvmserr;
1179     SV *tmpsv;
1180
1181     midx = my_maxidx(lnm) + 1;
1182
1183     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1184       /* Set up a temporary buffer for the return value; Perl will
1185        * clean it up at the next statement transition */
1186       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1187       if (!tmpsv) return NULL;
1188       buf = SvPVX(tmpsv);
1189     }
1190     else {
1191       /* Assume no interpreter ==> single thread */
1192       if (__my_getenv_len_eqv != NULL) {
1193         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1194       }
1195       else {
1196         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1197       }
1198       buf = __my_getenv_len_eqv;
1199     }
1200
1201     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1202     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1203     char * zeros;
1204
1205       getcwd(buf,LNM$C_NAMLENGTH);
1206       *len = strlen(buf);
1207
1208       /* Get rid of "000000/ in rooted filespecs */
1209       if (*len > 7) {
1210       zeros = strstr(buf, "/000000/");
1211       if (zeros != NULL) {
1212         int mlen;
1213         mlen = *len - (zeros - buf) - 7;
1214         memmove(zeros, &zeros[7], mlen);
1215         *len = *len - 7;
1216         buf[*len] = '\0';
1217         }
1218       }
1219       return buf;
1220     }
1221     else {
1222       if (sys) {
1223         /* Impose security constraints only if tainting */
1224         secure = PL_curinterp ? TAINTING_get : will_taint;
1225         saverr = errno;  savvmserr = vaxc$errno;
1226       }
1227       else {
1228         secure = 0;
1229       }
1230
1231       flags =
1232 #ifdef SECURE_INTERNAL_GETENV
1233               secure ? PERL__TRNENV_SECURE : 0
1234 #else
1235               0
1236 #endif
1237       ;
1238
1239       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1240
1241       if ((cp2 = strchr(lnm,';')) != NULL) {
1242         my_strlcpy(buf, lnm, cp2 - lnm + 1);
1243         idx = strtoul(cp2+1,NULL,0);
1244         lnm = buf;
1245         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1246       }
1247
1248       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1249
1250       /* Get rid of "000000/ in rooted filespecs */
1251       if (*len > 7) {
1252       char * zeros;
1253         zeros = strstr(buf, "/000000/");
1254         if (zeros != NULL) {
1255           int mlen;
1256           mlen = *len - (zeros - buf) - 7;
1257           memmove(zeros, &zeros[7], mlen);
1258           *len = *len - 7;
1259           buf[*len] = '\0';
1260         }
1261       }
1262
1263       /* Discard NOLOGNAM on internal calls since we're often looking
1264        * for an optional name, and this "error" often shows up as the
1265        * (bogus) exit status for a die() call later on.  */
1266       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1267       return *len ? buf : NULL;
1268     }
1269
1270 }  /* end of my_getenv_len() */
1271 /*}}}*/
1272
1273 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1274
1275 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1276
1277 /*{{{ void prime_env_iter() */
1278 void
1279 prime_env_iter(void)
1280 /* Fill the %ENV associative array with all logical names we can
1281  * find, in preparation for iterating over it.
1282  */
1283 {
1284   static int primed = 0;
1285   HV *seenhv = NULL, *envhv;
1286   SV *sv = NULL;
1287   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1288   unsigned short int chan;
1289 #ifndef CLI$M_TRUSTED
1290 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1291 #endif
1292   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1293   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1294   long int i;
1295   bool have_sym = FALSE, have_lnm = FALSE;
1296   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1297   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1298   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1299   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1300   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1301 #if defined(PERL_IMPLICIT_CONTEXT)
1302   pTHX;
1303 #endif
1304 #if defined(USE_ITHREADS)
1305   static perl_mutex primenv_mutex;
1306   MUTEX_INIT(&primenv_mutex);
1307 #endif
1308
1309 #if defined(PERL_IMPLICIT_CONTEXT)
1310     /* We jump through these hoops because we can be called at */
1311     /* platform-specific initialization time, which is before anything is */
1312     /* set up--we can't even do a plain dTHX since that relies on the */
1313     /* interpreter structure to be initialized */
1314     if (PL_curinterp) {
1315       aTHX = PERL_GET_INTERP;
1316     } else {
1317       /* we never get here because the NULL pointer will cause the */
1318       /* several of the routines called by this routine to access violate */
1319
1320       /* This routine is only called by hv.c/hv_iterinit which has a */
1321       /* context, so the real fix may be to pass it through instead of */
1322       /* the hoops above */
1323       aTHX = NULL;
1324     }
1325 #endif
1326
1327   if (primed || !PL_envgv) return;
1328   MUTEX_LOCK(&primenv_mutex);
1329   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1330   envhv = GvHVn(PL_envgv);
1331   /* Perform a dummy fetch as an lval to insure that the hash table is
1332    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1333   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1334
1335   for (i = 0; env_tables[i]; i++) {
1336      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1337          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1338      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1339   }
1340   if (have_sym || have_lnm) {
1341     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1342     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1343     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1344     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1345   }
1346
1347   for (i--; i >= 0; i--) {
1348     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1349       char *start;
1350       int j;
1351       for (j = 0; environ[j]; j++) {
1352         if (!(start = strchr(environ[j],'='))) {
1353           if (ckWARN(WARN_INTERNAL))
1354             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1355         }
1356         else {
1357           start++;
1358           sv = newSVpv(start,0);
1359           SvTAINTED_on(sv);
1360           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1361         }
1362       }
1363       continue;
1364     }
1365     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1366              !str$case_blind_compare(&tmpdsc,&clisym)) {
1367       my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1368       cmddsc.dsc$w_length = 20;
1369       if (env_tables[i]->dsc$w_length == 12 &&
1370           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1371           !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local  *", sizeof(cmd)-12);
1372       flags = defflags | CLI$M_NOLOGNAM;
1373     }
1374     else {
1375       my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1376       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1377         my_strlcat(cmd," /Table=", sizeof(cmd));
1378         cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, env_tables[i]->dsc$w_length + 1);
1379       }
1380       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1381       flags = defflags | CLI$M_NOCLISYM;
1382     }
1383
1384     /* Create a new subprocess to execute each command, to exclude the
1385      * remote possibility that someone could subvert a mbx or file used
1386      * to write multiple commands to a single subprocess.
1387      */
1388     do {
1389       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1390                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1391       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1392       defflags &= ~CLI$M_TRUSTED;
1393     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1394     _ckvmssts(retsts);
1395     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1396     if (seenhv) SvREFCNT_dec(seenhv);
1397     seenhv = newHV();
1398     while (1) {
1399       char *cp1, *cp2, *key;
1400       unsigned long int sts, iosb[2], retlen, keylen;
1401       U32 hash;
1402
1403       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1404       if (sts & 1) sts = iosb[0] & 0xffff;
1405       if (sts == SS$_ENDOFFILE) {
1406         int wakect = 0;
1407         while (substs == 0) { sys$hiber(); wakect++;}
1408         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1409         _ckvmssts(substs);
1410         break;
1411       }
1412       _ckvmssts(sts);
1413       retlen = iosb[0] >> 16;
1414       if (!retlen) continue;  /* blank line */
1415       buf[retlen] = '\0';
1416       if (iosb[1] != subpid) {
1417         if (iosb[1]) {
1418           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1419         }
1420         continue;
1421       }
1422       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1423         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1424
1425       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1426       if (*cp1 == '(' || /* Logical name table name */
1427           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1428       if (*cp1 == '"') cp1++;
1429       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1430       key = cp1;  keylen = cp2 - cp1;
1431       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1432       while (*cp2 && *cp2 != '=') cp2++;
1433       while (*cp2 && *cp2 == '=') cp2++;
1434       while (*cp2 && *cp2 == ' ') cp2++;
1435       if (*cp2 == '"') {  /* String translation; may embed "" */
1436         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1437         cp2++;  cp1--; /* Skip "" surrounding translation */
1438       }
1439       else {  /* Numeric translation */
1440         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1441         cp1--;  /* stop on last non-space char */
1442       }
1443       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1444         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1445         continue;
1446       }
1447       PERL_HASH(hash,key,keylen);
1448
1449       if (cp1 == cp2 && *cp2 == '.') {
1450         /* A single dot usually means an unprintable character, such as a null
1451          * to indicate a zero-length value.  Get the actual value to make sure.
1452          */
1453         char lnm[LNM$C_NAMLENGTH+1];
1454         char eqv[MAX_DCL_SYMBOL+1];
1455         int trnlen;
1456         strncpy(lnm, key, keylen);
1457         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1458         sv = newSVpvn(eqv, strlen(eqv));
1459       }
1460       else {
1461         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1462       }
1463
1464       SvTAINTED_on(sv);
1465       hv_store(envhv,key,keylen,sv,hash);
1466       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1467     }
1468     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1469       /* get the PPFs for this process, not the subprocess */
1470       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1471       char eqv[LNM$C_NAMLENGTH+1];
1472       int trnlen, i;
1473       for (i = 0; ppfs[i]; i++) {
1474         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1475         sv = newSVpv(eqv,trnlen);
1476         SvTAINTED_on(sv);
1477         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1478       }
1479     }
1480   }
1481   primed = 1;
1482   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1483   if (buf) Safefree(buf);
1484   if (seenhv) SvREFCNT_dec(seenhv);
1485   MUTEX_UNLOCK(&primenv_mutex);
1486   return;
1487
1488 }  /* end of prime_env_iter */
1489 /*}}}*/
1490
1491
1492 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1493 /* Define or delete an element in the same "environment" as
1494  * vmstrnenv().  If an element is to be deleted, it's removed from
1495  * the first place it's found.  If it's to be set, it's set in the
1496  * place designated by the first element of the table vector.
1497  * Like setenv() returns 0 for success, non-zero on error.
1498  */
1499 int
1500 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1501 {
1502     const char *cp1;
1503     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1504     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1505     int nseg = 0, j;
1506     unsigned long int retsts, usermode = PSL$C_USER;
1507     struct itmlst_3 *ile, *ilist;
1508     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1509                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1510                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1511     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1512     $DESCRIPTOR(local,"_LOCAL");
1513
1514     if (!lnm) {
1515         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1516         return SS$_IVLOGNAM;
1517     }
1518
1519     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1520       *cp2 = _toupper(*cp1);
1521       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1522         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1523         return SS$_IVLOGNAM;
1524       }
1525     }
1526     lnmdsc.dsc$w_length = cp1 - lnm;
1527     if (!tabvec || !*tabvec) tabvec = env_tables;
1528
1529     if (!eqv) {  /* we're deleting n element */
1530       for (curtab = 0; tabvec[curtab]; curtab++) {
1531         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1532         int i;
1533           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1534             if ((cp1 = strchr(environ[i],'=')) &&
1535                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1536                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1537 #ifdef HAS_SETENV
1538               return setenv(lnm,"",1) ? vaxc$errno : 0;
1539             }
1540           }
1541           ivenv = 1; retsts = SS$_NOLOGNAM;
1542 #else
1543               if (ckWARN(WARN_INTERNAL))
1544                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1545               ivenv = 1; retsts = SS$_NOSUCHPGM;
1546               break;
1547             }
1548           }
1549 #endif
1550         }
1551         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1552                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1553           unsigned int symtype;
1554           if (tabvec[curtab]->dsc$w_length == 12 &&
1555               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1556               !str$case_blind_compare(&tmpdsc,&local))
1557             symtype = LIB$K_CLI_LOCAL_SYM;
1558           else symtype = LIB$K_CLI_GLOBAL_SYM;
1559           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1560           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1561           if (retsts == LIB$_NOSUCHSYM) continue;
1562           break;
1563         }
1564         else if (!ivlnm) {
1565           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1566           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1567           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1568           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1569           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1570         }
1571       }
1572     }
1573     else {  /* we're defining a value */
1574       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1575 #ifdef HAS_SETENV
1576         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1577 #else
1578         if (ckWARN(WARN_INTERNAL))
1579           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1580         retsts = SS$_NOSUCHPGM;
1581 #endif
1582       }
1583       else {
1584         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1585         eqvdsc.dsc$w_length  = strlen(eqv);
1586         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1587             !str$case_blind_compare(&tmpdsc,&clisym)) {
1588           unsigned int symtype;
1589           if (tabvec[0]->dsc$w_length == 12 &&
1590               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1591                !str$case_blind_compare(&tmpdsc,&local))
1592             symtype = LIB$K_CLI_LOCAL_SYM;
1593           else symtype = LIB$K_CLI_GLOBAL_SYM;
1594           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1595         }
1596         else {
1597           if (!*eqv) eqvdsc.dsc$w_length = 1;
1598           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1599
1600             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1601             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1602               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1603                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1604               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1605               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1606             }
1607
1608             Newx(ilist,nseg+1,struct itmlst_3);
1609             ile = ilist;
1610             if (!ile) {
1611               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1612               return SS$_INSFMEM;
1613             }
1614             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1615
1616             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1617               ile->itmcode = LNM$_STRING;
1618               ile->bufadr = c;
1619               if ((j+1) == nseg) {
1620                 ile->buflen = strlen(c);
1621                 /* in case we are truncating one that's too long */
1622                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1623               }
1624               else {
1625                 ile->buflen = LNM$C_NAMLENGTH;
1626               }
1627             }
1628
1629             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1630             Safefree (ilist);
1631           }
1632           else {
1633             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1634           }
1635         }
1636       }
1637     }
1638     if (!(retsts & 1)) {
1639       switch (retsts) {
1640         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1641         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1642           set_errno(EVMSERR); break;
1643         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1644         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1645           set_errno(EINVAL); break;
1646         case SS$_NOPRIV:
1647           set_errno(EACCES); break;
1648         default:
1649           _ckvmssts(retsts);
1650           set_errno(EVMSERR);
1651        }
1652        set_vaxc_errno(retsts);
1653        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1654     }
1655     else {
1656       /* We reset error values on success because Perl does an hv_fetch()
1657        * before each hv_store(), and if the thing we're setting didn't
1658        * previously exist, we've got a leftover error message.  (Of course,
1659        * this fails in the face of
1660        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1661        * in that the error reported in $! isn't spurious,
1662        * but it's right more often than not.)
1663        */
1664       set_errno(0); set_vaxc_errno(retsts);
1665       return 0;
1666     }
1667
1668 }  /* end of vmssetenv() */
1669 /*}}}*/
1670
1671 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1672 /* This has to be a function since there's a prototype for it in proto.h */
1673 void
1674 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1675 {
1676     if (lnm && *lnm) {
1677       int len = strlen(lnm);
1678       if  (len == 7) {
1679         char uplnm[8];
1680         int i;
1681         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1682         if (!strcmp(uplnm,"DEFAULT")) {
1683           if (eqv && *eqv) my_chdir(eqv);
1684           return;
1685         }
1686     }
1687   }
1688   (void) vmssetenv(lnm,eqv,NULL);
1689 }
1690 /*}}}*/
1691
1692 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1693 /*  vmssetuserlnm
1694  *  sets a user-mode logical in the process logical name table
1695  *  used for redirection of sys$error
1696  */
1697 void
1698 Perl_vmssetuserlnm(const char *name, const char *eqv)
1699 {
1700     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1701     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1702     unsigned long int iss, attr = LNM$M_CONFINE;
1703     unsigned char acmode = PSL$C_USER;
1704     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1705                                  {0, 0, 0, 0}};
1706     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1707     d_name.dsc$w_length = strlen(name);
1708
1709     lnmlst[0].buflen = strlen(eqv);
1710     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1711
1712     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1713     if (!(iss&1)) lib$signal(iss);
1714 }
1715 /*}}}*/
1716
1717
1718 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1719 /* my_crypt - VMS password hashing
1720  * my_crypt() provides an interface compatible with the Unix crypt()
1721  * C library function, and uses sys$hash_password() to perform VMS
1722  * password hashing.  The quadword hashed password value is returned
1723  * as a NUL-terminated 8 character string.  my_crypt() does not change
1724  * the case of its string arguments; in order to match the behavior
1725  * of LOGINOUT et al., alphabetic characters in both arguments must
1726  *  be upcased by the caller.
1727  *
1728  * - fix me to call ACM services when available
1729  */
1730 char *
1731 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1732 {
1733 #   ifndef UAI$C_PREFERRED_ALGORITHM
1734 #     define UAI$C_PREFERRED_ALGORITHM 127
1735 #   endif
1736     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1737     unsigned short int salt = 0;
1738     unsigned long int sts;
1739     struct const_dsc {
1740         unsigned short int dsc$w_length;
1741         unsigned char      dsc$b_type;
1742         unsigned char      dsc$b_class;
1743         const char *       dsc$a_pointer;
1744     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1745        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1746     struct itmlst_3 uailst[3] = {
1747         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1748         { sizeof salt, UAI$_SALT,    &salt, 0},
1749         { 0,           0,            NULL,  NULL}};
1750     static char hash[9];
1751
1752     usrdsc.dsc$w_length = strlen(usrname);
1753     usrdsc.dsc$a_pointer = usrname;
1754     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1755       switch (sts) {
1756         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1757           set_errno(EACCES);
1758           break;
1759         case RMS$_RNF:
1760           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1761           break;
1762         default:
1763           set_errno(EVMSERR);
1764       }
1765       set_vaxc_errno(sts);
1766       if (sts != RMS$_RNF) return NULL;
1767     }
1768
1769     txtdsc.dsc$w_length = strlen(textpasswd);
1770     txtdsc.dsc$a_pointer = textpasswd;
1771     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1772       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1773     }
1774
1775     return (char *) hash;
1776
1777 }  /* end of my_crypt() */
1778 /*}}}*/
1779
1780
1781 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1782 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1783 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1784
1785 /* fixup barenames that are directories for internal use.
1786  * There have been problems with the consistent handling of UNIX
1787  * style directory names when routines are presented with a name that
1788  * has no directory delimiters at all.  So this routine will eventually
1789  * fix the issue.
1790  */
1791 static char * fixup_bare_dirnames(const char * name)
1792 {
1793   if (decc_disable_to_vms_logname_translation) {
1794 /* fix me */
1795   }
1796   return NULL;
1797 }
1798
1799 /* 8.3, remove() is now broken on symbolic links */
1800 static int rms_erase(const char * vmsname);
1801
1802
1803 /* mp_do_kill_file
1804  * A little hack to get around a bug in some implementation of remove()
1805  * that do not know how to delete a directory
1806  *
1807  * Delete any file to which user has control access, regardless of whether
1808  * delete access is explicitly allowed.
1809  * Limitations: User must have write access to parent directory.
1810  *              Does not block signals or ASTs; if interrupted in midstream
1811  *              may leave file with an altered ACL.
1812  * HANDLE WITH CARE!
1813  */
1814 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1815 static int
1816 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1817 {
1818     char *vmsname;
1819     char *rslt;
1820     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1821     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1822     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1823     struct myacedef {
1824       unsigned char myace$b_length;
1825       unsigned char myace$b_type;
1826       unsigned short int myace$w_flags;
1827       unsigned long int myace$l_access;
1828       unsigned long int myace$l_ident;
1829     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1830                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1831       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1832      struct itmlst_3
1833        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1834                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1835        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1836        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1837        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1838        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1839
1840     /* Expand the input spec using RMS, since the CRTL remove() and
1841      * system services won't do this by themselves, so we may miss
1842      * a file "hiding" behind a logical name or search list. */
1843     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1844     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1845
1846     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1847     if (rslt == NULL) {
1848         PerlMem_free(vmsname);
1849         return -1;
1850       }
1851
1852     /* Erase the file */
1853     rmsts = rms_erase(vmsname);
1854
1855     /* Did it succeed */
1856     if ($VMS_STATUS_SUCCESS(rmsts)) {
1857         PerlMem_free(vmsname);
1858         return 0;
1859       }
1860
1861     /* If not, can changing protections help? */
1862     if (rmsts != RMS$_PRV) {
1863       set_vaxc_errno(rmsts);
1864       PerlMem_free(vmsname);
1865       return -1;
1866     }
1867
1868     /* No, so we get our own UIC to use as a rights identifier,
1869      * and the insert an ACE at the head of the ACL which allows us
1870      * to delete the file.
1871      */
1872     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1873     fildsc.dsc$w_length = strlen(vmsname);
1874     fildsc.dsc$a_pointer = vmsname;
1875     cxt = 0;
1876     newace.myace$l_ident = oldace.myace$l_ident;
1877     rmsts = -1;
1878     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1879       switch (aclsts) {
1880         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1881           set_errno(ENOENT); break;
1882         case RMS$_DIR:
1883           set_errno(ENOTDIR); break;
1884         case RMS$_DEV:
1885           set_errno(ENODEV); break;
1886         case RMS$_SYN: case SS$_INVFILFOROP:
1887           set_errno(EINVAL); break;
1888         case RMS$_PRV:
1889           set_errno(EACCES); break;
1890         default:
1891           _ckvmssts_noperl(aclsts);
1892       }
1893       set_vaxc_errno(aclsts);
1894       PerlMem_free(vmsname);
1895       return -1;
1896     }
1897     /* Grab any existing ACEs with this identifier in case we fail */
1898     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1899     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1900                     || fndsts == SS$_NOMOREACE ) {
1901       /* Add the new ACE . . . */
1902       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1903         goto yourroom;
1904
1905       rmsts = rms_erase(vmsname);
1906       if ($VMS_STATUS_SUCCESS(rmsts)) {
1907         rmsts = 0;
1908         }
1909         else {
1910         rmsts = -1;
1911         /* We blew it - dir with files in it, no write priv for
1912          * parent directory, etc.  Put things back the way they were. */
1913         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1914           goto yourroom;
1915         if (fndsts & 1) {
1916           addlst[0].bufadr = &oldace;
1917           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1918             goto yourroom;
1919         }
1920       }
1921     }
1922
1923     yourroom:
1924     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1925     /* We just deleted it, so of course it's not there.  Some versions of
1926      * VMS seem to return success on the unlock operation anyhow (after all
1927      * the unlock is successful), but others don't.
1928      */
1929     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1930     if (aclsts & 1) aclsts = fndsts;
1931     if (!(aclsts & 1)) {
1932       set_errno(EVMSERR);
1933       set_vaxc_errno(aclsts);
1934     }
1935
1936     PerlMem_free(vmsname);
1937     return rmsts;
1938
1939 }  /* end of kill_file() */
1940 /*}}}*/
1941
1942
1943 /*{{{int do_rmdir(char *name)*/
1944 int
1945 Perl_do_rmdir(pTHX_ const char *name)
1946 {
1947     char * dirfile;
1948     int retval;
1949     Stat_t st;
1950
1951     /* lstat returns a VMS fileified specification of the name */
1952     /* that is looked up, and also lets verifies that this is a directory */
1953
1954     retval = flex_lstat(name, &st);
1955     if (retval != 0) {
1956         char * ret_spec;
1957
1958         /* Due to a historical feature, flex_stat/lstat can not see some */
1959         /* Unix format file names that the rest of the CRTL can see */
1960         /* Fixing that feature will cause some perl tests to fail */
1961         /* So try this one more time. */
1962
1963         retval = lstat(name, &st.crtl_stat);
1964         if (retval != 0)
1965             return -1;
1966
1967         /* force it to a file spec for the kill file to work. */
1968         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1969         if (ret_spec == NULL) {
1970             errno = EIO;
1971             return -1;
1972         }
1973     }
1974
1975     if (!S_ISDIR(st.st_mode)) {
1976         errno = ENOTDIR;
1977         retval = -1;
1978     }
1979     else {
1980         dirfile = st.st_devnam;
1981
1982         /* It may be possible for flex_stat to find a file and vmsify() to */
1983         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
1984         /* with that case, so fail it */
1985         if (dirfile[0] == 0) {
1986             errno = EIO;
1987             return -1;
1988         }
1989
1990         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1991     }
1992
1993     return retval;
1994
1995 }  /* end of do_rmdir */
1996 /*}}}*/
1997
1998 /* kill_file
1999  * Delete any file to which user has control access, regardless of whether
2000  * delete access is explicitly allowed.
2001  * Limitations: User must have write access to parent directory.
2002  *              Does not block signals or ASTs; if interrupted in midstream
2003  *              may leave file with an altered ACL.
2004  * HANDLE WITH CARE!
2005  */
2006 /*{{{int kill_file(char *name)*/
2007 int
2008 Perl_kill_file(pTHX_ const char *name)
2009 {
2010     char * vmsfile;
2011     Stat_t st;
2012     int rmsts;
2013
2014     /* Convert the filename to VMS format and see if it is a directory */
2015     /* flex_lstat returns a vmsified file specification */
2016     rmsts = flex_lstat(name, &st);
2017     if (rmsts != 0) {
2018
2019         /* Due to a historical feature, flex_stat/lstat can not see some */
2020         /* Unix format file names that the rest of the CRTL can see when */
2021         /* ODS-2 file specifications are in use. */
2022         /* Fixing that feature will cause some perl tests to fail */
2023         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2024         st.st_mode = 0;
2025         vmsfile = (char *) name; /* cast ok */
2026
2027     } else {
2028         vmsfile = st.st_devnam;
2029         if (vmsfile[0] == 0) {
2030             /* It may be possible for flex_stat to find a file and vmsify() */
2031             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2032             /* deal with that case, so fail it */
2033             errno = EIO;
2034             return -1;
2035         }
2036     }
2037
2038     /* Remove() is allowed to delete directories, according to the X/Open
2039      * specifications.
2040      * This may need special handling to work with the ACL hacks.
2041      */
2042     if (S_ISDIR(st.st_mode)) {
2043         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2044         return rmsts;
2045     }
2046
2047     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2048
2049     /* Need to delete all versions ? */
2050     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2051         int i = 0;
2052
2053         /* Just use lstat() here as do not need st_dev */
2054         /* and we know that the file is in VMS format or that */
2055         /* because of a historical bug, flex_stat can not see the file */
2056         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2057             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2058             if (rmsts != 0)
2059                 break;
2060             i++;
2061
2062             /* Make sure that we do not loop forever */
2063             if (i > 32767) {
2064                 errno = EIO;
2065                 rmsts = -1;
2066                 break;
2067             }
2068         }
2069     }
2070
2071     return rmsts;
2072
2073 }  /* end of kill_file() */
2074 /*}}}*/
2075
2076
2077 /*{{{int my_mkdir(char *,Mode_t)*/
2078 int
2079 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2080 {
2081   STRLEN dirlen = strlen(dir);
2082
2083   /* zero length string sometimes gives ACCVIO */
2084   if (dirlen == 0) return -1;
2085
2086   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2087    * null file name/type.  However, it's commonplace under Unix,
2088    * so we'll allow it for a gain in portability.
2089    */
2090   if (dir[dirlen-1] == '/') {
2091     char *newdir = savepvn(dir,dirlen-1);
2092     int ret = mkdir(newdir,mode);
2093     Safefree(newdir);
2094     return ret;
2095   }
2096   else return mkdir(dir,mode);
2097 }  /* end of my_mkdir */
2098 /*}}}*/
2099
2100 /*{{{int my_chdir(char *)*/
2101 int
2102 Perl_my_chdir(pTHX_ const char *dir)
2103 {
2104   STRLEN dirlen = strlen(dir);
2105
2106   /* zero length string sometimes gives ACCVIO */
2107   if (dirlen == 0) return -1;
2108   const char *dir1;
2109
2110   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2111    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2112    * so that existing scripts do not need to be changed.
2113    */
2114   dir1 = dir;
2115   while ((dirlen > 0) && (*dir1 == ' ')) {
2116     dir1++;
2117     dirlen--;
2118   }
2119
2120   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2121    * that implies
2122    * null file name/type.  However, it's commonplace under Unix,
2123    * so we'll allow it for a gain in portability.
2124    *
2125    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2126    */
2127   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2128       char *newdir;
2129       int ret;
2130       newdir = (char *)PerlMem_malloc(dirlen);
2131       if (newdir ==NULL)
2132           _ckvmssts_noperl(SS$_INSFMEM);
2133       memcpy(newdir, dir1, dirlen-1);
2134       newdir[dirlen-1] = '\0';
2135       ret = chdir(newdir);
2136       PerlMem_free(newdir);
2137       return ret;
2138   }
2139   else return chdir(dir1);
2140 }  /* end of my_chdir */
2141 /*}}}*/
2142
2143
2144 /*{{{int my_chmod(char *, mode_t)*/
2145 int
2146 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2147 {
2148   Stat_t st;
2149   int ret = -1;
2150   char * changefile;
2151   STRLEN speclen = strlen(file_spec);
2152
2153   /* zero length string sometimes gives ACCVIO */
2154   if (speclen == 0) return -1;
2155
2156   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2157    * that implies null file name/type.  However, it's commonplace under Unix,
2158    * so we'll allow it for a gain in portability.
2159    *
2160    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2161    * in VMS file.dir notation.
2162    */
2163   changefile = (char *) file_spec; /* cast ok */
2164   ret = flex_lstat(file_spec, &st);
2165   if (ret != 0) {
2166
2167         /* Due to a historical feature, flex_stat/lstat can not see some */
2168         /* Unix format file names that the rest of the CRTL can see when */
2169         /* ODS-2 file specifications are in use. */
2170         /* Fixing that feature will cause some perl tests to fail */
2171         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2172         st.st_mode = 0;
2173
2174   } else {
2175       /* It may be possible to get here with nothing in st_devname */
2176       /* chmod still may work though */
2177       if (st.st_devnam[0] != 0) {
2178           changefile = st.st_devnam;
2179       }
2180   }
2181   ret = chmod(changefile, mode);
2182   return ret;
2183 }  /* end of my_chmod */
2184 /*}}}*/
2185
2186
2187 /*{{{FILE *my_tmpfile()*/
2188 FILE *
2189 my_tmpfile(void)
2190 {
2191   FILE *fp;
2192   char *cp;
2193
2194   if ((fp = tmpfile())) return fp;
2195
2196   cp = (char *)PerlMem_malloc(L_tmpnam+24);
2197   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2198
2199   if (decc_filename_unix_only == 0)
2200     strcpy(cp,"Sys$Scratch:");
2201   else
2202     strcpy(cp,"/tmp/");
2203   tmpnam(cp+strlen(cp));
2204   strcat(cp,".Perltmp");
2205   fp = fopen(cp,"w+","fop=dlt");
2206   PerlMem_free(cp);
2207   return fp;
2208 }
2209 /*}}}*/
2210
2211
2212 /*
2213  * The C RTL's sigaction fails to check for invalid signal numbers so we
2214  * help it out a bit.  The docs are correct, but the actual routine doesn't
2215  * do what the docs say it will.
2216  */
2217 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2218 int
2219 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2220                    struct sigaction* oact)
2221 {
2222   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2223         SETERRNO(EINVAL, SS$_INVARG);
2224         return -1;
2225   }
2226   return sigaction(sig, act, oact);
2227 }
2228 /*}}}*/
2229
2230 #ifdef KILL_BY_SIGPRC
2231 #include <errnodef.h>
2232
2233 /* We implement our own kill() using the undocumented system service
2234    sys$sigprc for one of two reasons:
2235
2236    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2237    target process to do a sys$exit, which usually can't be handled
2238    gracefully...certainly not by Perl and the %SIG{} mechanism.
2239
2240    2.) If the kill() in the CRTL can't be called from a signal
2241    handler without disappearing into the ether, i.e., the signal
2242    it purportedly sends is never trapped. Still true as of VMS 7.3.
2243
2244    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2245    in the target process rather than calling sys$exit.
2246
2247    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2248    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2249    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2250    with condition codes C$_SIG0+nsig*8, catching the exception on the
2251    target process and resignaling with appropriate arguments.
2252
2253    But we don't have that VMS 7.0+ exception handler, so if you
2254    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2255
2256    Also note that SIGTERM is listed in the docs as being "unimplemented",
2257    yet always seems to be signaled with a VMS condition code of 4 (and
2258    correctly handled for that code).  So we hardwire it in.
2259
2260    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2261    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2262    than signalling with an unrecognized (and unhandled by CRTL) code.
2263 */
2264
2265 #define _MY_SIG_MAX 28
2266
2267 static unsigned int
2268 Perl_sig_to_vmscondition_int(int sig)
2269 {
2270     static unsigned int sig_code[_MY_SIG_MAX+1] =
2271     {
2272         0,                  /*  0 ZERO     */
2273         SS$_HANGUP,         /*  1 SIGHUP   */
2274         SS$_CONTROLC,       /*  2 SIGINT   */
2275         SS$_CONTROLY,       /*  3 SIGQUIT  */
2276         SS$_RADRMOD,        /*  4 SIGILL   */
2277         SS$_BREAK,          /*  5 SIGTRAP  */
2278         SS$_OPCCUS,         /*  6 SIGABRT  */
2279         SS$_COMPAT,         /*  7 SIGEMT   */
2280 #ifdef __VAX
2281         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2282 #else
2283         SS$_HPARITH,        /*  8 SIGFPE AXP */
2284 #endif
2285         SS$_ABORT,          /*  9 SIGKILL  */
2286         SS$_ACCVIO,         /* 10 SIGBUS   */
2287         SS$_ACCVIO,         /* 11 SIGSEGV  */
2288         SS$_BADPARAM,       /* 12 SIGSYS   */
2289         SS$_NOMBX,          /* 13 SIGPIPE  */
2290         SS$_ASTFLT,         /* 14 SIGALRM  */
2291         4,                  /* 15 SIGTERM  */
2292         0,                  /* 16 SIGUSR1  */
2293         0,                  /* 17 SIGUSR2  */
2294         0,                  /* 18 */
2295         0,                  /* 19 */
2296         0,                  /* 20 SIGCHLD  */
2297         0,                  /* 21 SIGCONT  */
2298         0,                  /* 22 SIGSTOP  */
2299         0,                  /* 23 SIGTSTP  */
2300         0,                  /* 24 SIGTTIN  */
2301         0,                  /* 25 SIGTTOU  */
2302         0,                  /* 26 */
2303         0,                  /* 27 */
2304         0                   /* 28 SIGWINCH  */
2305     };
2306
2307     static int initted = 0;
2308     if (!initted) {
2309         initted = 1;
2310         sig_code[16] = C$_SIGUSR1;
2311         sig_code[17] = C$_SIGUSR2;
2312         sig_code[20] = C$_SIGCHLD;
2313 #if __CRTL_VER >= 70300000
2314         sig_code[28] = C$_SIGWINCH;
2315 #endif
2316     }
2317
2318     if (sig < _SIG_MIN) return 0;
2319     if (sig > _MY_SIG_MAX) return 0;
2320     return sig_code[sig];
2321 }
2322
2323 unsigned int
2324 Perl_sig_to_vmscondition(int sig)
2325 {
2326 #ifdef SS$_DEBUG
2327     if (vms_debug_on_exception != 0)
2328         lib$signal(SS$_DEBUG);
2329 #endif
2330     return Perl_sig_to_vmscondition_int(sig);
2331 }
2332
2333
2334 #define sys$sigprc SYS$SIGPRC
2335 #ifdef __cplusplus
2336 extern "C" {
2337 #endif
2338 int sys$sigprc(unsigned int *pidadr,
2339                struct dsc$descriptor_s *prcname,
2340                unsigned int code);
2341 #ifdef __cplusplus
2342 }
2343 #endif
2344
2345 int
2346 Perl_my_kill(int pid, int sig)
2347 {
2348     int iss;
2349     unsigned int code;
2350
2351      /* sig 0 means validate the PID */
2352     /*------------------------------*/
2353     if (sig == 0) {
2354         const unsigned long int jpicode = JPI$_PID;
2355         pid_t ret_pid;
2356         int status;
2357         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2358         if ($VMS_STATUS_SUCCESS(status))
2359            return 0;
2360         switch (status) {
2361         case SS$_NOSUCHNODE:
2362         case SS$_UNREACHABLE:
2363         case SS$_NONEXPR:
2364            errno = ESRCH;
2365            break;
2366         case SS$_NOPRIV:
2367            errno = EPERM;
2368            break;
2369         default:
2370            errno = EVMSERR;
2371         }
2372         vaxc$errno=status;
2373         return -1;
2374     }
2375
2376     code = Perl_sig_to_vmscondition_int(sig);
2377
2378     if (!code) {
2379         SETERRNO(EINVAL, SS$_BADPARAM);
2380         return -1;
2381     }
2382
2383     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2384      * signals are to be sent to multiple processes.
2385      *  pid = 0 - all processes in group except ones that the system exempts
2386      *  pid = -1 - all processes except ones that the system exempts
2387      *  pid = -n - all processes in group (abs(n)) except ...
2388      * For now, just report as not supported.
2389      */
2390
2391     if (pid <= 0) {
2392         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2393         return -1;
2394     }
2395
2396     iss = sys$sigprc((unsigned int *)&pid,0,code);
2397     if (iss&1) return 0;
2398
2399     switch (iss) {
2400       case SS$_NOPRIV:
2401         set_errno(EPERM);  break;
2402       case SS$_NONEXPR:
2403       case SS$_NOSUCHNODE:
2404       case SS$_UNREACHABLE:
2405         set_errno(ESRCH);  break;
2406       case SS$_INSFMEM:
2407         set_errno(ENOMEM); break;
2408       default:
2409         _ckvmssts_noperl(iss);
2410         set_errno(EVMSERR);
2411     }
2412     set_vaxc_errno(iss);
2413
2414     return -1;
2415 }
2416 #endif
2417
2418 /* Routine to convert a VMS status code to a UNIX status code.
2419 ** More tricky than it appears because of conflicting conventions with
2420 ** existing code.
2421 **
2422 ** VMS status codes are a bit mask, with the least significant bit set for
2423 ** success.
2424 **
2425 ** Special UNIX status of EVMSERR indicates that no translation is currently
2426 ** available, and programs should check the VMS status code.
2427 **
2428 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2429 ** decoding.
2430 */
2431
2432 #ifndef C_FACILITY_NO
2433 #define C_FACILITY_NO 0x350000
2434 #endif
2435 #ifndef DCL_IVVERB
2436 #define DCL_IVVERB 0x38090
2437 #endif
2438
2439 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2440 {
2441 int facility;
2442 int fac_sp;
2443 int msg_no;
2444 int msg_status;
2445 int unix_status;
2446
2447   /* Assume the best or the worst */
2448   if (vms_status & STS$M_SUCCESS)
2449     unix_status = 0;
2450   else
2451     unix_status = EVMSERR;
2452
2453   msg_status = vms_status & ~STS$M_CONTROL;
2454
2455   facility = vms_status & STS$M_FAC_NO;
2456   fac_sp = vms_status & STS$M_FAC_SP;
2457   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2458
2459   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2460     switch(msg_no) {
2461     case SS$_NORMAL:
2462         unix_status = 0;
2463         break;
2464     case SS$_ACCVIO:
2465         unix_status = EFAULT;
2466         break;
2467     case SS$_DEVOFFLINE:
2468         unix_status = EBUSY;
2469         break;
2470     case SS$_CLEARED:
2471         unix_status = ENOTCONN;
2472         break;
2473     case SS$_IVCHAN:
2474     case SS$_IVLOGNAM:
2475     case SS$_BADPARAM:
2476     case SS$_IVLOGTAB:
2477     case SS$_NOLOGNAM:
2478     case SS$_NOLOGTAB:
2479     case SS$_INVFILFOROP:
2480     case SS$_INVARG:
2481     case SS$_NOSUCHID:
2482     case SS$_IVIDENT:
2483         unix_status = EINVAL;
2484         break;
2485     case SS$_UNSUPPORTED:
2486         unix_status = ENOTSUP;
2487         break;
2488     case SS$_FILACCERR:
2489     case SS$_NOGRPPRV:
2490     case SS$_NOSYSPRV:
2491         unix_status = EACCES;
2492         break;
2493     case SS$_DEVICEFULL:
2494         unix_status = ENOSPC;
2495         break;
2496     case SS$_NOSUCHDEV:
2497         unix_status = ENODEV;
2498         break;
2499     case SS$_NOSUCHFILE:
2500     case SS$_NOSUCHOBJECT:
2501         unix_status = ENOENT;
2502         break;
2503     case SS$_ABORT:                                 /* Fatal case */
2504     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2505     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2506         unix_status = EINTR;
2507         break;
2508     case SS$_BUFFEROVF:
2509         unix_status = E2BIG;
2510         break;
2511     case SS$_INSFMEM:
2512         unix_status = ENOMEM;
2513         break;
2514     case SS$_NOPRIV:
2515         unix_status = EPERM;
2516         break;
2517     case SS$_NOSUCHNODE:
2518     case SS$_UNREACHABLE:
2519         unix_status = ESRCH;
2520         break;
2521     case SS$_NONEXPR:
2522         unix_status = ECHILD;
2523         break;
2524     default:
2525         if ((facility == 0) && (msg_no < 8)) {
2526           /* These are not real VMS status codes so assume that they are
2527           ** already UNIX status codes
2528           */
2529           unix_status = msg_no;
2530           break;
2531         }
2532     }
2533   }
2534   else {
2535     /* Translate a POSIX exit code to a UNIX exit code */
2536     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2537         unix_status = (msg_no & 0x07F8) >> 3;
2538     }
2539     else {
2540
2541          /* Documented traditional behavior for handling VMS child exits */
2542         /*--------------------------------------------------------------*/
2543         if (child_flag != 0) {
2544
2545              /* Success / Informational return 0 */
2546             /*----------------------------------*/
2547             if (msg_no & STS$K_SUCCESS)
2548                 return 0;
2549
2550              /* Warning returns 1 */
2551             /*-------------------*/
2552             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2553                 return 1;
2554
2555              /* Everything else pass through the severity bits */
2556             /*------------------------------------------------*/
2557             return (msg_no & STS$M_SEVERITY);
2558         }
2559
2560          /* Normal VMS status to ERRNO mapping attempt */
2561         /*--------------------------------------------*/
2562         switch(msg_status) {
2563         /* case RMS$_EOF: */ /* End of File */
2564         case RMS$_FNF:  /* File Not Found */
2565         case RMS$_DNF:  /* Dir Not Found */
2566                 unix_status = ENOENT;
2567                 break;
2568         case RMS$_RNF:  /* Record Not Found */
2569                 unix_status = ESRCH;
2570                 break;
2571         case RMS$_DIR:
2572                 unix_status = ENOTDIR;
2573                 break;
2574         case RMS$_DEV:
2575                 unix_status = ENODEV;
2576                 break;
2577         case RMS$_IFI:
2578         case RMS$_FAC:
2579         case RMS$_ISI:
2580                 unix_status = EBADF;
2581                 break;
2582         case RMS$_FEX:
2583                 unix_status = EEXIST;
2584                 break;
2585         case RMS$_SYN:
2586         case RMS$_FNM:
2587         case LIB$_INVSTRDES:
2588         case LIB$_INVARG:
2589         case LIB$_NOSUCHSYM:
2590         case LIB$_INVSYMNAM:
2591         case DCL_IVVERB:
2592                 unix_status = EINVAL;
2593                 break;
2594         case CLI$_BUFOVF:
2595         case RMS$_RTB:
2596         case CLI$_TKNOVF:
2597         case CLI$_RSLOVF:
2598                 unix_status = E2BIG;
2599                 break;
2600         case RMS$_PRV:  /* No privilege */
2601         case RMS$_ACC:  /* ACP file access failed */
2602         case RMS$_WLK:  /* Device write locked */
2603                 unix_status = EACCES;
2604                 break;
2605         case RMS$_MKD:  /* Failed to mark for delete */
2606                 unix_status = EPERM;
2607                 break;
2608         /* case RMS$_NMF: */  /* No more files */
2609         }
2610     }
2611   }
2612
2613   return unix_status;
2614 }
2615
2616 /* Try to guess at what VMS error status should go with a UNIX errno
2617  * value.  This is hard to do as there could be many possible VMS
2618  * error statuses that caused the errno value to be set.
2619  */
2620
2621 int Perl_unix_status_to_vms(int unix_status)
2622 {
2623 int test_unix_status;
2624
2625      /* Trivial cases first */
2626     /*---------------------*/
2627     if (unix_status == EVMSERR)
2628         return vaxc$errno;
2629
2630      /* Is vaxc$errno sane? */
2631     /*---------------------*/
2632     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2633     if (test_unix_status == unix_status)
2634         return vaxc$errno;
2635
2636      /* If way out of range, must be VMS code already */
2637     /*-----------------------------------------------*/
2638     if (unix_status > EVMSERR)
2639         return unix_status;
2640
2641      /* If out of range, punt */
2642     /*-----------------------*/
2643     if (unix_status > __ERRNO_MAX)
2644         return SS$_ABORT;
2645
2646
2647      /* Ok, now we have to do it the hard way. */
2648     /*----------------------------------------*/
2649     switch(unix_status) {
2650     case 0:     return SS$_NORMAL;
2651     case EPERM: return SS$_NOPRIV;
2652     case ENOENT: return SS$_NOSUCHOBJECT;
2653     case ESRCH: return SS$_UNREACHABLE;
2654     case EINTR: return SS$_ABORT;
2655     /* case EIO: */
2656     /* case ENXIO:  */
2657     case E2BIG: return SS$_BUFFEROVF;
2658     /* case ENOEXEC */
2659     case EBADF: return RMS$_IFI;
2660     case ECHILD: return SS$_NONEXPR;
2661     /* case EAGAIN */
2662     case ENOMEM: return SS$_INSFMEM;
2663     case EACCES: return SS$_FILACCERR;
2664     case EFAULT: return SS$_ACCVIO;
2665     /* case ENOTBLK */
2666     case EBUSY: return SS$_DEVOFFLINE;
2667     case EEXIST: return RMS$_FEX;
2668     /* case EXDEV */
2669     case ENODEV: return SS$_NOSUCHDEV;
2670     case ENOTDIR: return RMS$_DIR;
2671     /* case EISDIR */
2672     case EINVAL: return SS$_INVARG;
2673     /* case ENFILE */
2674     /* case EMFILE */
2675     /* case ENOTTY */
2676     /* case ETXTBSY */
2677     /* case EFBIG */
2678     case ENOSPC: return SS$_DEVICEFULL;
2679     case ESPIPE: return LIB$_INVARG;
2680     /* case EROFS: */
2681     /* case EMLINK: */
2682     /* case EPIPE: */
2683     /* case EDOM */
2684     case ERANGE: return LIB$_INVARG;
2685     /* case EWOULDBLOCK */
2686     /* case EINPROGRESS */
2687     /* case EALREADY */
2688     /* case ENOTSOCK */
2689     /* case EDESTADDRREQ */
2690     /* case EMSGSIZE */
2691     /* case EPROTOTYPE */
2692     /* case ENOPROTOOPT */
2693     /* case EPROTONOSUPPORT */
2694     /* case ESOCKTNOSUPPORT */
2695     /* case EOPNOTSUPP */
2696     /* case EPFNOSUPPORT */
2697     /* case EAFNOSUPPORT */
2698     /* case EADDRINUSE */
2699     /* case EADDRNOTAVAIL */
2700     /* case ENETDOWN */
2701     /* case ENETUNREACH */
2702     /* case ENETRESET */
2703     /* case ECONNABORTED */
2704     /* case ECONNRESET */
2705     /* case ENOBUFS */
2706     /* case EISCONN */
2707     case ENOTCONN: return SS$_CLEARED;
2708     /* case ESHUTDOWN */
2709     /* case ETOOMANYREFS */
2710     /* case ETIMEDOUT */
2711     /* case ECONNREFUSED */
2712     /* case ELOOP */
2713     /* case ENAMETOOLONG */
2714     /* case EHOSTDOWN */
2715     /* case EHOSTUNREACH */
2716     /* case ENOTEMPTY */
2717     /* case EPROCLIM */
2718     /* case EUSERS  */
2719     /* case EDQUOT  */
2720     /* case ENOMSG  */
2721     /* case EIDRM */
2722     /* case EALIGN */
2723     /* case ESTALE */
2724     /* case EREMOTE */
2725     /* case ENOLCK */
2726     /* case ENOSYS */
2727     /* case EFTYPE */
2728     /* case ECANCELED */
2729     /* case EFAIL */
2730     /* case EINPROG */
2731     case ENOTSUP:
2732         return SS$_UNSUPPORTED;
2733     /* case EDEADLK */
2734     /* case ENWAIT */
2735     /* case EILSEQ */
2736     /* case EBADCAT */
2737     /* case EBADMSG */
2738     /* case EABANDONED */
2739     default:
2740         return SS$_ABORT; /* punt */
2741     }
2742 }
2743
2744
2745 /* default piping mailbox size */
2746 #ifdef __VAX
2747 #  define PERL_BUFSIZ        512
2748 #else
2749 #  define PERL_BUFSIZ        8192
2750 #endif
2751
2752
2753 static void
2754 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2755 {
2756   unsigned long int mbxbufsiz;
2757   static unsigned long int syssize = 0;
2758   unsigned long int dviitm = DVI$_DEVNAM;
2759   char csize[LNM$C_NAMLENGTH+1];
2760   int sts;
2761
2762   if (!syssize) {
2763     unsigned long syiitm = SYI$_MAXBUF;
2764     /*
2765      * Get the SYSGEN parameter MAXBUF
2766      *
2767      * If the logical 'PERL_MBX_SIZE' is defined
2768      * use the value of the logical instead of PERL_BUFSIZ, but
2769      * keep the size between 128 and MAXBUF.
2770      *
2771      */
2772     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2773   }
2774
2775   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2776       mbxbufsiz = atoi(csize);
2777   } else {
2778       mbxbufsiz = PERL_BUFSIZ;
2779   }
2780   if (mbxbufsiz < 128) mbxbufsiz = 128;
2781   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2782
2783   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2784
2785   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2786   _ckvmssts_noperl(sts);
2787   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2788
2789 }  /* end of create_mbx() */
2790
2791
2792 /*{{{  my_popen and my_pclose*/
2793
2794 typedef struct _iosb           IOSB;
2795 typedef struct _iosb*         pIOSB;
2796 typedef struct _pipe           Pipe;
2797 typedef struct _pipe*         pPipe;
2798 typedef struct pipe_details    Info;
2799 typedef struct pipe_details*  pInfo;
2800 typedef struct _srqp            RQE;
2801 typedef struct _srqp*          pRQE;
2802 typedef struct _tochildbuf      CBuf;
2803 typedef struct _tochildbuf*    pCBuf;
2804
2805 struct _iosb {
2806     unsigned short status;
2807     unsigned short count;
2808     unsigned long  dvispec;
2809 };
2810
2811 #pragma member_alignment save
2812 #pragma nomember_alignment quadword
2813 struct _srqp {          /* VMS self-relative queue entry */
2814     unsigned long qptr[2];
2815 };
2816 #pragma member_alignment restore
2817 static RQE  RQE_ZERO = {0,0};
2818
2819 struct _tochildbuf {
2820     RQE             q;
2821     int             eof;
2822     unsigned short  size;
2823     char            *buf;
2824 };
2825
2826 struct _pipe {
2827     RQE            free;
2828     RQE            wait;
2829     int            fd_out;
2830     unsigned short chan_in;
2831     unsigned short chan_out;
2832     char          *buf;
2833     unsigned int   bufsize;
2834     IOSB           iosb;
2835     IOSB           iosb2;
2836     int           *pipe_done;
2837     int            retry;
2838     int            type;
2839     int            shut_on_empty;
2840     int            need_wake;
2841     pPipe         *home;
2842     pInfo          info;
2843     pCBuf          curr;
2844     pCBuf          curr2;
2845 #if defined(PERL_IMPLICIT_CONTEXT)
2846     void            *thx;           /* Either a thread or an interpreter */
2847                                     /* pointer, depending on how we're built */
2848 #endif
2849 };
2850
2851
2852 struct pipe_details
2853 {
2854     pInfo           next;
2855     PerlIO *fp;  /* file pointer to pipe mailbox */
2856     int useFILE; /* using stdio, not perlio */
2857     int pid;   /* PID of subprocess */
2858     int mode;  /* == 'r' if pipe open for reading */
2859     int done;  /* subprocess has completed */
2860     int waiting; /* waiting for completion/closure */
2861     int             closing;        /* my_pclose is closing this pipe */
2862     unsigned long   completion;     /* termination status of subprocess */
2863     pPipe           in;             /* pipe in to sub */
2864     pPipe           out;            /* pipe out of sub */
2865     pPipe           err;            /* pipe of sub's sys$error */
2866     int             in_done;        /* true when in pipe finished */
2867     int             out_done;
2868     int             err_done;
2869     unsigned short  xchan;          /* channel to debug xterm */
2870     unsigned short  xchan_valid;    /* channel is assigned */
2871 };
2872
2873 struct exit_control_block
2874 {
2875     struct exit_control_block *flink;
2876     unsigned long int (*exit_routine)(void);
2877     unsigned long int arg_count;
2878     unsigned long int *status_address;
2879     unsigned long int exit_status;
2880 };
2881
2882 typedef struct _closed_pipes    Xpipe;
2883 typedef struct _closed_pipes*  pXpipe;
2884
2885 struct _closed_pipes {
2886     int             pid;            /* PID of subprocess */
2887     unsigned long   completion;     /* termination status of subprocess */
2888 };
2889 #define NKEEPCLOSED 50
2890 static Xpipe closed_list[NKEEPCLOSED];
2891 static int   closed_index = 0;
2892 static int   closed_num = 0;
2893
2894 #define RETRY_DELAY     "0 ::0.20"
2895 #define MAX_RETRY              50
2896
2897 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2898 static unsigned long mypid;
2899 static unsigned long delaytime[2];
2900
2901 static pInfo open_pipes = NULL;
2902 static $DESCRIPTOR(nl_desc, "NL:");
2903
2904 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2905
2906
2907
2908 static unsigned long int
2909 pipe_exit_routine(void)
2910 {
2911     pInfo info;
2912     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2913     int sts, did_stuff, j;
2914
2915    /*
2916     * Flush any pending i/o, but since we are in process run-down, be
2917     * careful about referencing PerlIO structures that may already have
2918     * been deallocated.  We may not even have an interpreter anymore.
2919     */
2920     info = open_pipes;
2921     while (info) {
2922         if (info->fp) {
2923 #if defined(PERL_IMPLICIT_CONTEXT)
2924            /* We need to use the Perl context of the thread that created */
2925            /* the pipe. */
2926            pTHX;
2927            if (info->err)
2928                aTHX = info->err->thx;
2929            else if (info->out)
2930                aTHX = info->out->thx;
2931            else if (info->in)
2932                aTHX = info->in->thx;
2933 #endif
2934            if (!info->useFILE
2935 #if defined(USE_ITHREADS)
2936              && my_perl
2937 #endif
2938 #ifdef USE_PERLIO
2939              && PL_perlio_fd_refcnt
2940 #endif
2941               )
2942                PerlIO_flush(info->fp);
2943            else
2944                fflush((FILE *)info->fp);
2945         }
2946         info = info->next;
2947     }
2948
2949     /*
2950      next we try sending an EOF...ignore if doesn't work, make sure we
2951      don't hang
2952     */
2953     did_stuff = 0;
2954     info = open_pipes;
2955
2956     while (info) {
2957       _ckvmssts_noperl(sys$setast(0));
2958       if (info->in && !info->in->shut_on_empty) {
2959         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2960                                  0, 0, 0, 0, 0, 0));
2961         info->waiting = 1;
2962         did_stuff = 1;
2963       }
2964       _ckvmssts_noperl(sys$setast(1));
2965       info = info->next;
2966     }
2967
2968     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2969
2970     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2971         int nwait = 0;
2972
2973         info = open_pipes;
2974         while (info) {
2975           _ckvmssts_noperl(sys$setast(0));
2976           if (info->waiting && info->done)
2977                 info->waiting = 0;
2978           nwait += info->waiting;
2979           _ckvmssts_noperl(sys$setast(1));
2980           info = info->next;
2981         }
2982         if (!nwait) break;
2983         sleep(1);
2984     }
2985
2986     did_stuff = 0;
2987     info = open_pipes;
2988     while (info) {
2989       _ckvmssts_noperl(sys$setast(0));
2990       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2991         sts = sys$forcex(&info->pid,0,&abort);
2992         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2993         did_stuff = 1;
2994       }
2995       _ckvmssts_noperl(sys$setast(1));
2996       info = info->next;
2997     }
2998
2999     /* again, wait for effect */
3000
3001     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3002         int nwait = 0;
3003
3004         info = open_pipes;
3005         while (info) {
3006           _ckvmssts_noperl(sys$setast(0));
3007           if (info->waiting && info->done)
3008                 info->waiting = 0;
3009           nwait += info->waiting;
3010           _ckvmssts_noperl(sys$setast(1));
3011           info = info->next;
3012         }
3013         if (!nwait) break;
3014         sleep(1);
3015     }
3016
3017     info = open_pipes;
3018     while (info) {
3019       _ckvmssts_noperl(sys$setast(0));
3020       if (!info->done) {  /* We tried to be nice . . . */
3021         sts = sys$delprc(&info->pid,0);
3022         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3023         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3024       }
3025       _ckvmssts_noperl(sys$setast(1));
3026       info = info->next;
3027     }
3028
3029     while(open_pipes) {
3030
3031 #if defined(PERL_IMPLICIT_CONTEXT)
3032       /* We need to use the Perl context of the thread that created */
3033       /* the pipe. */
3034       pTHX;
3035       if (open_pipes->err)
3036           aTHX = open_pipes->err->thx;
3037       else if (open_pipes->out)
3038           aTHX = open_pipes->out->thx;
3039       else if (open_pipes->in)
3040           aTHX = open_pipes->in->thx;
3041 #endif
3042       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3043       else if (!(sts & 1)) retsts = sts;
3044     }
3045     return retsts;
3046 }
3047
3048 static struct exit_control_block pipe_exitblock =
3049        {(struct exit_control_block *) 0,
3050         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3051
3052 static void pipe_mbxtofd_ast(pPipe p);
3053 static void pipe_tochild1_ast(pPipe p);
3054 static void pipe_tochild2_ast(pPipe p);
3055
3056 static void
3057 popen_completion_ast(pInfo info)
3058 {
3059   pInfo i = open_pipes;
3060   int iss;
3061
3062   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3063   closed_list[closed_index].pid = info->pid;
3064   closed_list[closed_index].completion = info->completion;
3065   closed_index++;
3066   if (closed_index == NKEEPCLOSED)
3067     closed_index = 0;
3068   closed_num++;
3069
3070   while (i) {
3071     if (i == info) break;
3072     i = i->next;
3073   }
3074   if (!i) return;       /* unlinked, probably freed too */
3075
3076   info->done = TRUE;
3077
3078 /*
3079     Writing to subprocess ...
3080             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3081
3082             chan_out may be waiting for "done" flag, or hung waiting
3083             for i/o completion to child...cancel the i/o.  This will
3084             put it into "snarf mode" (done but no EOF yet) that discards
3085             input.
3086
3087     Output from subprocess (stdout, stderr) needs to be flushed and
3088     shut down.   We try sending an EOF, but if the mbx is full the pipe
3089     routine should still catch the "shut_on_empty" flag, telling it to
3090     use immediate-style reads so that "mbx empty" -> EOF.
3091
3092
3093 */
3094   if (info->in && !info->in_done) {               /* only for mode=w */
3095         if (info->in->shut_on_empty && info->in->need_wake) {
3096             info->in->need_wake = FALSE;
3097             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3098         } else {
3099             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3100         }
3101   }
3102
3103   if (info->out && !info->out_done) {             /* were we also piping output? */
3104       info->out->shut_on_empty = TRUE;
3105       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3106       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3107       _ckvmssts_noperl(iss);
3108   }
3109
3110   if (info->err && !info->err_done) {        /* we were piping stderr */
3111         info->err->shut_on_empty = TRUE;
3112         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3113         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3114         _ckvmssts_noperl(iss);
3115   }
3116   _ckvmssts_noperl(sys$setef(pipe_ef));
3117
3118 }
3119
3120 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3121 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3122 static void pipe_infromchild_ast(pPipe p);
3123
3124 /*
3125     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3126     inside an AST routine without worrying about reentrancy and which Perl
3127     memory allocator is being used.
3128
3129     We read data and queue up the buffers, then spit them out one at a
3130     time to the output mailbox when the output mailbox is ready for one.
3131
3132 */
3133 #define INITIAL_TOCHILDQUEUE  2
3134
3135 static pPipe
3136 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3137 {
3138     pPipe p;
3139     pCBuf b;
3140     char mbx1[64], mbx2[64];
3141     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3142                                       DSC$K_CLASS_S, mbx1},
3143                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3144                                       DSC$K_CLASS_S, mbx2};
3145     unsigned int dviitm = DVI$_DEVBUFSIZ;
3146     int j, n;
3147
3148     n = sizeof(Pipe);
3149     _ckvmssts_noperl(lib$get_vm(&n, &p));
3150
3151     create_mbx(&p->chan_in , &d_mbx1);
3152     create_mbx(&p->chan_out, &d_mbx2);
3153     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3154
3155     p->buf           = 0;
3156     p->shut_on_empty = FALSE;
3157     p->need_wake     = FALSE;
3158     p->type          = 0;
3159     p->retry         = 0;
3160     p->iosb.status   = SS$_NORMAL;
3161     p->iosb2.status  = SS$_NORMAL;
3162     p->free          = RQE_ZERO;
3163     p->wait          = RQE_ZERO;
3164     p->curr          = 0;
3165     p->curr2         = 0;
3166     p->info          = 0;
3167 #ifdef PERL_IMPLICIT_CONTEXT
3168     p->thx           = aTHX;
3169 #endif
3170
3171     n = sizeof(CBuf) + p->bufsize;
3172
3173     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3174         _ckvmssts_noperl(lib$get_vm(&n, &b));
3175         b->buf = (char *) b + sizeof(CBuf);
3176         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3177     }
3178
3179     pipe_tochild2_ast(p);
3180     pipe_tochild1_ast(p);
3181     strcpy(wmbx, mbx1);
3182     strcpy(rmbx, mbx2);
3183     return p;
3184 }
3185
3186 /*  reads the MBX Perl is writing, and queues */
3187
3188 static void
3189 pipe_tochild1_ast(pPipe p)
3190 {
3191     pCBuf b = p->curr;
3192     int iss = p->iosb.status;
3193     int eof = (iss == SS$_ENDOFFILE);
3194     int sts;
3195 #ifdef PERL_IMPLICIT_CONTEXT
3196     pTHX = p->thx;
3197 #endif
3198
3199     if (p->retry) {
3200         if (eof) {
3201             p->shut_on_empty = TRUE;
3202             b->eof     = TRUE;
3203             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3204         } else  {
3205             _ckvmssts_noperl(iss);
3206         }
3207
3208         b->eof  = eof;
3209         b->size = p->iosb.count;
3210         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3211         if (p->need_wake) {
3212             p->need_wake = FALSE;
3213             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3214         }
3215     } else {
3216         p->retry = 1;   /* initial call */
3217     }
3218
3219     if (eof) {                  /* flush the free queue, return when done */
3220         int n = sizeof(CBuf) + p->bufsize;
3221         while (1) {
3222             iss = lib$remqti(&p->free, &b);
3223             if (iss == LIB$_QUEWASEMP) return;
3224             _ckvmssts_noperl(iss);
3225             _ckvmssts_noperl(lib$free_vm(&n, &b));
3226         }
3227     }
3228
3229     iss = lib$remqti(&p->free, &b);
3230     if (iss == LIB$_QUEWASEMP) {
3231         int n = sizeof(CBuf) + p->bufsize;
3232         _ckvmssts_noperl(lib$get_vm(&n, &b));
3233         b->buf = (char *) b + sizeof(CBuf);
3234     } else {
3235        _ckvmssts_noperl(iss);
3236     }
3237
3238     p->curr = b;
3239     iss = sys$qio(0,p->chan_in,
3240              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3241              &p->iosb,
3242              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3243     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3244     _ckvmssts_noperl(iss);
3245 }
3246
3247
3248 /* writes queued buffers to output, waits for each to complete before
3249    doing the next */
3250
3251 static void
3252 pipe_tochild2_ast(pPipe p)
3253 {
3254     pCBuf b = p->curr2;
3255     int iss = p->iosb2.status;
3256     int n = sizeof(CBuf) + p->bufsize;
3257     int done = (p->info && p->info->done) ||
3258               iss == SS$_CANCEL || iss == SS$_ABORT;
3259 #if defined(PERL_IMPLICIT_CONTEXT)
3260     pTHX = p->thx;
3261 #endif
3262
3263     do {
3264         if (p->type) {         /* type=1 has old buffer, dispose */
3265             if (p->shut_on_empty) {
3266                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3267             } else {
3268                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3269             }
3270             p->type = 0;
3271         }
3272
3273         iss = lib$remqti(&p->wait, &b);
3274         if (iss == LIB$_QUEWASEMP) {
3275             if (p->shut_on_empty) {
3276                 if (done) {
3277                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3278                     *p->pipe_done = TRUE;
3279                     _ckvmssts_noperl(sys$setef(pipe_ef));
3280                 } else {
3281                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3282                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3283                 }
3284                 return;
3285             }
3286             p->need_wake = TRUE;
3287             return;
3288         }
3289         _ckvmssts_noperl(iss);
3290         p->type = 1;
3291     } while (done);
3292
3293
3294     p->curr2 = b;
3295     if (b->eof) {
3296         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3297             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3298     } else {
3299         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3300             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3301     }
3302
3303     return;
3304
3305 }
3306
3307
3308 static pPipe
3309 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3310 {
3311     pPipe p;
3312     char mbx1[64], mbx2[64];
3313     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3314                                       DSC$K_CLASS_S, mbx1},
3315                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3316                                       DSC$K_CLASS_S, mbx2};
3317     unsigned int dviitm = DVI$_DEVBUFSIZ;
3318
3319     int n = sizeof(Pipe);
3320     _ckvmssts_noperl(lib$get_vm(&n, &p));
3321     create_mbx(&p->chan_in , &d_mbx1);
3322     create_mbx(&p->chan_out, &d_mbx2);
3323
3324     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3325     n = p->bufsize * sizeof(char);
3326     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3327     p->shut_on_empty = FALSE;
3328     p->info   = 0;
3329     p->type   = 0;
3330     p->iosb.status = SS$_NORMAL;
3331 #if defined(PERL_IMPLICIT_CONTEXT)
3332     p->thx = aTHX;
3333 #endif
3334     pipe_infromchild_ast(p);
3335
3336     strcpy(wmbx, mbx1);
3337     strcpy(rmbx, mbx2);
3338     return p;
3339 }
3340
3341 static void
3342 pipe_infromchild_ast(pPipe p)
3343 {
3344     int iss = p->iosb.status;
3345     int eof = (iss == SS$_ENDOFFILE);
3346     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3347     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3348 #if defined(PERL_IMPLICIT_CONTEXT)
3349     pTHX = p->thx;
3350 #endif
3351
3352     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3353         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3354         p->chan_out = 0;
3355     }
3356
3357     /* read completed:
3358             input shutdown if EOF from self (done or shut_on_empty)
3359             output shutdown if closing flag set (my_pclose)
3360             send data/eof from child or eof from self
3361             otherwise, re-read (snarf of data from child)
3362     */
3363
3364     if (p->type == 1) {
3365         p->type = 0;
3366         if (myeof && p->chan_in) {                  /* input shutdown */
3367             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3368             p->chan_in = 0;
3369         }
3370
3371         if (p->chan_out) {
3372             if (myeof || kideof) {      /* pass EOF to parent */
3373                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3374                                          pipe_infromchild_ast, p,
3375                                          0, 0, 0, 0, 0, 0));
3376                 return;
3377             } else if (eof) {       /* eat EOF --- fall through to read*/
3378
3379             } else {                /* transmit data */
3380                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3381                                          pipe_infromchild_ast,p,
3382                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3383                 return;
3384             }
3385         }
3386     }
3387
3388     /*  everything shut? flag as done */
3389
3390     if (!p->chan_in && !p->chan_out) {
3391         *p->pipe_done = TRUE;
3392         _ckvmssts_noperl(sys$setef(pipe_ef));
3393         return;
3394     }
3395
3396     /* write completed (or read, if snarfing from child)
3397             if still have input active,
3398                queue read...immediate mode if shut_on_empty so we get EOF if empty
3399             otherwise,
3400                check if Perl reading, generate EOFs as needed
3401     */
3402
3403     if (p->type == 0) {
3404         p->type = 1;
3405         if (p->chan_in) {
3406             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3407                           pipe_infromchild_ast,p,
3408                           p->buf, p->bufsize, 0, 0, 0, 0);
3409             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3410             _ckvmssts_noperl(iss);
3411         } else {           /* send EOFs for extra reads */
3412             p->iosb.status = SS$_ENDOFFILE;
3413             p->iosb.dvispec = 0;
3414             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3415                                      0, 0, 0,
3416                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3417         }
3418     }
3419 }
3420
3421 static pPipe
3422 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3423 {
3424     pPipe p;
3425     char mbx[64];
3426     unsigned long dviitm = DVI$_DEVBUFSIZ;
3427     struct stat s;
3428     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3429                                       DSC$K_CLASS_S, mbx};
3430     int n = sizeof(Pipe);
3431
3432     /* things like terminals and mbx's don't need this filter */
3433     if (fd && fstat(fd,&s) == 0) {
3434         unsigned long devchar;
3435         char device[65];
3436         unsigned short dev_len;
3437         struct dsc$descriptor_s d_dev;
3438         char * cptr;
3439         struct item_list_3 items[3];
3440         int status;
3441         unsigned short dvi_iosb[4];
3442
3443         cptr = getname(fd, out, 1);
3444         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3445         d_dev.dsc$a_pointer = out;
3446         d_dev.dsc$w_length = strlen(out);
3447         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3448         d_dev.dsc$b_class = DSC$K_CLASS_S;
3449
3450         items[0].len = 4;
3451         items[0].code = DVI$_DEVCHAR;
3452         items[0].bufadr = &devchar;
3453         items[0].retadr = NULL;
3454         items[1].len = 64;
3455         items[1].code = DVI$_FULLDEVNAM;
3456         items[1].bufadr = device;
3457         items[1].retadr = &dev_len;
3458         items[2].len = 0;
3459         items[2].code = 0;
3460
3461         status = sys$getdviw
3462                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3463         _ckvmssts_noperl(status);
3464         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3465             device[dev_len] = 0;
3466
3467             if (!(devchar & DEV$M_DIR)) {
3468                 strcpy(out, device);
3469                 return 0;
3470             }
3471         }
3472     }
3473
3474     _ckvmssts_noperl(lib$get_vm(&n, &p));
3475     p->fd_out = dup(fd);
3476     create_mbx(&p->chan_in, &d_mbx);
3477     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3478     n = (p->bufsize+1) * sizeof(char);
3479     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3480     p->shut_on_empty = FALSE;
3481     p->retry = 0;
3482     p->info  = 0;
3483     strcpy(out, mbx);
3484
3485     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3486                              pipe_mbxtofd_ast, p,
3487                              p->buf, p->bufsize, 0, 0, 0, 0));
3488
3489     return p;
3490 }
3491
3492 static void
3493 pipe_mbxtofd_ast(pPipe p)
3494 {
3495     int iss = p->iosb.status;
3496     int done = p->info->done;
3497     int iss2;
3498     int eof = (iss == SS$_ENDOFFILE);
3499     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3500     int err = !(iss&1) && !eof;
3501 #if defined(PERL_IMPLICIT_CONTEXT)
3502     pTHX = p->thx;
3503 #endif
3504
3505     if (done && myeof) {               /* end piping */
3506         close(p->fd_out);
3507         sys$dassgn(p->chan_in);
3508         *p->pipe_done = TRUE;
3509         _ckvmssts_noperl(sys$setef(pipe_ef));
3510         return;
3511     }
3512
3513     if (!err && !eof) {             /* good data to send to file */
3514         p->buf[p->iosb.count] = '\n';
3515         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3516         if (iss2 < 0) {
3517             p->retry++;
3518             if (p->retry < MAX_RETRY) {
3519                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3520                 return;
3521             }
3522         }
3523         p->retry = 0;
3524     } else if (err) {
3525         _ckvmssts_noperl(iss);
3526     }
3527
3528
3529     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3530           pipe_mbxtofd_ast, p,
3531           p->buf, p->bufsize, 0, 0, 0, 0);
3532     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3533     _ckvmssts_noperl(iss);
3534 }
3535
3536
3537 typedef struct _pipeloc     PLOC;
3538 typedef struct _pipeloc*   pPLOC;
3539
3540 struct _pipeloc {
3541     pPLOC   next;
3542     char    dir[NAM$C_MAXRSS+1];
3543 };
3544 static pPLOC  head_PLOC = 0;
3545
3546 void
3547 free_pipelocs(pTHX_ void *head)
3548 {
3549     pPLOC p, pnext;
3550     pPLOC *pHead = (pPLOC *)head;
3551
3552     p = *pHead;
3553     while (p) {
3554         pnext = p->next;
3555         PerlMem_free(p);
3556         p = pnext;
3557     }
3558     *pHead = 0;
3559 }
3560
3561 static void
3562 store_pipelocs(pTHX)
3563 {
3564     int    i;
3565     pPLOC  p;
3566     AV    *av = 0;
3567     SV    *dirsv;
3568     char  *dir, *x;
3569     char  *unixdir;
3570     char  temp[NAM$C_MAXRSS+1];
3571     STRLEN n_a;
3572
3573     if (head_PLOC)
3574         free_pipelocs(aTHX_ &head_PLOC);
3575
3576 /*  the . directory from @INC comes last */
3577
3578     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3579     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3580     p->next = head_PLOC;
3581     head_PLOC = p;
3582     strcpy(p->dir,"./");
3583
3584 /*  get the directory from $^X */
3585
3586     unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3587     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3588
3589 #ifdef PERL_IMPLICIT_CONTEXT
3590     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3591 #else
3592     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3593 #endif
3594         my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3595         x = strrchr(temp,']');
3596         if (x == NULL) {
3597         x = strrchr(temp,'>');
3598           if (x == NULL) {
3599             /* It could be a UNIX path */
3600             x = strrchr(temp,'/');
3601           }
3602         }
3603         if (x)
3604           x[1] = '\0';
3605         else {
3606           /* Got a bare name, so use default directory */
3607           temp[0] = '.';
3608           temp[1] = '\0';
3609         }
3610
3611         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3612             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3613             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3614             p->next = head_PLOC;
3615             head_PLOC = p;
3616             my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3617         }
3618     }
3619
3620 /*  reverse order of @INC entries, skip "." since entered above */
3621
3622 #ifdef PERL_IMPLICIT_CONTEXT
3623     if (aTHX)
3624 #endif
3625     if (PL_incgv) av = GvAVn(PL_incgv);
3626
3627     for (i = 0; av && i <= AvFILL(av); i++) {
3628         dirsv = *av_fetch(av,i,TRUE);
3629
3630         if (SvROK(dirsv)) continue;
3631         dir = SvPVx(dirsv,n_a);
3632         if (strcmp(dir,".") == 0) continue;
3633         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3634             continue;
3635
3636         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3637         p->next = head_PLOC;
3638         head_PLOC = p;
3639         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3640     }
3641
3642 /* most likely spot (ARCHLIB) put first in the list */
3643
3644 #ifdef ARCHLIB_EXP
3645     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3646         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3647         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3648         p->next = head_PLOC;
3649         head_PLOC = p;
3650         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3651     }
3652 #endif
3653     PerlMem_free(unixdir);
3654 }
3655
3656 static I32
3657 Perl_cando_by_name_int
3658    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3659 #if !defined(PERL_IMPLICIT_CONTEXT)
3660 #define cando_by_name_int               Perl_cando_by_name_int
3661 #else
3662 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3663 #endif
3664
3665 static char *
3666 find_vmspipe(pTHX)
3667 {
3668     static int   vmspipe_file_status = 0;
3669     static char  vmspipe_file[NAM$C_MAXRSS+1];
3670
3671     /* already found? Check and use ... need read+execute permission */
3672
3673     if (vmspipe_file_status == 1) {
3674         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3675          && cando_by_name_int
3676            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3677             return vmspipe_file;
3678         }
3679         vmspipe_file_status = 0;
3680     }
3681
3682     /* scan through stored @INC, $^X */
3683
3684     if (vmspipe_file_status == 0) {
3685         char file[NAM$C_MAXRSS+1];
3686         pPLOC  p = head_PLOC;
3687
3688         while (p) {
3689             char * exp_res;
3690             int dirlen;
3691             dirlen = my_strlcpy(file, p->dir, sizeof(file));
3692             my_strlcat(file, "vmspipe.com", sizeof(file));
3693             p = p->next;
3694
3695             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3696             if (!exp_res) continue;
3697
3698             if (cando_by_name_int
3699                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3700              && cando_by_name_int
3701                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3702                 vmspipe_file_status = 1;
3703                 return vmspipe_file;
3704             }
3705         }
3706         vmspipe_file_status = -1;   /* failed, use tempfiles */
3707     }
3708
3709     return 0;
3710 }
3711
3712 static FILE *
3713 vmspipe_tempfile(pTHX)
3714 {
3715     char file[NAM$C_MAXRSS+1];
3716     FILE *fp;
3717     static int index = 0;
3718     Stat_t s0, s1;
3719     int cmp_result;
3720
3721     /* create a tempfile */
3722
3723     /* we can't go from   W, shr=get to  R, shr=get without
3724        an intermediate vulnerable state, so don't bother trying...
3725
3726        and lib$spawn doesn't shr=put, so have to close the write
3727
3728        So... match up the creation date/time and the FID to
3729        make sure we're dealing with the same file
3730
3731     */
3732
3733     index++;
3734     if (!decc_filename_unix_only) {
3735       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3736       fp = fopen(file,"w");
3737       if (!fp) {
3738         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3739         fp = fopen(file,"w");
3740         if (!fp) {
3741             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3742             fp = fopen(file,"w");
3743         }
3744       }
3745      }
3746      else {
3747       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3748       fp = fopen(file,"w");
3749       if (!fp) {
3750         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3751         fp = fopen(file,"w");
3752         if (!fp) {
3753           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3754           fp = fopen(file,"w");
3755         }
3756       }
3757     }
3758     if (!fp) return 0;  /* we're hosed */
3759
3760     fprintf(fp,"$! 'f$verify(0)'\n");
3761     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3762     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3763     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3764     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3765     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3766     fprintf(fp,"$ perl_del    = \"delete\"\n");
3767     fprintf(fp,"$ pif         = \"if\"\n");
3768     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3769     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3770     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3771     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3772     fprintf(fp,"$!  --- build command line to get max possible length\n");
3773     fprintf(fp,"$c=perl_popen_cmd0\n");
3774     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3775     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3776     fprintf(fp,"$x=perl_popen_cmd3\n");
3777     fprintf(fp,"$c=c+x\n");
3778     fprintf(fp,"$ perl_on\n");
3779     fprintf(fp,"$ 'c'\n");
3780     fprintf(fp,"$ perl_status = $STATUS\n");
3781     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3782     fprintf(fp,"$ perl_exit 'perl_status'\n");
3783     fsync(fileno(fp));
3784
3785     fgetname(fp, file, 1);
3786     fstat(fileno(fp), &s0.crtl_stat);
3787     fclose(fp);
3788
3789     if (decc_filename_unix_only)
3790         int_tounixspec(file, file, NULL);
3791     fp = fopen(file,"r","shr=get");
3792     if (!fp) return 0;
3793     fstat(fileno(fp), &s1.crtl_stat);
3794
3795     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3796     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3797         fclose(fp);
3798         return 0;
3799     }
3800
3801     return fp;
3802 }
3803
3804
3805 static int vms_is_syscommand_xterm(void)
3806 {
3807     const static struct dsc$descriptor_s syscommand_dsc =
3808       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3809
3810     const static struct dsc$descriptor_s decwdisplay_dsc =
3811       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3812
3813     struct item_list_3 items[2];
3814     unsigned short dvi_iosb[4];
3815     unsigned long devchar;
3816     unsigned long devclass;
3817     int status;
3818
3819     /* Very simple check to guess if sys$command is a decterm? */
3820     /* First see if the DECW$DISPLAY: device exists */
3821     items[0].len = 4;
3822     items[0].code = DVI$_DEVCHAR;
3823     items[0].bufadr = &devchar;
3824     items[0].retadr = NULL;
3825     items[1].len = 0;
3826     items[1].code = 0;
3827
3828     status = sys$getdviw
3829         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3830
3831     if ($VMS_STATUS_SUCCESS(status)) {
3832         status = dvi_iosb[0];
3833     }
3834
3835     if (!$VMS_STATUS_SUCCESS(status)) {
3836         SETERRNO(EVMSERR, status);
3837         return -1;
3838     }
3839
3840     /* If it does, then for now assume that we are on a workstation */
3841     /* Now verify that SYS$COMMAND is a terminal */
3842     /* for creating the debugger DECTerm */
3843
3844     items[0].len = 4;
3845     items[0].code = DVI$_DEVCLASS;
3846     items[0].bufadr = &devclass;
3847     items[0].retadr = NULL;
3848     items[1].len = 0;
3849     items[1].code = 0;
3850
3851     status = sys$getdviw
3852         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3853
3854     if ($VMS_STATUS_SUCCESS(status)) {
3855         status = dvi_iosb[0];
3856     }
3857
3858     if (!$VMS_STATUS_SUCCESS(status)) {
3859         SETERRNO(EVMSERR, status);
3860         return -1;
3861     }
3862     else {
3863         if (devclass == DC$_TERM) {
3864             return 0;
3865         }
3866     }
3867     return -1;
3868 }
3869
3870 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3871 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3872 {
3873     int status;
3874     int ret_stat;
3875     char * ret_char;
3876     char device_name[65];
3877     unsigned short device_name_len;
3878     struct dsc$descriptor_s customization_dsc;
3879     struct dsc$descriptor_s device_name_dsc;
3880     const char * cptr;
3881     char customization[200];
3882     char title[40];
3883     pInfo info = NULL;
3884     char mbx1[64];
3885     unsigned short p_chan;
3886     int n;
3887     unsigned short iosb[4];
3888     const char * cust_str =
3889         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3890     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3891                                           DSC$K_CLASS_S, mbx1};
3892
3893      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3894     /*---------------------------------------*/
3895     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3896
3897
3898     /* Make sure that this is from the Perl debugger */
3899     ret_char = strstr(cmd," xterm ");
3900     if (ret_char == NULL)
3901         return NULL;
3902     cptr = ret_char + 7;
3903     ret_char = strstr(cmd,"tty");
3904     if (ret_char == NULL)
3905         return NULL;
3906     ret_char = strstr(cmd,"sleep");
3907     if (ret_char == NULL)
3908         return NULL;
3909
3910     if (decw_term_port == 0) {
3911         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3912         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3913         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3914
3915        status = lib$find_image_symbol
3916                                (&filename1_dsc,
3917                                 &decw_term_port_dsc,
3918                                 (void *)&decw_term_port,
3919                                 NULL,
3920                                 0);
3921
3922         /* Try again with the other image name */
3923         if (!$VMS_STATUS_SUCCESS(status)) {
3924
3925            status = lib$find_image_symbol
3926                                (&filename2_dsc,
3927                                 &decw_term_port_dsc,
3928                                 (void *)&decw_term_port,
3929                                 NULL,
3930                                 0);
3931
3932         }
3933
3934     }
3935
3936
3937     /* No decw$term_port, give it up */
3938     if (!$VMS_STATUS_SUCCESS(status))
3939         return NULL;
3940
3941     /* Are we on a workstation? */
3942     /* to do: capture the rows / columns and pass their properties */
3943     ret_stat = vms_is_syscommand_xterm();
3944     if (ret_stat < 0)
3945         return NULL;
3946
3947     /* Make the title: */
3948     ret_char = strstr(cptr,"-title");
3949     if (ret_char != NULL) {
3950         while ((*cptr != 0) && (*cptr != '\"')) {
3951             cptr++;
3952         }
3953         if (*cptr == '\"')
3954             cptr++;
3955         n = 0;
3956         while ((*cptr != 0) && (*cptr != '\"')) {
3957             title[n] = *cptr;
3958             n++;
3959             if (n == 39) {
3960                 title[39] = 0;
3961                 break;
3962             }
3963             cptr++;
3964         }
3965         title[n] = 0;
3966     }
3967     else {
3968             /* Default title */
3969             strcpy(title,"Perl Debug DECTerm");
3970     }
3971     sprintf(customization, cust_str, title);
3972
3973     customization_dsc.dsc$a_pointer = customization;
3974     customization_dsc.dsc$w_length = strlen(customization);
3975     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3976     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3977
3978     device_name_dsc.dsc$a_pointer = device_name;
3979     device_name_dsc.dsc$w_length = sizeof device_name -1;
3980     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3981     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3982
3983     device_name_len = 0;
3984
3985     /* Try to create the window */
3986      status = (*decw_term_port)
3987        (NULL,
3988         NULL,
3989         &customization_dsc,
3990         &device_name_dsc,
3991         &device_name_len,
3992         NULL,
3993         NULL,
3994         NULL);
3995     if (!$VMS_STATUS_SUCCESS(status)) {
3996         SETERRNO(EVMSERR, status);
3997         return NULL;
3998     }
3999
4000     device_name[device_name_len] = '\0';
4001
4002     /* Need to set this up to look like a pipe for cleanup */
4003     n = sizeof(Info);
4004     status = lib$get_vm(&n, &info);
4005     if (!$VMS_STATUS_SUCCESS(status)) {
4006         SETERRNO(ENOMEM, status);
4007         return NULL;
4008     }
4009
4010     info->mode = *mode;
4011     info->done = FALSE;
4012     info->completion = 0;
4013     info->closing    = FALSE;
4014     info->in         = 0;
4015     info->out        = 0;
4016     info->err        = 0;
4017     info->fp         = NULL;
4018     info->useFILE    = 0;
4019     info->waiting    = 0;
4020     info->in_done    = TRUE;
4021     info->out_done   = TRUE;
4022     info->err_done   = TRUE;
4023
4024     /* Assign a channel on this so that it will persist, and not login */
4025     /* We stash this channel in the info structure for reference. */
4026     /* The created xterm self destructs when the last channel is removed */
4027     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4028     /* So leave this assigned. */
4029     device_name_dsc.dsc$w_length = device_name_len;
4030     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4031     if (!$VMS_STATUS_SUCCESS(status)) {
4032         SETERRNO(EVMSERR, status);
4033         return NULL;
4034     }
4035     info->xchan_valid = 1;
4036
4037     /* Now create a mailbox to be read by the application */
4038
4039     create_mbx(&p_chan, &d_mbx1);
4040
4041     /* write the name of the created terminal to the mailbox */
4042     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4043             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4044
4045     if (!$VMS_STATUS_SUCCESS(status)) {
4046         SETERRNO(EVMSERR, status);
4047         return NULL;
4048     }
4049
4050     info->fp  = PerlIO_open(mbx1, mode);
4051
4052     /* Done with this channel */
4053     sys$dassgn(p_chan);
4054
4055     /* If any errors, then clean up */
4056     if (!info->fp) {
4057         n = sizeof(Info);
4058         _ckvmssts_noperl(lib$free_vm(&n, &info));
4059         return NULL;
4060         }
4061
4062     /* All done */
4063     return info->fp;
4064 }
4065
4066 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4067
4068 static PerlIO *
4069 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4070 {
4071     static int handler_set_up = FALSE;
4072     PerlIO * ret_fp;
4073     unsigned long int sts, flags = CLI$M_NOWAIT;
4074     /* The use of a GLOBAL table (as was done previously) rendered
4075      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4076      * environment.  Hence we've switched to LOCAL symbol table.
4077      */
4078     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4079     int j, wait = 0, n;
4080     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4081     char *in, *out, *err, mbx[512];
4082     FILE *tpipe = 0;
4083     char tfilebuf[NAM$C_MAXRSS+1];
4084     pInfo info = NULL;
4085     char cmd_sym_name[20];
4086     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4087                                       DSC$K_CLASS_S, symbol};
4088     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4089                                       DSC$K_CLASS_S, 0};
4090     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4091                                       DSC$K_CLASS_S, cmd_sym_name};
4092     struct dsc$descriptor_s *vmscmd;
4093     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4094     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4095     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4096
4097     /* Check here for Xterm create request.  This means looking for
4098      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4099      *  is possible to create an xterm.
4100      */
4101     if (*in_mode == 'r') {
4102         PerlIO * xterm_fd;
4103
4104 #if defined(PERL_IMPLICIT_CONTEXT)
4105         /* Can not fork an xterm with a NULL context */
4106         /* This probably could never happen */
4107         xterm_fd = NULL;
4108         if (aTHX != NULL)
4109 #endif
4110         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4111         if (xterm_fd != NULL)
4112             return xterm_fd;
4113     }
4114
4115     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4116
4117     /* once-per-program initialization...
4118        note that the SETAST calls and the dual test of pipe_ef
4119        makes sure that only the FIRST thread through here does
4120        the initialization...all other threads wait until it's
4121        done.
4122
4123        Yeah, uglier than a pthread call, it's got all the stuff inline
4124        rather than in a separate routine.
4125     */
4126
4127     if (!pipe_ef) {
4128         _ckvmssts_noperl(sys$setast(0));
4129         if (!pipe_ef) {
4130             unsigned long int pidcode = JPI$_PID;
4131             $DESCRIPTOR(d_delay, RETRY_DELAY);
4132             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4133             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4134             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4135         }
4136         if (!handler_set_up) {
4137           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4138           handler_set_up = TRUE;
4139         }
4140         _ckvmssts_noperl(sys$setast(1));
4141     }
4142
4143     /* see if we can find a VMSPIPE.COM */
4144
4145     tfilebuf[0] = '@';
4146     vmspipe = find_vmspipe(aTHX);
4147     if (vmspipe) {
4148         vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4149     } else {        /* uh, oh...we're in tempfile hell */
4150         tpipe = vmspipe_tempfile(aTHX);
4151         if (!tpipe) {       /* a fish popular in Boston */
4152             if (ckWARN(WARN_PIPE)) {
4153                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4154             }
4155         return NULL;
4156         }
4157         fgetname(tpipe,tfilebuf+1,1);
4158         vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4159     }
4160     vmspipedsc.dsc$a_pointer = tfilebuf;
4161
4162     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4163     if (!(sts & 1)) {
4164       switch (sts) {
4165         case RMS$_FNF:  case RMS$_DNF:
4166           set_errno(ENOENT); break;
4167         case RMS$_DIR:
4168           set_errno(ENOTDIR); break;
4169         case RMS$_DEV:
4170           set_errno(ENODEV); break;
4171         case RMS$_PRV:
4172           set_errno(EACCES); break;
4173         case RMS$_SYN:
4174           set_errno(EINVAL); break;
4175         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4176           set_errno(E2BIG); break;
4177         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4178           _ckvmssts_noperl(sts); /* fall through */
4179         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4180           set_errno(EVMSERR);
4181       }
4182       set_vaxc_errno(sts);
4183       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4184         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4185       }
4186       *psts = sts;
4187       return NULL;
4188     }
4189     n = sizeof(Info);
4190     _ckvmssts_noperl(lib$get_vm(&n, &info));
4191
4192     my_strlcpy(mode, in_mode, sizeof(mode));
4193     info->mode = *mode;
4194     info->done = FALSE;
4195     info->completion = 0;
4196     info->closing    = FALSE;
4197     info->in         = 0;
4198     info->out        = 0;
4199     info->err        = 0;
4200     info->fp         = NULL;
4201     info->useFILE    = 0;
4202     info->waiting    = 0;
4203     info->in_done    = TRUE;
4204     info->out_done   = TRUE;
4205     info->err_done   = TRUE;
4206     info->xchan      = 0;
4207     info->xchan_valid = 0;
4208
4209     in = (char *)PerlMem_malloc(VMS_MAXRSS);
4210     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4211     out = (char *)PerlMem_malloc(VMS_MAXRSS);
4212     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4213     err = (char *)PerlMem_malloc(VMS_MAXRSS);
4214     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4215
4216     in[0] = out[0] = err[0] = '\0';
4217
4218     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4219         info->useFILE = 1;
4220         strcpy(p,p+1);
4221     }
4222     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4223         wait = 1;
4224         strcpy(p,p+1);
4225     }
4226
4227     if (*mode == 'r') {             /* piping from subroutine */
4228
4229         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4230         if (info->out) {
4231             info->out->pipe_done = &info->out_done;
4232             info->out_done = FALSE;
4233             info->out->info = info;
4234         }
4235         if (!info->useFILE) {
4236             info->fp  = PerlIO_open(mbx, mode);
4237         } else {
4238             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4239             vmssetuserlnm("SYS$INPUT", mbx);
4240         }
4241
4242         if (!info->fp && info->out) {
4243             sys$cancel(info->out->chan_out);
4244
4245             while (!info->out_done) {
4246                 int done;
4247                 _ckvmssts_noperl(sys$setast(0));
4248                 done = info->out_done;
4249                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4250                 _ckvmssts_noperl(sys$setast(1));
4251                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4252             }
4253
4254             if (info->out->buf) {
4255                 n = info->out->bufsize * sizeof(char);
4256                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4257             }
4258             n = sizeof(Pipe);
4259             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4260             n = sizeof(Info);
4261             _ckvmssts_noperl(lib$free_vm(&n, &info));
4262             *psts = RMS$_FNF;
4263             return NULL;
4264         }
4265
4266         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4267         if (info->err) {
4268             info->err->pipe_done = &info->err_done;
4269             info->err_done = FALSE;
4270             info->err->info = info;
4271         }
4272
4273     } else if (*mode == 'w') {      /* piping to subroutine */
4274
4275         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4276         if (info->out) {
4277             info->out->pipe_done = &info->out_done;
4278             info->out_done = FALSE;
4279             info->out->info = info;
4280         }
4281
4282         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4283         if (info->err) {
4284             info->err->pipe_done = &info->err_done;
4285             info->err_done = FALSE;
4286             info->err->info = info;
4287         }
4288
4289         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4290         if (!info->useFILE) {
4291             info->fp  = PerlIO_open(mbx, mode);
4292         } else {
4293             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4294             vmssetuserlnm("SYS$OUTPUT", mbx);
4295         }
4296
4297         if (info->in) {
4298             info->in->pipe_done = &info->in_done;
4299             info->in_done = FALSE;
4300             info->in->info = info;
4301         }
4302
4303         /* error cleanup */
4304         if (!info->fp && info->in) {
4305             info->done = TRUE;
4306             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4307                                       0, 0, 0, 0, 0, 0, 0, 0));
4308
4309             while (!info->in_done) {
4310                 int done;
4311                 _ckvmssts_noperl(sys$setast(0));
4312                 done = info->in_done;
4313                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4314                 _ckvmssts_noperl(sys$setast(1));
4315                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4316             }
4317
4318             if (info->in->buf) {
4319                 n = info->in->bufsize * sizeof(char);
4320                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4321             }
4322             n = sizeof(Pipe);
4323             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4324             n = sizeof(Info);
4325             _ckvmssts_noperl(lib$free_vm(&n, &info));
4326             *psts = RMS$_FNF;
4327             return NULL;
4328         }
4329
4330
4331     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4332         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4333         if (info->out) {
4334             info->out->pipe_done = &info->out_done;
4335             info->out_done = FALSE;
4336             info->out->info = info;
4337         }
4338
4339         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4340         if (info->err) {
4341             info->err->pipe_done = &info->err_done;
4342             info->err_done = FALSE;
4343             info->err->info = info;
4344         }
4345     }
4346
4347     d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4348     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4349
4350     d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4351     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4352
4353     d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4354     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4355
4356     /* Done with the names for the pipes */
4357     PerlMem_free(err);
4358     PerlMem_free(out);
4359     PerlMem_free(in);
4360
4361     p = vmscmd->dsc$a_pointer;
4362     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4363     if (*p == '$') p++;                         /* remove leading $ */
4364     while (*p == ' ' || *p == '\t') p++;
4365
4366     for (j = 0; j < 4; j++) {
4367         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4368         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4369
4370     d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4371     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4372
4373         if (strlen(p) > MAX_DCL_SYMBOL) {
4374             p += MAX_DCL_SYMBOL;
4375         } else {
4376             p += strlen(p);
4377         }
4378     }
4379     _ckvmssts_noperl(sys$setast(0));
4380     info->next=open_pipes;  /* prepend to list */
4381     open_pipes=info;
4382     _ckvmssts_noperl(sys$setast(1));
4383     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4384      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4385      * have SYS$COMMAND if we need it.
4386      */
4387     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4388                       0, &info->pid, &info->completion,
4389                       0, popen_completion_ast,info,0,0,0));
4390
4391     /* if we were using a tempfile, close it now */
4392
4393     if (tpipe) fclose(tpipe);
4394
4395     /* once the subprocess is spawned, it has copied the symbols and
4396        we can get rid of ours */
4397
4398     for (j = 0; j < 4; j++) {
4399         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4400         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4401     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4402     }
4403     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4404     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4405     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4406     vms_execfree(vmscmd);
4407
4408 #ifdef PERL_IMPLICIT_CONTEXT
4409     if (aTHX)
4410 #endif
4411     PL_forkprocess = info->pid;
4412
4413     ret_fp = info->fp;
4414     if (wait) {
4415          dSAVEDERRNO;
4416          int done = 0;
4417          while (!done) {
4418              _ckvmssts_noperl(sys$setast(0));
4419              done = info->done;
4420              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4421              _ckvmssts_noperl(sys$setast(1));
4422              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4423          }
4424         *psts = info->completion;
4425 /* Caller thinks it is open and tries to close it. */
4426 /* This causes some problems, as it changes the error status */
4427 /*        my_pclose(info->fp); */
4428
4429          /* If we did not have a file pointer open, then we have to */
4430          /* clean up here or eventually we will run out of something */
4431          SAVE_ERRNO;
4432          if (info->fp == NULL) {
4433              my_pclose_pinfo(aTHX_ info);
4434          }
4435          RESTORE_ERRNO;
4436
4437     } else {
4438         *psts = info->pid;
4439     }
4440     return ret_fp;
4441 }  /* end of safe_popen */
4442
4443
4444 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4445 PerlIO *
4446 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4447 {
4448     int sts;
4449     TAINT_ENV();
4450     TAINT_PROPER("popen");
4451     PERL_FLUSHALL_FOR_CHILD;
4452     return safe_popen(aTHX_ cmd,mode,&sts);
4453 }
4454
4455 /*}}}*/
4456
4457
4458 /* Routine to close and cleanup a pipe info structure */
4459
4460 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4461
4462     unsigned long int retsts;
4463     int done, n;
4464     pInfo next, last;
4465
4466     /* If we were writing to a subprocess, insure that someone reading from
4467      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4468      * produce an EOF record in the mailbox.
4469      *
4470      *  well, at least sometimes it *does*, so we have to watch out for
4471      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4472      */
4473      if (info->fp) {
4474         if (!info->useFILE
4475 #if defined(USE_ITHREADS)
4476           && my_perl
4477 #endif
4478 #ifdef USE_PERLIO
4479           && PL_perlio_fd_refcnt
4480 #endif
4481            )
4482             PerlIO_flush(info->fp);
4483         else
4484             fflush((FILE *)info->fp);
4485     }
4486
4487     _ckvmssts(sys$setast(0));
4488      info->closing = TRUE;
4489      done = info->done && info->in_done && info->out_done && info->err_done;
4490      /* hanging on write to Perl's input? cancel it */
4491      if (info->mode == 'r' && info->out && !info->out_done) {
4492         if (info->out->chan_out) {
4493             _ckvmssts(sys$cancel(info->out->chan_out));
4494             if (!info->out->chan_in) {   /* EOF generation, need AST */
4495                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4496             }
4497         }
4498      }
4499      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4500          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4501                            0, 0, 0, 0, 0, 0));
4502     _ckvmssts(sys$setast(1));
4503     if (info->fp) {
4504      if (!info->useFILE
4505 #if defined(USE_ITHREADS)
4506          && my_perl
4507 #endif
4508 #ifdef USE_PERLIO
4509          && PL_perlio_fd_refcnt
4510 #endif
4511         )
4512         PerlIO_close(info->fp);
4513      else
4514         fclose((FILE *)info->fp);
4515     }
4516      /*
4517         we have to wait until subprocess completes, but ALSO wait until all
4518         the i/o completes...otherwise we'll be freeing the "info" structure
4519         that the i/o ASTs could still be using...
4520      */
4521
4522      while (!done) {
4523          _ckvmssts(sys$setast(0));
4524          done = info->done && info->in_done && info->out_done && info->err_done;
4525          if (!done) _ckvmssts(sys$clref(pipe_ef));
4526          _ckvmssts(sys$setast(1));
4527          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4528      }
4529      retsts = info->completion;
4530
4531     /* remove from list of open pipes */
4532     _ckvmssts(sys$setast(0));
4533     last = NULL;
4534     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4535         if (next == info)
4536             break;
4537     }
4538
4539     if (last)
4540         last->next = info->next;
4541     else
4542         open_pipes = info->next;
4543     _ckvmssts(sys$setast(1));
4544
4545     /* free buffers and structures */
4546
4547     if (info->in) {
4548         if (info->in->buf) {
4549             n = info->in->bufsize * sizeof(char);
4550             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4551         }
4552         n = sizeof(Pipe);
4553         _ckvmssts(lib$free_vm(&n, &info->in));
4554     }
4555     if (info->out) {
4556         if (info->out->buf) {
4557             n = info->out->bufsize * sizeof(char);
4558             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4559         }
4560         n = sizeof(Pipe);
4561         _ckvmssts(lib$free_vm(&n, &info->out));
4562     }
4563     if (info->err) {
4564         if (info->err->buf) {
4565             n = info->err->bufsize * sizeof(char);
4566             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4567         }
4568         n = sizeof(Pipe);
4569         _ckvmssts(lib$free_vm(&n, &info->err));
4570     }
4571     n = sizeof(Info);
4572     _ckvmssts(lib$free_vm(&n, &info));
4573
4574     return retsts;
4575 }
4576
4577
4578 /*{{{  I32 my_pclose(PerlIO *fp)*/
4579 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4580 {
4581     pInfo info, last = NULL;
4582     I32 ret_status;
4583
4584     /* Fixme - need ast and mutex protection here */
4585     for (info = open_pipes; info != NULL; last = info, info = info->next)
4586         if (info->fp == fp) break;
4587
4588     if (info == NULL) {  /* no such pipe open */
4589       set_errno(ECHILD); /* quoth POSIX */
4590       set_vaxc_errno(SS$_NONEXPR);
4591       return -1;
4592     }
4593
4594     ret_status = my_pclose_pinfo(aTHX_ info);
4595
4596     return ret_status;
4597
4598 }  /* end of my_pclose() */
4599
4600 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4601   /* Roll our own prototype because we want this regardless of whether
4602    * _VMS_WAIT is defined.
4603    */
4604
4605 #ifdef __cplusplus
4606 extern "C" {
4607 #endif
4608   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4609 #ifdef __cplusplus
4610 }
4611 #endif
4612
4613 #endif
4614 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4615    created with popen(); otherwise partially emulate waitpid() unless
4616    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4617    Also check processes not considered by the CRTL waitpid().
4618  */
4619 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4620 Pid_t
4621 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4622 {
4623     pInfo info;
4624     int done;
4625     int sts;
4626     int j;
4627
4628     if (statusp) *statusp = 0;
4629
4630     for (info = open_pipes; info != NULL; info = info->next)
4631         if (info->pid == pid) break;
4632
4633     if (info != NULL) {  /* we know about this child */
4634       while (!info->done) {
4635           _ckvmssts(sys$setast(0));
4636           done = info->done;
4637           if (!done) _ckvmssts(sys$clref(pipe_ef));
4638           _ckvmssts(sys$setast(1));
4639           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4640       }
4641
4642       if (statusp) *statusp = info->completion;
4643       return pid;
4644     }
4645
4646     /* child that already terminated? */
4647
4648     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4649         if (closed_list[j].pid == pid) {
4650             if (statusp) *statusp = closed_list[j].completion;
4651             return pid;
4652         }
4653     }
4654
4655     /* fall through if this child is not one of our own pipe children */
4656
4657 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4658
4659       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4660        * in 7.2 did we get a version that fills in the VMS completion
4661        * status as Perl has always tried to do.
4662        */
4663
4664       sts = __vms_waitpid( pid, statusp, flags );
4665
4666       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4667          return sts;
4668
4669       /* If the real waitpid tells us the child does not exist, we
4670        * fall through here to implement waiting for a child that
4671        * was created by some means other than exec() (say, spawned
4672        * from DCL) or to wait for a process that is not a subprocess
4673        * of the current process.
4674        */
4675
4676 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4677
4678     {
4679       $DESCRIPTOR(intdsc,"0 00:00:01");
4680       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4681       unsigned long int pidcode = JPI$_PID, mypid;
4682       unsigned long int interval[2];
4683       unsigned int jpi_iosb[2];
4684       struct itmlst_3 jpilist[2] = {
4685           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4686           {                      0,         0,                 0, 0}
4687       };
4688
4689       if (pid <= 0) {
4690         /* Sorry folks, we don't presently implement rooting around for
4691            the first child we can find, and we definitely don't want to
4692            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4693          */
4694         set_errno(ENOTSUP);
4695         return -1;
4696       }
4697
4698       /* Get the owner of the child so I can warn if it's not mine. If the
4699        * process doesn't exist or I don't have the privs to look at it,
4700        * I can go home early.
4701        */
4702       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4703       if (sts & 1) sts = jpi_iosb[0];
4704       if (!(sts & 1)) {
4705         switch (sts) {
4706             case SS$_NONEXPR:
4707                 set_errno(ECHILD);
4708                 break;
4709             case SS$_NOPRIV:
4710                 set_errno(EACCES);
4711                 break;
4712             default:
4713                 _ckvmssts(sts);
4714         }
4715         set_vaxc_errno(sts);
4716         return -1;
4717       }
4718
4719       if (ckWARN(WARN_EXEC)) {
4720         /* remind folks they are asking for non-standard waitpid behavior */
4721         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4722         if (ownerpid != mypid)
4723           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4724                       "waitpid: process %x is not a child of process %x",
4725                       pid,mypid);
4726       }
4727
4728       /* simply check on it once a second until it's not there anymore. */
4729
4730       _ckvmssts(sys$bintim(&intdsc,interval));
4731       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4732             _ckvmssts(sys$schdwk(0,0,interval,0));
4733             _ckvmssts(sys$hiber());
4734       }
4735       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4736
4737       _ckvmssts(sts);
4738       return pid;
4739     }
4740 }  /* end of waitpid() */
4741 /*}}}*/
4742 /*}}}*/
4743 /*}}}*/
4744
4745 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4746 char *
4747 my_gconvert(double val, int ndig, int trail, char *buf)
4748 {
4749   static char __gcvtbuf[DBL_DIG+1];
4750   char *loc;
4751
4752   loc = buf ? buf : __gcvtbuf;
4753
4754   if (val) {
4755     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4756     return gcvt(val,ndig,loc);
4757   }
4758   else {
4759     loc[0] = '0'; loc[1] = '\0';
4760     return loc;
4761   }
4762
4763 }
4764 /*}}}*/
4765
4766 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4767 static int rms_free_search_context(struct FAB * fab)
4768 {
4769 struct NAM * nam;
4770
4771     nam = fab->fab$l_nam;
4772     nam->nam$b_nop |= NAM$M_SYNCHK;
4773     nam->nam$l_rlf = NULL;
4774     fab->fab$b_dns = 0;
4775     return sys$parse(fab, NULL, NULL);
4776 }
4777
4778 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4779 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4780 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4781 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4782 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4783 #define rms_nam_esll(nam) nam.nam$b_esl
4784 #define rms_nam_esl(nam) nam.nam$b_esl
4785 #define rms_nam_name(nam) nam.nam$l_name
4786 #define rms_nam_namel(nam) nam.nam$l_name
4787 #define rms_nam_type(nam) nam.nam$l_type
4788 #define rms_nam_typel(nam) nam.nam$l_type
4789 #define rms_nam_ver(nam) nam.nam$l_ver
4790 #define rms_nam_verl(nam) nam.nam$l_ver
4791 #define rms_nam_rsll(nam) nam.nam$b_rsl
4792 #define rms_nam_rsl(nam) nam.nam$b_rsl
4793 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4794 #define rms_set_fna(fab, nam, name, size) \
4795         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4796 #define rms_get_fna(fab, nam) fab.fab$l_fna
4797 #define rms_set_dna(fab, nam, name, size) \
4798         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4799 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4800 #define rms_set_esa(nam, name, size) \
4801         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4802 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4803         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4804 #define rms_set_rsa(nam, name, size) \
4805         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4806 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4807         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4808 #define rms_nam_name_type_l_size(nam) \
4809         (nam.nam$b_name + nam.nam$b_type)
4810 #else
4811 static int rms_free_search_context(struct FAB * fab)
4812 {
4813 struct NAML * nam;
4814
4815     nam = fab->fab$l_naml;
4816     nam->naml$b_nop |= NAM$M_SYNCHK;
4817     nam->naml$l_rlf = NULL;
4818     nam->naml$l_long_defname_size = 0;
4819
4820     fab->fab$b_dns = 0;
4821     return sys$parse(fab, NULL, NULL);
4822 }
4823
4824 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4825 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4826 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4827 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4828 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4829 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4830 #define rms_nam_esl(nam) nam.naml$b_esl
4831 #define rms_nam_name(nam) nam.naml$l_name
4832 #define rms_nam_namel(nam) nam.naml$l_long_name
4833 #define rms_nam_type(nam) nam.naml$l_type
4834 #define rms_nam_typel(nam) nam.naml$l_long_type
4835 #define rms_nam_ver(nam) nam.naml$l_ver
4836 #define rms_nam_verl(nam) nam.naml$l_long_ver
4837 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4838 #define rms_nam_rsl(nam) nam.naml$b_rsl
4839 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4840 #define rms_set_fna(fab, nam, name, size) \
4841         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4842         nam.naml$l_long_filename_size = size; \
4843         nam.naml$l_long_filename = name;}
4844 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4845 #define rms_set_dna(fab, nam, name, size) \
4846         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4847         nam.naml$l_long_defname_size = size; \
4848         nam.naml$l_long_defname = name; }
4849 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4850 #define rms_set_esa(nam, name, size) \
4851         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4852         nam.naml$l_long_expand_alloc = size; \
4853         nam.naml$l_long_expand = name; }
4854 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4855         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4856         nam.naml$l_long_expand = l_name; \
4857         nam.naml$l_long_expand_alloc = l_size; }
4858 #define rms_set_rsa(nam, name, size) \
4859         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4860         nam.naml$l_long_result = name; \
4861         nam.naml$l_long_result_alloc = size; }
4862 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4863         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4864         nam.naml$l_long_result = l_name; \
4865         nam.naml$l_long_result_alloc = l_size; }
4866 #define rms_nam_name_type_l_size(nam) \
4867         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4868 #endif
4869
4870
4871 /* rms_erase
4872  * The CRTL for 8.3 and later can create symbolic links in any mode,
4873  * however in 8.3 the unlink/remove/delete routines will only properly handle
4874  * them if one of the PCP modes is active.
4875  */
4876 static int rms_erase(const char * vmsname)
4877 {
4878   int status;
4879   struct FAB myfab = cc$rms_fab;
4880   rms_setup_nam(mynam);
4881
4882   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4883   rms_bind_fab_nam(myfab, mynam);
4884
4885 #ifdef NAML$M_OPEN_SPECIAL
4886   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4887 #endif
4888
4889   status = sys$erase(&myfab, 0, 0);
4890
4891   return status;
4892 }
4893
4894
4895 static int
4896 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4897                     const struct dsc$descriptor_s * vms_dst_dsc,
4898                     unsigned long flags)
4899 {
4900     /*  VMS and UNIX handle file permissions differently and the
4901      * the same ACL trick may be needed for renaming files,
4902      * especially if they are directories.
4903      */
4904
4905    /* todo: get kill_file and rename to share common code */
4906    /* I can not find online documentation for $change_acl
4907     * it appears to be replaced by $set_security some time ago */
4908
4909 const unsigned int access_mode = 0;
4910 $DESCRIPTOR(obj_file_dsc,"FILE");
4911 char *vmsname;
4912 char *rslt;
4913 unsigned long int jpicode = JPI$_UIC;
4914 int aclsts, fndsts, rnsts = -1;
4915 unsigned int ctx = 0;
4916 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4917 struct dsc$descriptor_s * clean_dsc;
4918
4919 struct myacedef {
4920     unsigned char myace$b_length;
4921     unsigned char myace$b_type;
4922     unsigned short int myace$w_flags;
4923     unsigned long int myace$l_access;
4924     unsigned long int myace$l_ident;
4925 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4926              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4927              0},
4928              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4929
4930 struct item_list_3
4931         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4932                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4933                       {0,0,0,0}},
4934         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4935         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4936                      {0,0,0,0}};
4937
4938
4939     /* Expand the input spec using RMS, since we do not want to put
4940      * ACLs on the target of a symbolic link */
4941     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
4942     if (vmsname == NULL)
4943         return SS$_INSFMEM;
4944
4945     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4946                         vmsname,
4947                         PERL_RMSEXPAND_M_SYMLINK);
4948     if (rslt == NULL) {
4949         PerlMem_free(vmsname);
4950         return SS$_INSFMEM;
4951     }
4952
4953     /* So we get our own UIC to use as a rights identifier,
4954      * and the insert an ACE at the head of the ACL which allows us
4955      * to delete the file.
4956      */
4957     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4958
4959     fildsc.dsc$w_length = strlen(vmsname);
4960     fildsc.dsc$a_pointer = vmsname;
4961     ctx = 0;
4962     newace.myace$l_ident = oldace.myace$l_ident;
4963     rnsts = SS$_ABORT;
4964
4965     /* Grab any existing ACEs with this identifier in case we fail */
4966     clean_dsc = &fildsc;
4967     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4968                                &fildsc,
4969                                NULL,
4970                                OSS$M_WLOCK,
4971                                findlst,
4972                                &ctx,
4973                                &access_mode);
4974
4975     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4976         /* Add the new ACE . . . */
4977
4978         /* if the sys$get_security succeeded, then ctx is valid, and the
4979          * object/file descriptors will be ignored.  But otherwise they
4980          * are needed
4981          */
4982         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4983                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4984         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4985             set_errno(EVMSERR);
4986             set_vaxc_errno(aclsts);
4987             PerlMem_free(vmsname);
4988             return aclsts;
4989         }
4990
4991         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4992                                 NULL, NULL,
4993                                 &flags,
4994                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4995
4996         if ($VMS_STATUS_SUCCESS(rnsts)) {
4997             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4998         }
4999
5000         /* Put things back the way they were. */
5001         ctx = 0;
5002         aclsts = sys$get_security(&obj_file_dsc,
5003                                   clean_dsc,
5004                                   NULL,
5005                                   OSS$M_WLOCK,
5006                                   findlst,
5007                                   &ctx,
5008                                   &access_mode);
5009
5010         if ($VMS_STATUS_SUCCESS(aclsts)) {
5011         int sec_flags;
5012
5013             sec_flags = 0;
5014             if (!$VMS_STATUS_SUCCESS(fndsts))
5015                 sec_flags = OSS$M_RELCTX;
5016
5017             /* Get rid of the new ACE */
5018             aclsts = sys$set_security(NULL, NULL, NULL,
5019                                   sec_flags, dellst, &ctx, &access_mode);
5020
5021             /* If there was an old ACE, put it back */
5022             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5023                 addlst[0].bufadr = &oldace;
5024                 aclsts = sys$set_security(NULL, NULL, NULL,
5025                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5026                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5027                     set_errno(EVMSERR);
5028                     set_vaxc_errno(aclsts);
5029                     rnsts = aclsts;
5030                 }
5031             } else {
5032             int aclsts2;
5033
5034                 /* Try to clear the lock on the ACL list */
5035                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5036                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5037
5038                 /* Rename errors are most important */
5039                 if (!$VMS_STATUS_SUCCESS(rnsts))
5040                     aclsts = rnsts;
5041                 set_errno(EVMSERR);
5042                 set_vaxc_errno(aclsts);
5043                 rnsts = aclsts;
5044             }
5045         }
5046         else {
5047             if (aclsts != SS$_ACLEMPTY)
5048                 rnsts = aclsts;
5049         }
5050     }
5051     else
5052         rnsts = fndsts;
5053
5054     PerlMem_free(vmsname);
5055     return rnsts;
5056 }
5057
5058
5059 /*{{{int rename(const char *, const char * */
5060 /* Not exactly what X/Open says to do, but doing it absolutely right
5061  * and efficiently would require a lot more work.  This should be close
5062  * enough to pass all but the most strict X/Open compliance test.
5063  */
5064 int
5065 Perl_rename(pTHX_ const char *src, const char * dst)
5066 {
5067 int retval;
5068 int pre_delete = 0;
5069 int src_sts;
5070 int dst_sts;
5071 Stat_t src_st;
5072 Stat_t dst_st;
5073
5074     /* Validate the source file */
5075     src_sts = flex_lstat(src, &src_st);
5076     if (src_sts != 0) {
5077
5078         /* No source file or other problem */
5079         return src_sts;
5080     }
5081     if (src_st.st_devnam[0] == 0)  {
5082         /* This may be possible so fail if it is seen. */
5083         errno = EIO;
5084         return -1;
5085     }
5086
5087     dst_sts = flex_lstat(dst, &dst_st);
5088     if (dst_sts == 0) {
5089
5090         if (dst_st.st_dev != src_st.st_dev) {
5091             /* Must be on the same device */
5092             errno = EXDEV;
5093             return -1;
5094         }
5095
5096         /* VMS_INO_T_COMPARE is true if the inodes are different
5097          * to match the output of memcmp
5098          */
5099
5100         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5101             /* That was easy, the files are the same! */
5102             return 0;
5103         }
5104
5105         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5106             /* If source is a directory, so must be dest */
5107                 errno = EISDIR;
5108                 return -1;
5109         }
5110
5111     }
5112
5113
5114     if ((dst_sts == 0) &&
5115         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5116
5117         /* We have issues here if vms_unlink_all_versions is set
5118          * If the destination exists, and is not a directory, then
5119          * we must delete in advance.
5120          *
5121          * If the src is a directory, then we must always pre-delete
5122          * the destination.
5123          *
5124          * If we successfully delete the dst in advance, and the rename fails
5125          * X/Open requires that errno be EIO.
5126          *
5127          */
5128
5129         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5130             int d_sts;
5131             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5132                                      S_ISDIR(dst_st.st_mode));
5133
5134            /* Need to delete all versions ? */
5135            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5136                 int i = 0;
5137
5138                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5139                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5140                     if (d_sts != 0)
5141                         break;
5142                     i++;
5143
5144                     /* Make sure that we do not loop forever */
5145                     if (i > 32767) {
5146                         errno = EIO;
5147                         d_sts = -1;
5148                         break;
5149                     }
5150                 }
5151            }
5152
5153             if (d_sts != 0)
5154                 return d_sts;
5155
5156             /* We killed the destination, so only errno now is EIO */
5157             pre_delete = 1;
5158         }
5159     }
5160
5161     /* Originally the idea was to call the CRTL rename() and only
5162      * try the lib$rename_file if it failed.
5163      * It turns out that there are too many variants in what the
5164      * the CRTL rename might do, so only use lib$rename_file
5165      */
5166     retval = -1;
5167
5168     {
5169         /* Is the source and dest both in VMS format */
5170         /* if the source is a directory, then need to fileify */
5171         /*  and dest must be a directory or non-existent. */
5172
5173         char * vms_dst;
5174         int sts;
5175         char * ret_str;
5176         unsigned long flags;
5177         struct dsc$descriptor_s old_file_dsc;
5178         struct dsc$descriptor_s new_file_dsc;
5179
5180         /* We need to modify the src and dst depending
5181          * on if one or more of them are directories.
5182          */
5183
5184         vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
5185         if (vms_dst == NULL)
5186             _ckvmssts_noperl(SS$_INSFMEM);
5187
5188         if (S_ISDIR(src_st.st_mode)) {
5189         char * ret_str;
5190         char * vms_dir_file;
5191
5192             vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
5193             if (vms_dir_file == NULL)
5194                 _ckvmssts_noperl(SS$_INSFMEM);
5195
5196             /* If the dest is a directory, we must remove it */
5197             if (dst_sts == 0) {
5198                 int d_sts;
5199                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5200                 if (d_sts != 0) {
5201                     PerlMem_free(vms_dst);
5202                     errno = EIO;
5203                     return d_sts;
5204                 }
5205
5206                 pre_delete = 1;
5207             }
5208
5209            /* The dest must be a VMS file specification */
5210            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5211            if (ret_str == NULL) {
5212                 PerlMem_free(vms_dst);
5213                 errno = EIO;
5214                 return -1;
5215            }
5216
5217             /* The source must be a file specification */
5218             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5219             if (ret_str == NULL) {
5220                 PerlMem_free(vms_dst);
5221                 PerlMem_free(vms_dir_file);
5222                 errno = EIO;
5223                 return -1;
5224             }
5225             PerlMem_free(vms_dst);
5226             vms_dst = vms_dir_file;
5227
5228         } else {
5229             /* File to file or file to new dir */
5230
5231             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5232                 /* VMS pathify a dir target */
5233                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5234                 if (ret_str == NULL) {
5235                     PerlMem_free(vms_dst);
5236                     errno = EIO;
5237                     return -1;
5238                 }
5239             } else {
5240                 char * v_spec, * r_spec, * d_spec, * n_spec;
5241                 char * e_spec, * vs_spec;
5242                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5243
5244                 /* fileify a target VMS file specification */
5245                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5246                 if (ret_str == NULL) {
5247                     PerlMem_free(vms_dst);
5248                     errno = EIO;
5249                     return -1;
5250                 }
5251
5252                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5253                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5254                              &e_len, &vs_spec, &vs_len);
5255                 if (sts == 0) {
5256                      if (e_len == 0) {
5257                          /* Get rid of the version */
5258                          if (vs_len != 0) {
5259                              *vs_spec = '\0';
5260                          }
5261                          /* Need to specify a '.' so that the extension */
5262                          /* is not inherited */
5263                          strcat(vms_dst,".");
5264                      }
5265                 }
5266             }
5267         }
5268
5269         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5270         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5271         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5272         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5273
5274         new_file_dsc.dsc$a_pointer = vms_dst;
5275         new_file_dsc.dsc$w_length = strlen(vms_dst);
5276         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5277         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5278
5279         flags = 0;
5280 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5281         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5282 #endif
5283
5284         sts = lib$rename_file(&old_file_dsc,
5285                               &new_file_dsc,
5286                               NULL, NULL,
5287                               &flags,
5288                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5289         if (!$VMS_STATUS_SUCCESS(sts)) {
5290
5291            /* We could have failed because VMS style permissions do not
5292             * permit renames that UNIX will allow.  Just like the hack
5293             * in for kill_file.
5294             */
5295            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5296         }
5297
5298         PerlMem_free(vms_dst);
5299         if (!$VMS_STATUS_SUCCESS(sts)) {
5300             errno = EIO;
5301             return -1;
5302         }
5303         retval = 0;
5304     }
5305
5306     if (vms_unlink_all_versions) {
5307         /* Now get rid of any previous versions of the source file that
5308          * might still exist
5309          */
5310         int i = 0;
5311         dSAVEDERRNO;
5312         SAVE_ERRNO;
5313         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5314                                    S_ISDIR(src_st.st_mode));
5315         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5316              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5317                                        S_ISDIR(src_st.st_mode));
5318              if (src_sts != 0)
5319                  break;
5320              i++;
5321
5322              /* Make sure that we do not loop forever */
5323              if (i > 32767) {
5324                  src_sts = -1;
5325                  break;
5326              }
5327         }
5328         RESTORE_ERRNO;
5329     }
5330
5331     /* We deleted the destination, so must force the error to be EIO */
5332     if ((retval != 0) && (pre_delete != 0))
5333         errno = EIO;
5334
5335     return retval;
5336 }
5337 /*}}}*/
5338
5339
5340 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5341 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5342  * to expand file specification.  Allows for a single default file
5343  * specification and a simple mask of options.  If outbuf is non-NULL,
5344  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5345  * the resultant file specification is placed.  If outbuf is NULL, the
5346  * resultant file specification is placed into a static buffer.
5347  * The third argument, if non-NULL, is taken to be a default file
5348  * specification string.  The fourth argument is unused at present.
5349  * rmesexpand() returns the address of the resultant string if
5350  * successful, and NULL on error.
5351  *
5352  * New functionality for previously unused opts value:
5353  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5354  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5355  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5356  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5357  */
5358 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5359
5360 static char *
5361 int_rmsexpand
5362    (const char *filespec,
5363     char *outbuf,
5364     const char *defspec,
5365     unsigned opts,
5366     int * fs_utf8,
5367     int * dfs_utf8)
5368 {
5369   char * ret_spec;
5370   const char * in_spec;
5371   char * spec_buf;
5372   const char * def_spec;
5373   char * vmsfspec, *vmsdefspec;
5374   char * esa;
5375   char * esal = NULL;
5376   char * outbufl;
5377   struct FAB myfab = cc$rms_fab;
5378   rms_setup_nam(mynam);
5379   STRLEN speclen;
5380   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5381   int sts;
5382
5383   /* temp hack until UTF8 is actually implemented */
5384   if (fs_utf8 != NULL)
5385     *fs_utf8 = 0;
5386
5387   if (!filespec || !*filespec) {
5388     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5389     return NULL;
5390   }
5391
5392   vmsfspec = NULL;
5393   vmsdefspec = NULL;
5394   outbufl = NULL;
5395
5396   in_spec = filespec;
5397   isunix = 0;
5398   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5399       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5400       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5401
5402       /* If this is a UNIX file spec, convert it to VMS */
5403       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5404                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5405                            &e_len, &vs_spec, &vs_len);
5406       if (sts != 0) {
5407           isunix = 1;
5408           char * ret_spec;
5409
5410           vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5411           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5412           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5413           if (ret_spec == NULL) {
5414               PerlMem_free(vmsfspec);
5415               return NULL;
5416           }
5417           in_spec = (const char *)vmsfspec;
5418
5419           /* Unless we are forcing to VMS format, a UNIX input means
5420            * UNIX output, and that requires long names to be used
5421            */
5422           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5423 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5424               opts |= PERL_RMSEXPAND_M_LONG;
5425 #else
5426               NOOP;
5427 #endif
5428           else
5429               isunix = 0;
5430       }
5431
5432   }
5433
5434   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5435   rms_bind_fab_nam(myfab, mynam);
5436
5437   /* Process the default file specification if present */
5438   def_spec = defspec;
5439   if (defspec && *defspec) {
5440     int t_isunix;
5441     t_isunix = is_unix_filespec(defspec);
5442     if (t_isunix) {
5443       vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5444       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5445       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5446
5447       if (ret_spec == NULL) {
5448           /* Clean up and bail */
5449           PerlMem_free(vmsdefspec);
5450           if (vmsfspec != NULL)
5451               PerlMem_free(vmsfspec);
5452               return NULL;
5453           }
5454           def_spec = (const char *)vmsdefspec;
5455       }
5456       rms_set_dna(myfab, mynam,
5457                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5458   }
5459
5460   /* Now we need the expansion buffers */
5461   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
5462   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5463 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5464   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
5465   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5466 #endif
5467   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5468
5469   /* If a NAML block is used RMS always writes to the long and short
5470    * addresses unless you suppress the short name.
5471    */
5472 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5473   outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
5474   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5475 #endif
5476    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5477
5478 #ifdef NAM$M_NO_SHORT_UPCASE
5479   if (decc_efs_case_preserve)
5480     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5481 #endif
5482
5483    /* We may not want to follow symbolic links */
5484 #ifdef NAML$M_OPEN_SPECIAL
5485   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5486     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5487 #endif
5488
5489   /* First attempt to parse as an existing file */
5490   retsts = sys$parse(&myfab,0,0);
5491   if (!(retsts & STS$K_SUCCESS)) {
5492
5493     /* Could not find the file, try as syntax only if error is not fatal */
5494     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5495     if (retsts == RMS$_DNF ||
5496         retsts == RMS$_DIR ||
5497         retsts == RMS$_DEV ||
5498         retsts == RMS$_PRV) {
5499       retsts = sys$parse(&myfab,0,0);
5500       if (retsts & STS$K_SUCCESS) goto int_expanded;
5501     }
5502
5503      /* Still could not parse the file specification */
5504     /*----------------------------------------------*/
5505     sts = rms_free_search_context(&myfab); /* Free search context */
5506     if (vmsdefspec != NULL)
5507         PerlMem_free(vmsdefspec);
5508     if (vmsfspec != NULL)
5509         PerlMem_free(vmsfspec);
5510     if (outbufl != NULL)
5511         PerlMem_free(outbufl);
5512     PerlMem_free(esa);
5513     if (esal != NULL)
5514         PerlMem_free(esal);
5515     set_vaxc_errno(retsts);
5516     if      (retsts == RMS$_PRV) set_errno(EACCES);
5517     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5518     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5519     else                         set_errno(EVMSERR);
5520     return NULL;
5521   }
5522   retsts = sys$search(&myfab,0,0);
5523   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5524     sts = rms_free_search_context(&myfab); /* Free search context */
5525     if (vmsdefspec != NULL)
5526         PerlMem_free(vmsdefspec);
5527     if (vmsfspec != NULL)
5528         PerlMem_free(vmsfspec);
5529     if (outbufl != NULL)
5530         PerlMem_free(outbufl);
5531     PerlMem_free(esa);
5532     if (esal != NULL)
5533         PerlMem_free(esal);
5534     set_vaxc_errno(retsts);
5535     if      (retsts == RMS$_PRV) set_errno(EACCES);
5536     else                         set_errno(EVMSERR);
5537     return NULL;
5538   }
5539
5540   /* If the input filespec contained any lowercase characters,
5541    * downcase the result for compatibility with Unix-minded code. */
5542 int_expanded:
5543   if (!decc_efs_case_preserve) {
5544     char * tbuf;
5545     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5546       if (islower(*tbuf)) { haslower = 1; break; }
5547   }
5548
5549    /* Is a long or a short name expected */
5550   /*------------------------------------*/
5551   spec_buf = NULL;
5552 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5553   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5554     if (rms_nam_rsll(mynam)) {
5555         spec_buf = outbufl;
5556         speclen = rms_nam_rsll(mynam);
5557     }
5558     else {
5559         spec_buf = esal; /* Not esa */
5560         speclen = rms_nam_esll(mynam);
5561     }
5562   }
5563   else {
5564 #endif
5565     if (rms_nam_rsl(mynam)) {
5566         spec_buf = outbuf;
5567         speclen = rms_nam_rsl(mynam);
5568     }
5569     else {
5570         spec_buf = esa; /* Not esal */
5571         speclen = rms_nam_esl(mynam);
5572     }
5573 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5574   }
5575 #endif
5576   spec_buf[speclen] = '\0';
5577
5578   /* Trim off null fields added by $PARSE
5579    * If type > 1 char, must have been specified in original or default spec
5580    * (not true for version; $SEARCH may have added version of existing file).
5581    */
5582   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5583   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5584     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5585              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5586   }
5587   else {
5588     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5589              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5590   }
5591   if (trimver || trimtype) {
5592     if (defspec && *defspec) {
5593       char *defesal = NULL;
5594       char *defesa = NULL;
5595       defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5596       if (defesa != NULL) {
5597         struct FAB deffab = cc$rms_fab;
5598 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5599         defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5600         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5601 #endif
5602         rms_setup_nam(defnam);
5603
5604         rms_bind_fab_nam(deffab, defnam);
5605
5606         /* Cast ok */
5607         rms_set_fna
5608             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5609
5610         /* RMS needs the esa/esal as a work area if wildcards are involved */
5611         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5612
5613         rms_clear_nam_nop(defnam);
5614         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5615 #ifdef NAM$M_NO_SHORT_UPCASE
5616         if (decc_efs_case_preserve)
5617           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5618 #endif
5619 #ifdef NAML$M_OPEN_SPECIAL
5620         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5621           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5622 #endif
5623         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5624           if (trimver) {
5625              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5626           }
5627           if (trimtype) {
5628             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5629           }
5630         }
5631         if (defesal != NULL)
5632             PerlMem_free(defesal);
5633         PerlMem_free(defesa);
5634       } else {
5635           _ckvmssts_noperl(SS$_INSFMEM);
5636       }
5637     }
5638     if (trimver) {
5639       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5640         if (*(rms_nam_verl(mynam)) != '\"')
5641           speclen = rms_nam_verl(mynam) - spec_buf;
5642       }
5643       else {
5644         if (*(rms_nam_ver(mynam)) != '\"')
5645           speclen = rms_nam_ver(mynam) - spec_buf;
5646       }
5647     }
5648     if (trimtype) {
5649       /* If we didn't already trim version, copy down */
5650       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5651         if (speclen > rms_nam_verl(mynam) - spec_buf)
5652           memmove
5653            (rms_nam_typel(mynam),
5654             rms_nam_verl(mynam),
5655             speclen - (rms_nam_verl(mynam) - spec_buf));
5656           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5657       }
5658       else {
5659         if (speclen > rms_nam_ver(mynam) - spec_buf)
5660           memmove
5661            (rms_nam_type(mynam),
5662             rms_nam_ver(mynam),
5663             speclen - (rms_nam_ver(mynam) - spec_buf));
5664           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5665       }
5666     }
5667   }
5668
5669    /* Done with these copies of the input files */
5670   /*-------------------------------------------*/
5671   if (vmsfspec != NULL)
5672         PerlMem_free(vmsfspec);
5673   if (vmsdefspec != NULL)
5674         PerlMem_free(vmsdefspec);
5675
5676   /* If we just had a directory spec on input, $PARSE "helpfully"
5677    * adds an empty name and type for us */
5678 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5679   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5680     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5681         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5682         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5683       speclen = rms_nam_namel(mynam) - spec_buf;
5684   }
5685   else
5686 #endif
5687   {
5688     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5689         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5690         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5691       speclen = rms_nam_name(mynam) - spec_buf;
5692   }
5693
5694   /* Posix format specifications must have matching quotes */
5695   if (speclen < (VMS_MAXRSS - 1)) {
5696     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5697       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5698         spec_buf[speclen] = '\"';
5699         speclen++;
5700       }
5701     }
5702   }
5703   spec_buf[speclen] = '\0';
5704   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5705
5706   /* Have we been working with an expanded, but not resultant, spec? */
5707   /* Also, convert back to Unix syntax if necessary. */
5708   {
5709   int rsl;
5710
5711 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5712     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5713       rsl = rms_nam_rsll(mynam);
5714     } else
5715 #endif
5716     {
5717       rsl = rms_nam_rsl(mynam);
5718     }
5719     if (!rsl) {
5720       /* rsl is not present, it means that spec_buf is either */
5721       /* esa or esal, and needs to be copied to outbuf */
5722       /* convert to Unix if desired */
5723       if (isunix) {
5724         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5725       } else {
5726         /* VMS file specs are not in UTF-8 */
5727         if (fs_utf8 != NULL)
5728             *fs_utf8 = 0;
5729         my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5730         ret_spec = outbuf;
5731       }
5732     }
5733     else {
5734       /* Now spec_buf is either outbuf or outbufl */
5735       /* We need the result into outbuf */
5736       if (isunix) {
5737            /* If we need this in UNIX, then we need another buffer */
5738            /* to keep things in order */
5739            char * src;
5740            char * new_src = NULL;
5741            if (spec_buf == outbuf) {
5742                new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
5743                my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5744            } else {
5745                src = spec_buf;
5746            }
5747            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5748            if (new_src) {
5749                PerlMem_free(new_src);
5750            }
5751       } else {
5752            /* VMS file specs are not in UTF-8 */
5753            if (fs_utf8 != NULL)
5754                *fs_utf8 = 0;
5755
5756            /* Copy the buffer if needed */
5757            if (outbuf != spec_buf)
5758                my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5759            ret_spec = outbuf;
5760       }
5761     }
5762   }
5763
5764   /* Need to clean up the search context */
5765   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5766   sts = rms_free_search_context(&myfab); /* Free search context */
5767
5768   /* Clean up the extra buffers */
5769   if (esal != NULL)
5770       PerlMem_free(esal);
5771   PerlMem_free(esa);
5772   if (outbufl != NULL)
5773      PerlMem_free(outbufl);
5774
5775   /* Return the result */
5776   return ret_spec;
5777 }
5778
5779 /* Common simple case - Expand an already VMS spec */
5780 static char *
5781 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5782     opts |= PERL_RMSEXPAND_M_VMS_IN;
5783     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5784 }
5785
5786 /* Common simple case - Expand to a VMS spec */
5787 static char *
5788 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5789     opts |= PERL_RMSEXPAND_M_VMS;
5790     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5791 }
5792
5793
5794 /* Entry point used by perl routines */
5795 static char *
5796 mp_do_rmsexpand
5797    (pTHX_ const char *filespec,
5798     char *outbuf,
5799     int ts,
5800     const char *defspec,
5801     unsigned opts,
5802     int * fs_utf8,
5803     int * dfs_utf8)
5804 {
5805     static char __rmsexpand_retbuf[VMS_MAXRSS];
5806     char * expanded, *ret_spec, *ret_buf;
5807
5808     expanded = NULL;
5809     ret_buf = outbuf;
5810     if (ret_buf == NULL) {
5811         if (ts) {
5812             Newx(expanded, VMS_MAXRSS, char);
5813             if (expanded == NULL)
5814                 _ckvmssts(SS$_INSFMEM);
5815             ret_buf = expanded;
5816         } else {
5817             ret_buf = __rmsexpand_retbuf;
5818         }
5819     }
5820
5821
5822     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5823                              opts, fs_utf8,  dfs_utf8);
5824
5825     if (ret_spec == NULL) {
5826        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5827        if (expanded)
5828            Safefree(expanded);
5829     }
5830
5831     return ret_spec;
5832 }
5833 /*}}}*/
5834 /* External entry points */
5835 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5836 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5837 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5838 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5839 char *Perl_rmsexpand_utf8
5840   (pTHX_ const char *spec, char *buf, const char *def,
5841    unsigned opt, int * fs_utf8, int * dfs_utf8)
5842 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5843 char *Perl_rmsexpand_utf8_ts
5844   (pTHX_ const char *spec, char *buf, const char *def,
5845    unsigned opt, int * fs_utf8, int * dfs_utf8)
5846 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5847
5848
5849 /*
5850 ** The following routines are provided to make life easier when
5851 ** converting among VMS-style and Unix-style directory specifications.
5852 ** All will take input specifications in either VMS or Unix syntax. On
5853 ** failure, all return NULL.  If successful, the routines listed below
5854 ** return a pointer to a buffer containing the appropriately
5855 ** reformatted spec (and, therefore, subsequent calls to that routine
5856 ** will clobber the result), while the routines of the same names with
5857 ** a _ts suffix appended will return a pointer to a mallocd string
5858 ** containing the appropriately reformatted spec.
5859 ** In all cases, only explicit syntax is altered; no check is made that
5860 ** the resulting string is valid or that the directory in question
5861 ** actually exists.
5862 **
5863 **   fileify_dirspec() - convert a directory spec into the name of the
5864 **     directory file (i.e. what you can stat() to see if it's a dir).
5865 **     The style (VMS or Unix) of the result is the same as the style
5866 **     of the parameter passed in.
5867 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5868 **     what you prepend to a filename to indicate what directory it's in).
5869 **     The style (VMS or Unix) of the result is the same as the style
5870 **     of the parameter passed in.
5871 **   tounixpath() - convert a directory spec into a Unix-style path.
5872 **   tovmspath() - convert a directory spec into a VMS-style path.
5873 **   tounixspec() - convert any file spec into a Unix-style file spec.
5874 **   tovmsspec() - convert any file spec into a VMS-style spec.
5875 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5876 **
5877 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5878 ** Permission is given to distribute this code as part of the Perl
5879 ** standard distribution under the terms of the GNU General Public
5880 ** License or the Perl Artistic License.  Copies of each may be
5881 ** found in the Perl standard distribution.
5882  */
5883
5884 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5885 static char *
5886 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5887 {
5888     unsigned long int dirlen, retlen, hasfilename = 0;
5889     char *cp1, *cp2, *lastdir;
5890     char *trndir, *vmsdir;
5891     unsigned short int trnlnm_iter_count;
5892     int sts;
5893     if (utf8_fl != NULL)
5894         *utf8_fl = 0;
5895
5896     if (!dir || !*dir) {
5897       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5898     }
5899     dirlen = strlen(dir);
5900     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5901     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5902       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5903         dir = "/sys$disk";
5904         dirlen = 9;
5905       }
5906       else
5907         dirlen = 1;
5908     }
5909     if (dirlen > (VMS_MAXRSS - 1)) {
5910       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5911       return NULL;
5912     }
5913     trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5914     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5915     if (!strpbrk(dir+1,"/]>:")  &&
5916         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5917       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5918       trnlnm_iter_count = 0;
5919       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
5920         trnlnm_iter_count++;
5921         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5922       }
5923       dirlen = strlen(trndir);
5924     }
5925     else {
5926       memcpy(trndir, dir, dirlen);
5927       trndir[dirlen] = '\0';
5928     }
5929
5930     /* At this point we are done with *dir and use *trndir which is a
5931      * copy that can be modified.  *dir must not be modified.
5932      */
5933
5934     /* If we were handed a rooted logical name or spec, treat it like a
5935      * simple directory, so that
5936      *    $ Define myroot dev:[dir.]
5937      *    ... do_fileify_dirspec("myroot",buf,1) ...
5938      * does something useful.
5939      */
5940     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5941       trndir[--dirlen] = '\0';
5942       trndir[dirlen-1] = ']';
5943     }
5944     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5945       trndir[--dirlen] = '\0';
5946       trndir[dirlen-1] = '>';
5947     }
5948
5949     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5950       /* If we've got an explicit filename, we can just shuffle the string. */
5951       if (*(cp1+1)) hasfilename = 1;
5952       /* Similarly, we can just back up a level if we've got multiple levels
5953          of explicit directories in a VMS spec which ends with directories. */
5954       else {
5955         for (cp2 = cp1; cp2 > trndir; cp2--) {
5956           if (*cp2 == '.') {
5957             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5958 /* fix-me, can not scan EFS file specs backward like this */
5959               *cp2 = *cp1; *cp1 = '\0';
5960               hasfilename = 1;
5961               break;
5962             }
5963           }
5964           if (*cp2 == '[' || *cp2 == '<') break;
5965         }
5966       }
5967     }
5968
5969     vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5970     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5971     cp1 = strpbrk(trndir,"]:>");
5972     if (hasfilename || !cp1) { /* filename present or not VMS */
5973
5974       if (trndir[0] == '.') {
5975         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5976           PerlMem_free(trndir);
5977           PerlMem_free(vmsdir);
5978           return int_fileify_dirspec("[]", buf, NULL);
5979         }
5980         else if (trndir[1] == '.' &&
5981                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5982           PerlMem_free(trndir);
5983           PerlMem_free(vmsdir);
5984           return int_fileify_dirspec("[-]", buf, NULL);
5985         }
5986       }
5987       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5988         dirlen -= 1;                 /* to last element */
5989         lastdir = strrchr(trndir,'/');
5990       }
5991       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5992         /* If we have "/." or "/..", VMSify it and let the VMS code
5993          * below expand it, rather than repeating the code to handle
5994          * relative components of a filespec here */
5995         do {
5996           if (*(cp1+2) == '.') cp1++;
5997           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5998             char * ret_chr;
5999             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6000                 PerlMem_free(trndir);
6001                 PerlMem_free(vmsdir);
6002                 return NULL;
6003             }
6004             if (strchr(vmsdir,'/') != NULL) {
6005               /* If int_tovmsspec() returned it, it must have VMS syntax
6006                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6007                * the time to check this here only so we avoid a recursion
6008                * loop; otherwise, gigo.
6009                */
6010               PerlMem_free(trndir);
6011               PerlMem_free(vmsdir);
6012               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6013               return NULL;
6014             }
6015             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6016                 PerlMem_free(trndir);
6017                 PerlMem_free(vmsdir);
6018                 return NULL;
6019             }
6020             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6021             PerlMem_free(trndir);
6022             PerlMem_free(vmsdir);
6023             return ret_chr;
6024           }
6025           cp1++;
6026         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6027         lastdir = strrchr(trndir,'/');
6028       }
6029       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6030         char * ret_chr;
6031         /* Ditto for specs that end in an MFD -- let the VMS code
6032          * figure out whether it's a real device or a rooted logical. */
6033
6034         /* This should not happen any more.  Allowing the fake /000000
6035          * in a UNIX pathname causes all sorts of problems when trying
6036          * to run in UNIX emulation.  So the VMS to UNIX conversions
6037          * now remove the fake /000000 directories.
6038          */
6039
6040         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6041         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6042             PerlMem_free(trndir);
6043             PerlMem_free(vmsdir);
6044             return NULL;
6045         }
6046         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6047             PerlMem_free(trndir);
6048             PerlMem_free(vmsdir);
6049             return NULL;
6050         }
6051         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6052         PerlMem_free(trndir);
6053         PerlMem_free(vmsdir);
6054         return ret_chr;
6055       }
6056       else {
6057
6058         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6059              !(lastdir = cp1 = strrchr(trndir,']')) &&
6060              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6061
6062         cp2 = strrchr(cp1,'.');
6063         if (cp2) {
6064             int e_len, vs_len = 0;
6065             int is_dir = 0;
6066             char * cp3;
6067             cp3 = strchr(cp2,';');
6068             e_len = strlen(cp2);
6069             if (cp3) {
6070                 vs_len = strlen(cp3);
6071                 e_len = e_len - vs_len;
6072             }
6073             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6074             if (!is_dir) {
6075                 if (!decc_efs_charset) {
6076                     /* If this is not EFS, then not a directory */
6077                     PerlMem_free(trndir);
6078                     PerlMem_free(vmsdir);
6079                     set_errno(ENOTDIR);
6080                     set_vaxc_errno(RMS$_DIR);
6081                     return NULL;
6082                 }
6083             } else {
6084                 /* Ok, here we have an issue, technically if a .dir shows */
6085                 /* from inside a directory, then we should treat it as */
6086                 /* xxx^.dir.dir.  But we do not have that context at this */
6087                 /* point unless this is totally restructured, so we remove */
6088                 /* The .dir for now, and fix this better later */
6089                 dirlen = cp2 - trndir;
6090             }
6091             if (decc_efs_charset && !strchr(trndir,'/')) {
6092                 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6093                 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6094
6095                 for (; cp4 > cp1; cp4--) {
6096                     if (*cp4 == '.') {
6097                         if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6098                             memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6099                             *cp4 = '^';
6100                             dirlen++;
6101                         }
6102                     }
6103                 }
6104             }
6105         }
6106
6107       }
6108
6109       retlen = dirlen + 6;
6110       memcpy(buf, trndir, dirlen);
6111       buf[dirlen] = '\0';
6112
6113       /* We've picked up everything up to the directory file name.
6114          Now just add the type and version, and we're set. */
6115       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6116           strcat(buf,".dir;1");
6117       else
6118           strcat(buf,".DIR;1");
6119       PerlMem_free(trndir);
6120       PerlMem_free(vmsdir);
6121       return buf;
6122     }
6123     else {  /* VMS-style directory spec */
6124
6125       char *esa, *esal, term, *cp;
6126       char *my_esa;
6127       int my_esa_len;
6128       unsigned long int cmplen, haslower = 0;
6129       struct FAB dirfab = cc$rms_fab;
6130       rms_setup_nam(savnam);
6131       rms_setup_nam(dirnam);
6132
6133       esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
6134       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6135       esal = NULL;
6136 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6137       esal = (char *)PerlMem_malloc(VMS_MAXRSS);
6138       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6139 #endif
6140       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6141       rms_bind_fab_nam(dirfab, dirnam);
6142       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6143       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6144 #ifdef NAM$M_NO_SHORT_UPCASE
6145       if (decc_efs_case_preserve)
6146         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6147 #endif
6148
6149       for (cp = trndir; *cp; cp++)
6150         if (islower(*cp)) { haslower = 1; break; }
6151       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6152         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6153             (dirfab.fab$l_sts == RMS$_DNF) ||
6154             (dirfab.fab$l_sts == RMS$_PRV)) {
6155             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6156             sts = sys$parse(&dirfab);
6157         }
6158         if (!sts) {
6159           PerlMem_free(esa);
6160           if (esal != NULL)
6161               PerlMem_free(esal);
6162           PerlMem_free(trndir);
6163           PerlMem_free(vmsdir);
6164           set_errno(EVMSERR);
6165           set_vaxc_errno(dirfab.fab$l_sts);
6166           return NULL;
6167         }
6168       }
6169       else {
6170         savnam = dirnam;
6171         /* Does the file really exist? */
6172         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6173           /* Yes; fake the fnb bits so we'll check type below */
6174           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6175         }
6176         else { /* No; just work with potential name */
6177           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6178           else {
6179             int fab_sts;
6180             fab_sts = dirfab.fab$l_sts;
6181             sts = rms_free_search_context(&dirfab);
6182             PerlMem_free(esa);
6183             if (esal != NULL)
6184                 PerlMem_free(esal);
6185             PerlMem_free(trndir);
6186             PerlMem_free(vmsdir);
6187             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6188             return NULL;
6189           }
6190         }
6191       }
6192
6193       /* Make sure we are using the right buffer */
6194 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6195       if (esal != NULL) {
6196         my_esa = esal;
6197         my_esa_len = rms_nam_esll(dirnam);
6198       } else {
6199 #endif
6200         my_esa = esa;
6201         my_esa_len = rms_nam_esl(dirnam);
6202 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6203       }
6204 #endif
6205       my_esa[my_esa_len] = '\0';
6206       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6207         cp1 = strchr(my_esa,']');
6208         if (!cp1) cp1 = strchr(my_esa,'>');
6209         if (cp1) {  /* Should always be true */
6210           my_esa_len -= cp1 - my_esa - 1;
6211           memmove(my_esa, cp1 + 1, my_esa_len);
6212         }
6213       }
6214       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6215         /* Yep; check version while we're at it, if it's there. */
6216         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6217         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6218           /* Something other than .DIR[;1].  Bzzt. */
6219           sts = rms_free_search_context(&dirfab);
6220           PerlMem_free(esa);
6221           if (esal != NULL)
6222              PerlMem_free(esal);
6223           PerlMem_free(trndir);
6224           PerlMem_free(vmsdir);
6225           set_errno(ENOTDIR);
6226           set_vaxc_errno(RMS$_DIR);
6227           return NULL;
6228         }
6229       }
6230
6231       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6232         /* They provided at least the name; we added the type, if necessary, */
6233         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6234         sts = rms_free_search_context(&dirfab);
6235         PerlMem_free(trndir);
6236         PerlMem_free(esa);
6237         if (esal != NULL)
6238             PerlMem_free(esal);
6239         PerlMem_free(vmsdir);
6240         return buf;
6241       }
6242       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6243         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6244         *cp1 = '\0';
6245         my_esa_len -= 9;
6246       }
6247       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6248       if (cp1 == NULL) { /* should never happen */
6249         sts = rms_free_search_context(&dirfab);
6250         PerlMem_free(trndir);
6251         PerlMem_free(esa);
6252         if (esal != NULL)
6253             PerlMem_free(esal);
6254         PerlMem_free(vmsdir);
6255         return NULL;
6256       }
6257       term = *cp1;
6258       *cp1 = '\0';
6259       retlen = strlen(my_esa);
6260       cp1 = strrchr(my_esa,'.');
6261       /* ODS-5 directory specifications can have extra "." in them. */
6262       /* Fix-me, can not scan EFS file specifications backwards */
6263       while (cp1 != NULL) {
6264         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6265           break;
6266         else {
6267            cp1--;
6268            while ((cp1 > my_esa) && (*cp1 != '.'))
6269              cp1--;
6270         }
6271         if (cp1 == my_esa)
6272           cp1 = NULL;
6273       }
6274
6275       if ((cp1) != NULL) {
6276         /* There's more than one directory in the path.  Just roll back. */
6277         *cp1 = term;
6278         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6279       }
6280       else {
6281         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6282           /* Go back and expand rooted logical name */
6283           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6284 #ifdef NAM$M_NO_SHORT_UPCASE
6285           if (decc_efs_case_preserve)
6286             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6287 #endif
6288           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6289             sts = rms_free_search_context(&dirfab);
6290             PerlMem_free(esa);
6291             if (esal != NULL)
6292                 PerlMem_free(esal);
6293             PerlMem_free(trndir);
6294             PerlMem_free(vmsdir);
6295             set_errno(EVMSERR);
6296             set_vaxc_errno(dirfab.fab$l_sts);
6297             return NULL;
6298           }
6299
6300           /* This changes the length of the string of course */
6301           if (esal != NULL) {
6302               my_esa_len = rms_nam_esll(dirnam);
6303           } else {
6304               my_esa_len = rms_nam_esl(dirnam);
6305           }
6306
6307           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6308           cp1 = strstr(my_esa,"][");
6309           if (!cp1) cp1 = strstr(my_esa,"]<");
6310           dirlen = cp1 - my_esa;
6311           memcpy(buf, my_esa, dirlen);
6312           if (!strncmp(cp1+2,"000000]",7)) {
6313             buf[dirlen-1] = '\0';
6314             /* fix-me Not full ODS-5, just extra dots in directories for now */
6315             cp1 = buf + dirlen - 1;
6316             while (cp1 > buf)
6317             {
6318               if (*cp1 == '[')
6319                 break;
6320               if (*cp1 == '.') {
6321                 if (*(cp1-1) != '^')
6322                   break;
6323               }
6324               cp1--;
6325             }
6326             if (*cp1 == '.') *cp1 = ']';
6327             else {
6328               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6329               memmove(cp1+1,"000000]",7);
6330             }
6331           }
6332           else {
6333             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6334             buf[retlen] = '\0';
6335             /* Convert last '.' to ']' */
6336             cp1 = buf+retlen-1;
6337             while (*cp != '[') {
6338               cp1--;
6339               if (*cp1 == '.') {
6340                 /* Do not trip on extra dots in ODS-5 directories */
6341                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6342                 break;
6343               }
6344             }
6345             if (*cp1 == '.') *cp1 = ']';
6346             else {
6347               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6348               memmove(cp1+1,"000000]",7);
6349             }
6350           }
6351         }
6352         else {  /* This is a top-level dir.  Add the MFD to the path. */
6353           cp1 = my_esa;
6354           cp2 = buf;
6355           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6356           strcpy(cp2,":[000000]");
6357           cp1 += 2;
6358           strcpy(cp2+9,cp1);
6359         }
6360       }
6361       sts = rms_free_search_context(&dirfab);
6362       /* We've set up the string up through the filename.  Add the
6363          type and version, and we're done. */
6364       strcat(buf,".DIR;1");
6365
6366       /* $PARSE may have upcased filespec, so convert output to lower
6367        * case if input contained any lowercase characters. */
6368       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6369       PerlMem_free(trndir);
6370       PerlMem_free(esa);
6371       if (esal != NULL)
6372         PerlMem_free(esal);
6373       PerlMem_free(vmsdir);
6374       return buf;
6375     }
6376 }  /* end of int_fileify_dirspec() */
6377
6378
6379 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6380 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6381 {
6382     static char __fileify_retbuf[VMS_MAXRSS];
6383     char * fileified, *ret_spec, *ret_buf;
6384
6385     fileified = NULL;
6386     ret_buf = buf;
6387     if (ret_buf == NULL) {
6388         if (ts) {
6389             Newx(fileified, VMS_MAXRSS, char);
6390             if (fileified == NULL)
6391                 _ckvmssts(SS$_INSFMEM);
6392             ret_buf = fileified;
6393         } else {
6394             ret_buf = __fileify_retbuf;
6395         }
6396     }
6397
6398     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6399
6400     if (ret_spec == NULL) {
6401        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6402        if (fileified)
6403            Safefree(fileified);
6404     }
6405
6406     return ret_spec;
6407 }  /* end of do_fileify_dirspec() */
6408 /*}}}*/
6409
6410 /* External entry points */
6411 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6412 { return do_fileify_dirspec(dir,buf,0,NULL); }
6413 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6414 { return do_fileify_dirspec(dir,buf,1,NULL); }
6415 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6416 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6417 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6418 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6419
6420 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6421     char * v_spec, int v_len, char * r_spec, int r_len,
6422     char * d_spec, int d_len, char * n_spec, int n_len,
6423     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6424
6425     /* VMS specification - Try to do this the simple way */
6426     if ((v_len + r_len > 0) || (d_len > 0)) {
6427         int is_dir;
6428
6429         /* No name or extension component, already a directory */
6430         if ((n_len + e_len + vs_len) == 0) {
6431             strcpy(buf, dir);
6432             return buf;
6433         }
6434
6435         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6436         /* This results from catfile() being used instead of catdir() */
6437         /* So even though it should not work, we need to allow it */
6438
6439         /* If this is .DIR;1 then do a simple conversion */
6440         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6441         if (is_dir || (e_len == 0) && (d_len > 0)) {
6442              int len;
6443              len = v_len + r_len + d_len - 1;
6444              char dclose = d_spec[d_len - 1];
6445              memcpy(buf, dir, len);
6446              buf[len] = '.';
6447              len++;
6448              memcpy(&buf[len], n_spec, n_len);
6449              len += n_len;
6450              buf[len] = dclose;
6451              buf[len + 1] = '\0';
6452              return buf;
6453         }
6454
6455 #ifdef HAS_SYMLINK
6456         else if (d_len > 0) {
6457             /* In the olden days, a directory needed to have a .DIR */
6458             /* extension to be a valid directory, but now it could  */
6459             /* be a symbolic link */
6460             int len;
6461             len = v_len + r_len + d_len - 1;
6462             char dclose = d_spec[d_len - 1];
6463             memcpy(buf, dir, len);
6464             buf[len] = '.';
6465             len++;
6466             memcpy(&buf[len], n_spec, n_len);
6467             len += n_len;
6468             if (e_len > 0) {
6469                 if (decc_efs_charset) {
6470                     buf[len] = '^';
6471                     len++;
6472                     memcpy(&buf[len], e_spec, e_len);
6473                     len += e_len;
6474                 } else {
6475                     set_vaxc_errno(RMS$_DIR);
6476                     set_errno(ENOTDIR);
6477                     return NULL;
6478                 }
6479             }
6480             buf[len] = dclose;
6481             buf[len + 1] = '\0';
6482             return buf;
6483         }
6484 #else
6485         else {
6486             set_vaxc_errno(RMS$_DIR);
6487             set_errno(ENOTDIR);
6488             return NULL;
6489         }
6490 #endif
6491     }
6492     set_vaxc_errno(RMS$_DIR);
6493     set_errno(ENOTDIR);
6494     return NULL;
6495 }
6496
6497
6498 /* Internal routine to make sure or convert a directory to be in a */
6499 /* path specification.  No utf8 flag because it is not changed or used */
6500 static char *int_pathify_dirspec(const char *dir, char *buf)
6501 {
6502     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6503     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6504     char * exp_spec, *ret_spec;
6505     char * trndir;
6506     unsigned short int trnlnm_iter_count;
6507     STRLEN trnlen;
6508     int need_to_lower;
6509
6510     if (vms_debug_fileify) {
6511         if (dir == NULL)
6512             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6513         else
6514             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6515     }
6516
6517     /* We may need to lower case the result if we translated  */
6518     /* a logical name or got the current working directory */
6519     need_to_lower = 0;
6520
6521     if (!dir || !*dir) {
6522       set_errno(EINVAL);
6523       set_vaxc_errno(SS$_BADPARAM);
6524       return NULL;
6525     }
6526
6527     trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
6528     if (trndir == NULL)
6529         _ckvmssts_noperl(SS$_INSFMEM);
6530
6531     /* If no directory specified use the current default */
6532     if (*dir)
6533         my_strlcpy(trndir, dir, VMS_MAXRSS);
6534     else {
6535         getcwd(trndir, VMS_MAXRSS - 1);
6536         need_to_lower = 1;
6537     }
6538
6539     /* now deal with bare names that could be logical names */
6540     trnlnm_iter_count = 0;
6541     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6542            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6543         trnlnm_iter_count++;
6544         need_to_lower = 1;
6545         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6546             break;
6547         trnlen = strlen(trndir);
6548
6549         /* Trap simple rooted lnms, and return lnm:[000000] */
6550         if (!strcmp(trndir+trnlen-2,".]")) {
6551             my_strlcpy(buf, dir, VMS_MAXRSS);
6552             strcat(buf, ":[000000]");
6553             PerlMem_free(trndir);
6554
6555             if (vms_debug_fileify) {
6556                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6557             }
6558             return buf;
6559         }
6560     }
6561
6562     /* At this point we do not work with *dir, but the copy in  *trndir */
6563
6564     if (need_to_lower && !decc_efs_case_preserve) {
6565         /* Legacy mode, lower case the returned value */
6566         __mystrtolower(trndir);
6567     }
6568
6569
6570     /* Some special cases, '..', '.' */
6571     sts = 0;
6572     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6573        /* Force UNIX filespec */
6574        sts = 1;
6575
6576     } else {
6577         /* Is this Unix or VMS format? */
6578         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6579                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6580                              &e_len, &vs_spec, &vs_len);
6581         if (sts == 0) {
6582
6583             /* Just a filename? */
6584             if ((v_len + r_len + d_len) == 0) {
6585
6586                 /* Now we have a problem, this could be Unix or VMS */
6587                 /* We have to guess.  .DIR usually means VMS */
6588
6589                 /* In UNIX report mode, the .DIR extension is removed */
6590                 /* if one shows up, it is for a non-directory or a directory */
6591                 /* in EFS charset mode */
6592
6593                 /* So if we are in Unix report mode, assume that this */
6594                 /* is a relative Unix directory specification */
6595
6596                 sts = 1;
6597                 if (!decc_filename_unix_report && decc_efs_charset) {
6598                     int is_dir;
6599                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6600
6601                     if (is_dir) {
6602                         /* Traditional mode, assume .DIR is directory */
6603                         buf[0] = '[';
6604                         buf[1] = '.';
6605                         memcpy(&buf[2], n_spec, n_len);
6606                         buf[n_len + 2] = ']';
6607                         buf[n_len + 3] = '\0';
6608                         PerlMem_free(trndir);
6609                         if (vms_debug_fileify) {
6610                             fprintf(stderr,
6611                                     "int_pathify_dirspec: buf = %s\n",
6612                                     buf);
6613                         }
6614                         return buf;
6615                     }
6616                 }
6617             }
6618         }
6619     }
6620     if (sts == 0) {
6621         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6622             v_spec, v_len, r_spec, r_len,
6623             d_spec, d_len, n_spec, n_len,
6624             e_spec, e_len, vs_spec, vs_len);
6625
6626         if (ret_spec != NULL) {
6627             PerlMem_free(trndir);
6628             if (vms_debug_fileify) {
6629                 fprintf(stderr,
6630                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6631             }
6632             return ret_spec;
6633         }
6634
6635         /* Simple way did not work, which means that a logical name */
6636         /* was present for the directory specification.             */
6637         /* Need to use an rmsexpand variant to decode it completely */
6638         exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
6639         if (exp_spec == NULL)
6640             _ckvmssts_noperl(SS$_INSFMEM);
6641
6642         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6643         if (ret_spec != NULL) {
6644             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6645                                  &r_spec, &r_len, &d_spec, &d_len,
6646                                  &n_spec, &n_len, &e_spec,
6647                                  &e_len, &vs_spec, &vs_len);
6648             if (sts == 0) {
6649                 ret_spec = int_pathify_dirspec_simple(
6650                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6651                     d_spec, d_len, n_spec, n_len,
6652                     e_spec, e_len, vs_spec, vs_len);
6653
6654                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6655                     /* Legacy mode, lower case the returned value */
6656                     __mystrtolower(ret_spec);
6657                 }
6658             } else {
6659                 set_vaxc_errno(RMS$_DIR);
6660                 set_errno(ENOTDIR);
6661                 ret_spec = NULL;
6662             }
6663         }
6664         PerlMem_free(exp_spec);
6665         PerlMem_free(trndir);
6666         if (vms_debug_fileify) {
6667             if (ret_spec == NULL)
6668                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6669             else
6670                 fprintf(stderr,
6671                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6672         }
6673         return ret_spec;
6674
6675     } else {
6676         /* Unix specification, Could be trivial conversion, */
6677         /* but have to deal with trailing '.dir' or extra '.' */
6678
6679         char * lastdot;
6680         char * lastslash;
6681         int is_dir;
6682         STRLEN dir_len = strlen(trndir);
6683
6684         lastslash = strrchr(trndir, '/');
6685         if (lastslash == NULL)
6686             lastslash = trndir;
6687         else
6688             lastslash++;
6689
6690         lastdot = NULL;
6691
6692         /* '..' or '.' are valid directory components */
6693         is_dir = 0;
6694         if (lastslash[0] == '.') {
6695             if (lastslash[1] == '\0') {
6696                is_dir = 1;
6697             } else if (lastslash[1] == '.') {
6698                 if (lastslash[2] == '\0') {
6699                     is_dir = 1;
6700                 } else {
6701                     /* And finally allow '...' */
6702                     if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6703                         is_dir = 1;
6704                     }
6705                 }
6706             }
6707         }
6708
6709         if (!is_dir) {
6710            lastdot = strrchr(lastslash, '.');
6711         }
6712         if (lastdot != NULL) {
6713             STRLEN e_len;
6714              /* '.dir' is discarded, and any other '.' is invalid */
6715             e_len = strlen(lastdot);
6716
6717             is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6718
6719             if (is_dir) {
6720                 dir_len = dir_len - 4;
6721             }
6722         }
6723
6724         my_strlcpy(buf, trndir, VMS_MAXRSS);
6725         if (buf[dir_len - 1] != '/') {
6726             buf[dir_len] = '/';
6727             buf[dir_len + 1] = '\0';
6728         }
6729
6730         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6731         if (!decc_efs_charset) {
6732              int dir_start = 0;
6733              char * str = buf;
6734              if (str[0] == '.') {
6735                  char * dots = str;
6736                  int cnt = 1;
6737                  while ((dots[cnt] == '.') && (cnt < 3))
6738                      cnt++;
6739                  if (cnt <= 3) {
6740                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6741                          dir_start = 1;
6742                          str += cnt;
6743                      }
6744                  }
6745              }
6746              for (; *str; ++str) {
6747                  while (*str == '/') {
6748                      dir_start = 1;
6749                      *str++;
6750                  }
6751                  if (dir_start) {
6752
6753                      /* Have to skip up to three dots which could be */
6754                      /* directories, 3 dots being a VMS extension for Perl */
6755                      char * dots = str;
6756                      int cnt = 0;
6757                      while ((dots[cnt] == '.') && (cnt < 3)) {
6758                          cnt++;
6759                      }
6760                      if (dots[cnt] == '\0')
6761                          break;
6762                      if ((cnt > 1) && (dots[cnt] != '/')) {
6763                          dir_start = 0;
6764                      } else {
6765                          str += cnt;
6766                      }
6767
6768                      /* too many dots? */
6769                      if ((cnt == 0) || (cnt > 3)) {
6770                          dir_start = 0;
6771                      }
6772                  }
6773                  if (!dir_start && (*str == '.')) {
6774                      *str = '_';
6775                  }
6776              }
6777         }
6778         PerlMem_free(trndir);
6779         ret_spec = buf;
6780         if (vms_debug_fileify) {
6781             if (ret_spec == NULL)
6782                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6783             else
6784                 fprintf(stderr,
6785                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6786         }
6787         return ret_spec;
6788     }
6789 }
6790
6791 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6792 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6793 {
6794     static char __pathify_retbuf[VMS_MAXRSS];
6795     char * pathified, *ret_spec, *ret_buf;
6796
6797     pathified = NULL;
6798     ret_buf = buf;
6799     if (ret_buf == NULL) {
6800         if (ts) {
6801             Newx(pathified, VMS_MAXRSS, char);
6802             if (pathified == NULL)
6803                 _ckvmssts(SS$_INSFMEM);
6804             ret_buf = pathified;
6805         } else {
6806             ret_buf = __pathify_retbuf;
6807         }
6808     }
6809
6810     ret_spec = int_pathify_dirspec(dir, ret_buf);
6811
6812     if (ret_spec == NULL) {
6813        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6814        if (pathified)
6815            Safefree(pathified);
6816     }
6817
6818     return ret_spec;
6819
6820 }  /* end of do_pathify_dirspec() */
6821
6822
6823 /* External entry points */
6824 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6825 { return do_pathify_dirspec(dir,buf,0,NULL); }
6826 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6827 { return do_pathify_dirspec(dir,buf,1,NULL); }
6828 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6829 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6830 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6831 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6832
6833 /* Internal tounixspec routine that does not use a thread context */
6834 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6835 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6836 {
6837   char *dirend, *cp1, *cp3, *tmp;
6838   const char *cp2;
6839   int dirlen;
6840   unsigned short int trnlnm_iter_count;
6841   int cmp_rslt;
6842   if (utf8_fl != NULL)
6843     *utf8_fl = 0;
6844
6845   if (vms_debug_fileify) {
6846       if (spec == NULL)
6847           fprintf(stderr, "int_tounixspec: spec = NULL\n");
6848       else
6849           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6850   }
6851
6852
6853   if (spec == NULL) {
6854       set_errno(EINVAL);
6855       set_vaxc_errno(SS$_BADPARAM);
6856       return NULL;
6857   }
6858   if (strlen(spec) > (VMS_MAXRSS-1)) {
6859       set_errno(E2BIG);
6860       set_vaxc_errno(SS$_BUFFEROVF);
6861       return NULL;
6862   }
6863
6864   /* New VMS specific format needs translation
6865    * glob passes filenames with trailing '\n' and expects this preserved.
6866    */
6867   if (decc_posix_compliant_pathnames) {
6868     if (strncmp(spec, "\"^UP^", 5) == 0) {
6869       char * uspec;
6870       char *tunix;
6871       int tunix_len;
6872       int nl_flag;
6873
6874       tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
6875       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6876       tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
6877       nl_flag = 0;
6878       if (tunix[tunix_len - 1] == '\n') {
6879         tunix[tunix_len - 1] = '\"';
6880         tunix[tunix_len] = '\0';
6881         tunix_len--;
6882         nl_flag = 1;
6883       }
6884       uspec = decc$translate_vms(tunix);
6885       PerlMem_free(tunix);
6886       if ((int)uspec > 0) {
6887         my_strlcpy(rslt, uspec, VMS_MAXRSS);
6888         if (nl_flag) {
6889           strcat(rslt,"\n");
6890         }
6891         else {
6892           /* If we can not translate it, makemaker wants as-is */
6893           my_strlcpy(rslt, spec, VMS_MAXRSS);
6894         }
6895         return rslt;
6896       }
6897     }
6898   }
6899
6900   cmp_rslt = 0; /* Presume VMS */
6901   cp1 = strchr(spec, '/');
6902   if (cp1 == NULL)
6903     cmp_rslt = 0;
6904
6905     /* Look for EFS ^/ */
6906     if (decc_efs_charset) {
6907       while (cp1 != NULL) {
6908         cp2 = cp1 - 1;
6909         if (*cp2 != '^') {
6910           /* Found illegal VMS, assume UNIX */
6911           cmp_rslt = 1;
6912           break;
6913         }
6914       cp1++;
6915       cp1 = strchr(cp1, '/');
6916     }
6917   }
6918
6919   /* Look for "." and ".." */
6920   if (decc_filename_unix_report) {
6921     if (spec[0] == '.') {
6922       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6923         cmp_rslt = 1;
6924       }
6925       else {
6926         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6927           cmp_rslt = 1;
6928         }
6929       }
6930     }
6931   }
6932   /* This is already UNIX or at least nothing VMS understands */
6933   if (cmp_rslt) {
6934     my_strlcpy(rslt, spec, VMS_MAXRSS);
6935     if (vms_debug_fileify) {
6936         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6937     }
6938     return rslt;
6939   }
6940
6941   cp1 = rslt;
6942   cp2 = spec;
6943   dirend = strrchr(spec,']');
6944   if (dirend == NULL) dirend = strrchr(spec,'>');
6945   if (dirend == NULL) dirend = strchr(spec,':');
6946   if (dirend == NULL) {
6947     strcpy(rslt,spec);
6948     if (vms_debug_fileify) {
6949         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6950     }
6951     return rslt;
6952   }
6953
6954   /* Special case 1 - sys$posix_root = / */
6955   if (!decc_disable_posix_root) {
6956     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6957       *cp1 = '/';
6958       cp1++;
6959       cp2 = cp2 + 15;
6960       }
6961   }
6962
6963   /* Special case 2 - Convert NLA0: to /dev/null */
6964   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6965   if (cmp_rslt == 0) {
6966     strcpy(rslt, "/dev/null");
6967     cp1 = cp1 + 9;
6968     cp2 = cp2 + 5;
6969     if (spec[6] != '\0') {
6970       cp1[9] = '/';
6971       cp1++;
6972       cp2++;
6973     }
6974   }
6975
6976    /* Also handle special case "SYS$SCRATCH:" */
6977   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6978   tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
6979   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6980   if (cmp_rslt == 0) {
6981   int islnm;
6982
6983     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
6984     if (!islnm) {
6985       strcpy(rslt, "/tmp");
6986       cp1 = cp1 + 4;
6987       cp2 = cp2 + 12;
6988       if (spec[12] != '\0') {
6989         cp1[4] = '/';
6990         cp1++;
6991         cp2++;
6992       }
6993     }
6994   }
6995
6996   if (*cp2 != '[' && *cp2 != '<') {
6997     *(cp1++) = '/';
6998   }
6999   else {  /* the VMS spec begins with directories */
7000     cp2++;
7001     if (*cp2 == ']' || *cp2 == '>') {
7002       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7003       PerlMem_free(tmp);
7004       return rslt;
7005     }
7006     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7007       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7008         PerlMem_free(tmp);
7009         if (vms_debug_fileify) {
7010             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7011         }
7012         return NULL;
7013       }
7014       trnlnm_iter_count = 0;
7015       do {
7016         cp3 = tmp;
7017         while (*cp3 != ':' && *cp3) cp3++;
7018         *(cp3++) = '\0';
7019         if (strchr(cp3,']') != NULL) break;
7020         trnlnm_iter_count++;
7021         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7022       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7023       cp1 = rslt;
7024       cp3 = tmp;
7025       *(cp1++) = '/';
7026       while (*cp3) {
7027         *(cp1++) = *(cp3++);
7028         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7029             PerlMem_free(tmp);
7030             set_errno(ENAMETOOLONG);
7031             set_vaxc_errno(SS$_BUFFEROVF);
7032             if (vms_debug_fileify) {
7033                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7034             }
7035             return NULL; /* No room */
7036         }
7037       }
7038       *(cp1++) = '/';
7039     }
7040     if ((*cp2 == '^')) {
7041         /* EFS file escape, pass the next character as is */
7042         /* Fix me: HEX encoding for Unicode not implemented */
7043         cp2++;
7044     }
7045     else if ( *cp2 == '.') {
7046       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7047         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7048         cp2 += 3;
7049       }
7050       else cp2++;
7051     }
7052   }
7053   PerlMem_free(tmp);
7054   for (; cp2 <= dirend; cp2++) {
7055     if ((*cp2 == '^')) {
7056         /* EFS file escape, pass the next character as is */
7057         /* Fix me: HEX encoding for Unicode not implemented */
7058         *(cp1++) = *(++cp2);
7059         /* An escaped dot stays as is -- don't convert to slash */
7060         if (*cp2 == '.') cp2++;
7061     }
7062     if (*cp2 == ':') {
7063       *(cp1++) = '/';
7064       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7065     }
7066     else if (*cp2 == ']' || *cp2 == '>') {
7067       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7068     }
7069     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7070       *(cp1++) = '/';
7071       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7072         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7073                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7074         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7075             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7076       }
7077       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7078         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7079         cp2 += 2;
7080       }
7081     }
7082     else if (*cp2 == '-') {
7083       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7084         while (*cp2 == '-') {
7085           cp2++;
7086           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7087         }
7088         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7089                                                          /* filespecs like */
7090           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7091           if (vms_debug_fileify) {
7092               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7093           }
7094           return NULL;
7095         }
7096       }
7097       else *(cp1++) = *cp2;
7098     }
7099     else *(cp1++) = *cp2;
7100   }
7101   /* Translate the rest of the filename. */
7102   while (*cp2) {
7103       int dot_seen;
7104       dot_seen = 0;
7105       switch(*cp2) {
7106       /* Fixme - for compatibility with the CRTL we should be removing */
7107       /* spaces from the file specifications, but this may show that */
7108       /* some tests that were appearing to pass are not really passing */
7109       case '%':
7110           cp2++;
7111           *(cp1++) = '?';
7112           break;
7113       case '^':
7114           /* Fix me hex expansions not implemented */
7115           cp2++;  /* '^.' --> '.' and other. */
7116           if (*cp2) {
7117               if (*cp2 == '_') {
7118                   cp2++;
7119                   *(cp1++) = ' ';
7120               } else {
7121                   *(cp1++) = *(cp2++);
7122               }
7123           }
7124           break;
7125       case ';':
7126           if (decc_filename_unix_no_version) {
7127               /* Easy, drop the version */
7128               while (*cp2)
7129                   cp2++;
7130               break;
7131           } else {
7132               /* Punt - passing the version as a dot will probably */
7133               /* break perl in weird ways, but so did passing */
7134               /* through the ; as a version.  Follow the CRTL and */
7135               /* hope for the best. */
7136               cp2++;
7137               *(cp1++) = '.';
7138           }
7139           break;
7140       case '.':
7141           if (dot_seen) {
7142               /* We will need to fix this properly later */
7143               /* As Perl may be installed on an ODS-5 volume, but not */
7144               /* have the EFS_CHARSET enabled, it still may encounter */
7145               /* filenames with extra dots in them, and a precedent got */
7146               /* set which allowed them to work, that we will uphold here */
7147               /* If extra dots are present in a name and no ^ is on them */
7148               /* VMS assumes that the first one is the extension delimiter */
7149               /* the rest have an implied ^. */
7150
7151               /* this is also a conflict as the . is also a version */
7152               /* delimiter in VMS, */
7153
7154               *(cp1++) = *(cp2++);
7155               break;
7156           }
7157           dot_seen = 1;
7158           /* This is an extension */
7159           if (decc_readdir_dropdotnotype) {
7160               cp2++;
7161               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7162                   /* Drop the dot for the extension */
7163                   break;
7164               } else {
7165                   *(cp1++) = '.';
7166               }
7167               break;
7168           }
7169       default:
7170           *(cp1++) = *(cp2++);
7171       }
7172   }
7173   *cp1 = '\0';
7174
7175   /* This still leaves /000000/ when working with a
7176    * VMS device root or concealed root.
7177    */
7178   {
7179   int ulen;
7180   char * zeros;
7181
7182       ulen = strlen(rslt);
7183
7184       /* Get rid of "000000/ in rooted filespecs */
7185       if (ulen > 7) {
7186         zeros = strstr(rslt, "/000000/");
7187         if (zeros != NULL) {
7188           int mlen;
7189           mlen = ulen - (zeros - rslt) - 7;
7190           memmove(zeros, &zeros[7], mlen);
7191           ulen = ulen - 7;
7192           rslt[ulen] = '\0';
7193         }
7194       }
7195   }
7196
7197   if (vms_debug_fileify) {
7198       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7199   }
7200   return rslt;
7201
7202 }  /* end of int_tounixspec() */
7203
7204
7205 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7206 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7207 {
7208     static char __tounixspec_retbuf[VMS_MAXRSS];
7209     char * unixspec, *ret_spec, *ret_buf;
7210
7211     unixspec = NULL;
7212     ret_buf = buf;
7213     if (ret_buf == NULL) {
7214         if (ts) {
7215             Newx(unixspec, VMS_MAXRSS, char);
7216             if (unixspec == NULL)
7217                 _ckvmssts(SS$_INSFMEM);
7218             ret_buf = unixspec;
7219         } else {
7220             ret_buf = __tounixspec_retbuf;
7221         }
7222     }
7223
7224     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7225
7226     if (ret_spec == NULL) {
7227        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7228        if (unixspec)
7229            Safefree(unixspec);
7230     }
7231
7232     return ret_spec;
7233
7234 }  /* end of do_tounixspec() */
7235 /*}}}*/
7236 /* External entry points */
7237 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7238   { return do_tounixspec(spec,buf,0, NULL); }
7239 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7240   { return do_tounixspec(spec,buf,1, NULL); }
7241 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7242   { return do_tounixspec(spec,buf,0, utf8_fl); }
7243 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7244   { return do_tounixspec(spec,buf,1, utf8_fl); }
7245
7246 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7247
7248 /*
7249  This procedure is used to identify if a path is based in either
7250  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7251  it returns the OpenVMS format directory for it.
7252
7253  It is expecting specifications of only '/' or '/xxxx/'
7254
7255  If a posix root does not exist, or 'xxxx' is not a directory
7256  in the posix root, it returns a failure.
7257
7258  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7259
7260  It is used only internally by posix_to_vmsspec_hardway().
7261  */
7262
7263 static int posix_root_to_vms
7264   (char *vmspath, int vmspath_len,
7265    const char *unixpath,
7266    const int * utf8_fl)
7267 {
7268 int sts;
7269 struct FAB myfab = cc$rms_fab;
7270 rms_setup_nam(mynam);
7271 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7272 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7273 char * esa, * esal, * rsa, * rsal;
7274 int dir_flag;
7275 int unixlen;
7276
7277     dir_flag = 0;
7278     vmspath[0] = '\0';
7279     unixlen = strlen(unixpath);
7280     if (unixlen == 0) {
7281       return RMS$_FNF;
7282     }
7283
7284 #if __CRTL_VER >= 80200000
7285   /* If not a posix spec already, convert it */
7286   if (decc_posix_compliant_pathnames) {
7287     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7288       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7289     }
7290     else {
7291       /* This is already a VMS specification, no conversion */
7292       unixlen--;
7293       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7294     }
7295   }
7296   else
7297 #endif
7298   {
7299   int path_len;
7300   int i,j;
7301
7302      /* Check to see if this is under the POSIX root */
7303      if (decc_disable_posix_root) {
7304         return RMS$_FNF;
7305      }
7306
7307      /* Skip leading / */
7308      if (unixpath[0] == '/') {
7309         unixpath++;
7310         unixlen--;
7311      }
7312
7313
7314      strcpy(vmspath,"SYS$POSIX_ROOT:");
7315
7316      /* If this is only the / , or blank, then... */
7317      if (unixpath[0] == '\0') {
7318         /* by definition, this is the answer */
7319         return SS$_NORMAL;
7320      }
7321
7322      /* Need to look up a directory */
7323      vmspath[15] = '[';
7324      vmspath[16] = '\0';
7325
7326      /* Copy and add '^' escape characters as needed */
7327      j = 16;
7328      i = 0;
7329      while (unixpath[i] != 0) {
7330      int k;
7331
7332         j += copy_expand_unix_filename_escape
7333             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7334         i += k;
7335      }
7336
7337      path_len = strlen(vmspath);
7338      if (vmspath[path_len - 1] == '/')
7339         path_len--;
7340      vmspath[path_len] = ']';
7341      path_len++;
7342      vmspath[path_len] = '\0';
7343
7344   }
7345   vmspath[vmspath_len] = 0;
7346   if (unixpath[unixlen - 1] == '/')
7347   dir_flag = 1;
7348   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7349   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7350   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7351   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7352   rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7353   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7354   rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7355   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7356   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7357   rms_bind_fab_nam(myfab, mynam);
7358   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7359   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7360   if (decc_efs_case_preserve)
7361     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7362 #ifdef NAML$M_OPEN_SPECIAL
7363   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7364 #endif
7365
7366   /* Set up the remaining naml fields */
7367   sts = sys$parse(&myfab);
7368
7369   /* It failed! Try again as a UNIX filespec */
7370   if (!(sts & 1)) {
7371     PerlMem_free(esal);
7372     PerlMem_free(esa);
7373     PerlMem_free(rsal);
7374     PerlMem_free(rsa);
7375     return sts;
7376   }
7377
7378    /* get the Device ID and the FID */
7379    sts = sys$search(&myfab);
7380
7381    /* These are no longer needed */
7382    PerlMem_free(esa);
7383    PerlMem_free(rsal);
7384    PerlMem_free(rsa);
7385
7386    /* on any failure, returned the POSIX ^UP^ filespec */
7387    if (!(sts & 1)) {
7388       PerlMem_free(esal);
7389       return sts;
7390    }
7391    specdsc.dsc$a_pointer = vmspath;
7392    specdsc.dsc$w_length = vmspath_len;
7393
7394    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7395    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7396    sts = lib$fid_to_name
7397       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7398
7399   /* on any failure, returned the POSIX ^UP^ filespec */
7400   if (!(sts & 1)) {
7401      /* This can happen if user does not have permission to read directories */
7402      if (strncmp(unixpath,"\"^UP^",5) != 0)
7403        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7404      else
7405        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7406   }
7407   else {
7408     vmspath[specdsc.dsc$w_length] = 0;
7409
7410     /* Are we expecting a directory? */
7411     if (dir_flag != 0) {
7412     int i;
7413     char *eptr;
7414
7415       eptr = NULL;
7416
7417       i = specdsc.dsc$w_length - 1;
7418       while (i > 0) {
7419       int zercnt;
7420         zercnt = 0;
7421         /* Version must be '1' */
7422         if (vmspath[i--] != '1')
7423           break;
7424         /* Version delimiter is one of ".;" */
7425         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7426           break;
7427         i--;
7428         if (vmspath[i--] != 'R')
7429           break;
7430         if (vmspath[i--] != 'I')
7431           break;
7432         if (vmspath[i--] != 'D')
7433           break;
7434         if (vmspath[i--] != '.')
7435           break;
7436         eptr = &vmspath[i+1];
7437         while (i > 0) {
7438           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7439             if (vmspath[i-1] != '^') {
7440               if (zercnt != 6) {
7441                 *eptr = vmspath[i];
7442                 eptr[1] = '\0';
7443                 vmspath[i] = '.';
7444                 break;
7445               }
7446               else {
7447                 /* Get rid of 6 imaginary zero directory filename */
7448                 vmspath[i+1] = '\0';
7449               }
7450             }
7451           }
7452           if (vmspath[i] == '0')
7453             zercnt++;
7454           else
7455             zercnt = 10;
7456           i--;
7457         }
7458         break;
7459       }
7460     }
7461   }
7462   PerlMem_free(esal);
7463   return sts;
7464 }
7465
7466 /* /dev/mumble needs to be handled special.
7467    /dev/null becomes NLA0:, And there is the potential for other stuff
7468    like /dev/tty which may need to be mapped to something.
7469 */
7470
7471 static int
7472 slash_dev_special_to_vms
7473    (const char * unixptr,
7474     char * vmspath,
7475     int vmspath_len)
7476 {
7477 char * nextslash;
7478 int len;
7479 int cmp;
7480
7481     unixptr += 4;
7482     nextslash = strchr(unixptr, '/');
7483     len = strlen(unixptr);
7484     if (nextslash != NULL)
7485         len = nextslash - unixptr;
7486     cmp = strncmp("null", unixptr, 5);
7487     if (cmp == 0) {
7488         if (vmspath_len >= 6) {
7489             strcpy(vmspath, "_NLA0:");
7490             return SS$_NORMAL;
7491         }
7492     }
7493     return 0;
7494 }
7495
7496
7497 /* The built in routines do not understand perl's special needs, so
7498     doing a manual conversion from UNIX to VMS
7499
7500     If the utf8_fl is not null and points to a non-zero value, then
7501     treat 8 bit characters as UTF-8.
7502
7503     The sequence starting with '$(' and ending with ')' will be passed
7504     through with out interpretation instead of being escaped.
7505
7506   */
7507 static int posix_to_vmsspec_hardway
7508   (char *vmspath, int vmspath_len,
7509    const char *unixpath,
7510    int dir_flag,
7511    int * utf8_fl) {
7512
7513 char *esa;
7514 const char *unixptr;
7515 const char *unixend;
7516 char *vmsptr;
7517 const char *lastslash;
7518 const char *lastdot;
7519 int unixlen;
7520 int vmslen;
7521 int dir_start;
7522 int dir_dot;
7523 int quoted;
7524 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7525 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7526
7527   if (utf8_fl != NULL)
7528     *utf8_fl = 0;
7529
7530   unixptr = unixpath;
7531   dir_dot = 0;
7532
7533   /* Ignore leading "/" characters */
7534   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7535     unixptr++;
7536   }
7537   unixlen = strlen(unixptr);
7538
7539   /* Do nothing with blank paths */
7540   if (unixlen == 0) {
7541     vmspath[0] = '\0';
7542     return SS$_NORMAL;
7543   }
7544
7545   quoted = 0;
7546   /* This could have a "^UP^ on the front */
7547   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7548     quoted = 1;
7549     unixptr+= 5;
7550     unixlen-= 5;
7551   }
7552
7553   lastslash = strrchr(unixptr,'/');
7554   lastdot = strrchr(unixptr,'.');
7555   unixend = strrchr(unixptr,'\"');
7556   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7557     unixend = unixptr + unixlen;
7558   }
7559
7560   /* last dot is last dot or past end of string */
7561   if (lastdot == NULL)
7562     lastdot = unixptr + unixlen;
7563
7564   /* if no directories, set last slash to beginning of string */
7565   if (lastslash == NULL) {
7566     lastslash = unixptr;
7567   }
7568   else {
7569     /* Watch out for trailing "." after last slash, still a directory */
7570     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7571       lastslash = unixptr + unixlen;
7572     }
7573
7574     /* Watch out for trailing ".." after last slash, still a directory */
7575     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7576       lastslash = unixptr + unixlen;
7577     }
7578
7579     /* dots in directories are aways escaped */
7580     if (lastdot < lastslash)
7581       lastdot = unixptr + unixlen;
7582   }
7583
7584   /* if (unixptr < lastslash) then we are in a directory */
7585
7586   dir_start = 0;
7587
7588   vmsptr = vmspath;
7589   vmslen = 0;
7590
7591   /* Start with the UNIX path */
7592   if (*unixptr != '/') {
7593     /* relative paths */
7594
7595     /* If allowing logical names on relative pathnames, then handle here */
7596     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7597         !decc_posix_compliant_pathnames) {
7598     char * nextslash;
7599     int seg_len;
7600     char * trn;
7601     int islnm;
7602
7603         /* Find the next slash */
7604         nextslash = strchr(unixptr,'/');
7605
7606         esa = (char *)PerlMem_malloc(vmspath_len);
7607         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7608
7609         trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7610         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7611
7612         if (nextslash != NULL) {
7613
7614             seg_len = nextslash - unixptr;
7615             memcpy(esa, unixptr, seg_len);
7616             esa[seg_len] = 0;
7617         }
7618         else {
7619             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7620         }
7621         /* trnlnm(section) */
7622         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7623
7624         if (islnm) {
7625             /* Now fix up the directory */
7626
7627             /* Split up the path to find the components */
7628             sts = vms_split_path
7629                   (trn,
7630                    &v_spec,
7631                    &v_len,
7632                    &r_spec,
7633                    &r_len,
7634                    &d_spec,
7635                    &d_len,
7636                    &n_spec,
7637                    &n_len,
7638                    &e_spec,
7639                    &e_len,
7640                    &vs_spec,
7641                    &vs_len);
7642
7643             while (sts == 0) {
7644             int cmp;
7645
7646                 /* A logical name must be a directory  or the full
7647                    specification.  It is only a full specification if
7648                    it is the only component */
7649                 if ((unixptr[seg_len] == '\0') ||
7650                     (unixptr[seg_len+1] == '\0')) {
7651
7652                     /* Is a directory being required? */
7653                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7654                         /* Not a logical name */
7655                         break;
7656                     }
7657
7658
7659                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7660                         /* This must be a directory */
7661                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7662                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7663                             vmsptr[vmslen] = ':';
7664                             vmslen++;
7665                             vmsptr[vmslen] = '\0';
7666                             return SS$_NORMAL;
7667                         }
7668                     }
7669
7670                 }
7671
7672
7673                 /* must be dev/directory - ignore version */
7674                 if ((n_len + e_len) != 0)
7675                     break;
7676
7677                 /* transfer the volume */
7678                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7679                     memcpy(vmsptr, v_spec, v_len);
7680                     vmsptr += v_len;
7681                     vmsptr[0] = '\0';
7682                     vmslen += v_len;
7683                 }
7684
7685                 /* unroot the rooted directory */
7686                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7687                     r_spec[0] = '[';
7688                     r_spec[r_len - 1] = ']';
7689
7690                     /* This should not be there, but nothing is perfect */
7691                     if (r_len > 9) {
7692                         cmp = strcmp(&r_spec[1], "000000.");
7693                         if (cmp == 0) {
7694                             r_spec += 7;
7695                             r_spec[7] = '[';
7696                             r_len -= 7;
7697                             if (r_len == 2)
7698                                 r_len = 0;
7699                         }
7700                     }
7701                     if (r_len > 0) {
7702                         memcpy(vmsptr, r_spec, r_len);
7703                         vmsptr += r_len;
7704                         vmslen += r_len;
7705                         vmsptr[0] = '\0';
7706                     }
7707                 }
7708                 /* Bring over the directory. */
7709                 if ((d_len > 0) &&
7710                     ((d_len + vmslen) < vmspath_len)) {
7711                     d_spec[0] = '[';
7712                     d_spec[d_len - 1] = ']';
7713                     if (d_len > 9) {
7714                         cmp = strcmp(&d_spec[1], "000000.");
7715                         if (cmp == 0) {
7716                             d_spec += 7;
7717                             d_spec[7] = '[';
7718                             d_len -= 7;
7719                             if (d_len == 2)
7720                                 d_len = 0;
7721                         }
7722                     }
7723
7724                     if (r_len > 0) {
7725                         /* Remove the redundant root */
7726                         if (r_len > 0) {
7727                             /* remove the ][ */
7728                             vmsptr--;
7729                             vmslen--;
7730                             d_spec++;
7731                             d_len--;
7732                         }
7733                         memcpy(vmsptr, d_spec, d_len);
7734                             vmsptr += d_len;
7735                             vmslen += d_len;
7736                             vmsptr[0] = '\0';
7737                     }
7738                 }
7739                 break;
7740             }
7741         }
7742
7743         PerlMem_free(esa);
7744         PerlMem_free(trn);
7745     }
7746
7747     if (lastslash > unixptr) {
7748     int dotdir_seen;
7749
7750       /* skip leading ./ */
7751       dotdir_seen = 0;
7752       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7753         dotdir_seen = 1;
7754         unixptr++;
7755         unixptr++;
7756       }
7757
7758       /* Are we still in a directory? */
7759       if (unixptr <= lastslash) {
7760         *vmsptr++ = '[';
7761         vmslen = 1;
7762         dir_start = 1;
7763
7764         /* if not backing up, then it is relative forward. */
7765         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7766               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7767           *vmsptr++ = '.';
7768           vmslen++;
7769           dir_dot = 1;
7770           }
7771        }
7772        else {
7773          if (dotdir_seen) {
7774            /* Perl wants an empty directory here to tell the difference
7775             * between a DCL command and a filename
7776             */
7777           *vmsptr++ = '[';
7778           *vmsptr++ = ']';
7779           vmslen = 2;
7780         }
7781       }
7782     }
7783     else {
7784       /* Handle two special files . and .. */
7785       if (unixptr[0] == '.') {
7786         if (&unixptr[1] == unixend) {
7787           *vmsptr++ = '[';
7788           *vmsptr++ = ']';
7789           vmslen += 2;
7790           *vmsptr++ = '\0';
7791           return SS$_NORMAL;
7792         }
7793         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7794           *vmsptr++ = '[';
7795           *vmsptr++ = '-';
7796           *vmsptr++ = ']';
7797           vmslen += 3;
7798           *vmsptr++ = '\0';
7799           return SS$_NORMAL;
7800         }
7801       }
7802     }
7803   }
7804   else {        /* Absolute PATH handling */
7805   int sts;
7806   char * nextslash;
7807   int seg_len;
7808     /* Need to find out where root is */
7809
7810     /* In theory, this procedure should never get an absolute POSIX pathname
7811      * that can not be found on the POSIX root.
7812      * In practice, that can not be relied on, and things will show up
7813      * here that are a VMS device name or concealed logical name instead.
7814      * So to make things work, this procedure must be tolerant.
7815      */
7816     esa = (char *)PerlMem_malloc(vmspath_len);
7817     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7818
7819     sts = SS$_NORMAL;
7820     nextslash = strchr(&unixptr[1],'/');
7821     seg_len = 0;
7822     if (nextslash != NULL) {
7823       int cmp;
7824       seg_len = nextslash - &unixptr[1];
7825       my_strlcpy(vmspath, unixptr, seg_len + 2);
7826       cmp = 1;
7827       if (seg_len == 3) {
7828         cmp = strncmp(vmspath, "dev", 4);
7829         if (cmp == 0) {
7830             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7831             if (sts == SS$_NORMAL)
7832                 return SS$_NORMAL;
7833         }
7834       }
7835       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7836     }
7837
7838     if ($VMS_STATUS_SUCCESS(sts)) {
7839       /* This is verified to be a real path */
7840
7841       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7842       if ($VMS_STATUS_SUCCESS(sts)) {
7843         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
7844         vmsptr = vmspath + vmslen;
7845         unixptr++;
7846         if (unixptr < lastslash) {
7847         char * rptr;
7848           vmsptr--;
7849           *vmsptr++ = '.';
7850           dir_start = 1;
7851           dir_dot = 1;
7852           if (vmslen > 7) {
7853           int cmp;
7854             rptr = vmsptr - 7;
7855             cmp = strcmp(rptr,"000000.");
7856             if (cmp == 0) {
7857               vmslen -= 7;
7858               vmsptr -= 7;
7859               vmsptr[1] = '\0';
7860             } /* removing 6 zeros */
7861           } /* vmslen < 7, no 6 zeros possible */
7862         } /* Not in a directory */
7863       } /* Posix root found */
7864       else {
7865         /* No posix root, fall back to default directory */
7866         strcpy(vmspath, "SYS$DISK:[");
7867         vmsptr = &vmspath[10];
7868         vmslen = 10;
7869         if (unixptr > lastslash) {
7870            *vmsptr = ']';
7871            vmsptr++;
7872            vmslen++;
7873         }
7874         else {
7875            dir_start = 1;
7876         }
7877       }
7878     } /* end of verified real path handling */
7879     else {
7880     int add_6zero;
7881     int islnm;
7882
7883       /* Ok, we have a device or a concealed root that is not in POSIX
7884        * or we have garbage.  Make the best of it.
7885        */
7886
7887       /* Posix to VMS destroyed this, so copy it again */
7888       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
7889       vmslen = strlen(vmspath); /* We know we're truncating. */
7890       vmsptr = &vmsptr[vmslen];
7891       islnm = 0;
7892
7893       /* Now do we need to add the fake 6 zero directory to it? */
7894       add_6zero = 1;
7895       if ((*lastslash == '/') && (nextslash < lastslash)) {
7896         /* No there is another directory */
7897         add_6zero = 0;
7898       }
7899       else {
7900       int trnend;
7901       int cmp;
7902
7903         /* now we have foo:bar or foo:[000000]bar to decide from */
7904         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7905
7906         if (!islnm && !decc_posix_compliant_pathnames) {
7907
7908             cmp = strncmp("bin", vmspath, 4);
7909             if (cmp == 0) {
7910                 /* bin => SYS$SYSTEM: */
7911                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7912             }
7913             else {
7914                 /* tmp => SYS$SCRATCH: */
7915                 cmp = strncmp("tmp", vmspath, 4);
7916                 if (cmp == 0) {
7917                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7918                 }
7919             }
7920         }
7921
7922         trnend = islnm ? islnm - 1 : 0;
7923
7924         /* if this was a logical name, ']' or '>' must be present */
7925         /* if not a logical name, then assume a device and hope. */
7926         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7927
7928         /* if log name and trailing '.' then rooted - treat as device */
7929         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7930
7931         /* Fix me, if not a logical name, a device lookup should be
7932          * done to see if the device is file structured.  If the device
7933          * is not file structured, the 6 zeros should not be put on.
7934          *
7935          * As it is, perl is occasionally looking for dev:[000000]tty.
7936          * which looks a little strange.
7937          *
7938          * Not that easy to detect as "/dev" may be file structured with
7939          * special device files.
7940          */
7941
7942         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
7943             (&nextslash[1] == unixend)) {
7944           /* No real directory present */
7945           add_6zero = 1;
7946         }
7947       }
7948
7949       /* Put the device delimiter on */
7950       *vmsptr++ = ':';
7951       vmslen++;
7952       unixptr = nextslash;
7953       unixptr++;
7954
7955       /* Start directory if needed */
7956       if (!islnm || add_6zero) {
7957         *vmsptr++ = '[';
7958         vmslen++;
7959         dir_start = 1;
7960       }
7961
7962       /* add fake 000000] if needed */
7963       if (add_6zero) {
7964         *vmsptr++ = '0';
7965         *vmsptr++ = '0';
7966         *vmsptr++ = '0';
7967         *vmsptr++ = '0';
7968         *vmsptr++ = '0';
7969         *vmsptr++ = '0';
7970         *vmsptr++ = ']';
7971         vmslen += 7;
7972         dir_start = 0;
7973       }
7974
7975     } /* non-POSIX translation */
7976     PerlMem_free(esa);
7977   } /* End of relative/absolute path handling */
7978
7979   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7980   int dash_flag;
7981   int in_cnt;
7982   int out_cnt;
7983
7984     dash_flag = 0;
7985
7986     if (dir_start != 0) {
7987
7988       /* First characters in a directory are handled special */
7989       while ((*unixptr == '/') ||
7990              ((*unixptr == '.') &&
7991               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7992                 (&unixptr[1]==unixend)))) {
7993       int loop_flag;
7994
7995         loop_flag = 0;
7996
7997         /* Skip redundant / in specification */
7998         while ((*unixptr == '/') && (dir_start != 0)) {
7999           loop_flag = 1;
8000           unixptr++;
8001           if (unixptr == lastslash)
8002             break;
8003         }
8004         if (unixptr == lastslash)
8005           break;
8006
8007         /* Skip redundant ./ characters */
8008         while ((*unixptr == '.') &&
8009                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8010           loop_flag = 1;
8011           unixptr++;
8012           if (unixptr == lastslash)
8013             break;
8014           if (*unixptr == '/')
8015             unixptr++;
8016         }
8017         if (unixptr == lastslash)
8018           break;
8019
8020         /* Skip redundant ../ characters */
8021         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8022              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8023           /* Set the backing up flag */
8024           loop_flag = 1;
8025           dir_dot = 0;
8026           dash_flag = 1;
8027           *vmsptr++ = '-';
8028           vmslen++;
8029           unixptr++; /* first . */
8030           unixptr++; /* second . */
8031           if (unixptr == lastslash)
8032             break;
8033           if (*unixptr == '/') /* The slash */
8034             unixptr++;
8035         }
8036         if (unixptr == lastslash)
8037           break;
8038
8039         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8040         /* Not needed when VMS is pretending to be UNIX. */
8041
8042         /* Is this loop stuck because of too many dots? */
8043         if (loop_flag == 0) {
8044           /* Exit the loop and pass the rest through */
8045           break;
8046         }
8047       }
8048
8049       /* Are we done with directories yet? */
8050       if (unixptr >= lastslash) {
8051
8052         /* Watch out for trailing dots */
8053         if (dir_dot != 0) {
8054             vmslen --;
8055             vmsptr--;
8056         }
8057         *vmsptr++ = ']';
8058         vmslen++;
8059         dash_flag = 0;
8060         dir_start = 0;
8061         if (*unixptr == '/')
8062           unixptr++;
8063       }
8064       else {
8065         /* Have we stopped backing up? */
8066         if (dash_flag) {
8067           *vmsptr++ = '.';
8068           vmslen++;
8069           dash_flag = 0;
8070           /* dir_start continues to be = 1 */
8071         }
8072         if (*unixptr == '-') {
8073           *vmsptr++ = '^';
8074           *vmsptr++ = *unixptr++;
8075           vmslen += 2;
8076           dir_start = 0;
8077
8078           /* Now are we done with directories yet? */
8079           if (unixptr >= lastslash) {
8080
8081             /* Watch out for trailing dots */
8082             if (dir_dot != 0) {
8083               vmslen --;
8084               vmsptr--;
8085             }
8086
8087             *vmsptr++ = ']';
8088             vmslen++;
8089             dash_flag = 0;
8090             dir_start = 0;
8091           }
8092         }
8093       }
8094     }
8095
8096     /* All done? */
8097     if (unixptr >= unixend)
8098       break;
8099
8100     /* Normal characters - More EFS work probably needed */
8101     dir_start = 0;
8102     dir_dot = 0;
8103
8104     switch(*unixptr) {
8105     case '/':
8106         /* remove multiple / */
8107         while (unixptr[1] == '/') {
8108            unixptr++;
8109         }
8110         if (unixptr == lastslash) {
8111           /* Watch out for trailing dots */
8112           if (dir_dot != 0) {
8113             vmslen --;
8114             vmsptr--;
8115           }
8116           *vmsptr++ = ']';
8117         }
8118         else {
8119           dir_start = 1;
8120           *vmsptr++ = '.';
8121           dir_dot = 1;
8122
8123           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8124           /* Not needed when VMS is pretending to be UNIX. */
8125
8126         }
8127         dash_flag = 0;
8128         if (unixptr != unixend)
8129           unixptr++;
8130         vmslen++;
8131         break;
8132     case '.':
8133         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8134             (&unixptr[1] == unixend)) {
8135           *vmsptr++ = '^';
8136           *vmsptr++ = '.';
8137           vmslen += 2;
8138           unixptr++;
8139
8140           /* trailing dot ==> '^..' on VMS */
8141           if (unixptr == unixend) {
8142             *vmsptr++ = '.';
8143             vmslen++;
8144             unixptr++;
8145           }
8146           break;
8147         }
8148
8149         *vmsptr++ = *unixptr++;
8150         vmslen ++;
8151         break;
8152     case '"':
8153         if (quoted && (&unixptr[1] == unixend)) {
8154             unixptr++;
8155             break;
8156         }
8157         in_cnt = copy_expand_unix_filename_escape
8158                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8159         vmsptr += out_cnt;
8160         unixptr += in_cnt;
8161         break;
8162     case '~':
8163     case ';':
8164     case '\\':
8165     case '?':
8166     case ' ':
8167     default:
8168         in_cnt = copy_expand_unix_filename_escape
8169                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8170         vmsptr += out_cnt;
8171         unixptr += in_cnt;
8172         break;
8173     }
8174   }
8175
8176   /* Make sure directory is closed */
8177   if (unixptr == lastslash) {
8178     char *vmsptr2;
8179     vmsptr2 = vmsptr - 1;
8180
8181     if (*vmsptr2 != ']') {
8182       *vmsptr2--;
8183
8184       /* directories do not end in a dot bracket */
8185       if (*vmsptr2 == '.') {
8186         vmsptr2--;
8187
8188         /* ^. is allowed */
8189         if (*vmsptr2 != '^') {
8190           vmsptr--; /* back up over the dot */
8191         }
8192       }
8193       *vmsptr++ = ']';
8194     }
8195   }
8196   else {
8197     char *vmsptr2;
8198     /* Add a trailing dot if a file with no extension */
8199     vmsptr2 = vmsptr - 1;
8200     if ((vmslen > 1) &&
8201         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8202         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8203         *vmsptr++ = '.';
8204         vmslen++;
8205     }
8206   }
8207
8208   *vmsptr = '\0';
8209   return SS$_NORMAL;
8210 }
8211 #endif
8212
8213  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8214 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8215 {
8216 char * result;
8217 int utf8_flag;
8218
8219    /* If a UTF8 flag is being passed, honor it */
8220    utf8_flag = 0;
8221    if (utf8_fl != NULL) {
8222      utf8_flag = *utf8_fl;
8223     *utf8_fl = 0;
8224    }
8225
8226    if (utf8_flag) {
8227      /* If there is a possibility of UTF8, then if any UTF8 characters
8228         are present, then they must be converted to VTF-7
8229       */
8230      result = strcpy(rslt, path); /* FIX-ME */
8231    }
8232    else
8233      result = strcpy(rslt, path);
8234
8235    return result;
8236 }
8237
8238
8239
8240 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8241 static char *int_tovmsspec
8242    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8243   char *dirend;
8244   char *lastdot;
8245   char *cp1;
8246   const char *cp2;
8247   unsigned long int infront = 0, hasdir = 1;
8248   int rslt_len;
8249   int no_type_seen;
8250   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8251   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8252
8253   if (vms_debug_fileify) {
8254       if (path == NULL)
8255           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8256       else
8257           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8258   }
8259
8260   if (path == NULL) {
8261       /* If we fail, we should be setting errno */
8262       set_errno(EINVAL);
8263       set_vaxc_errno(SS$_BADPARAM);
8264       return NULL;
8265   }
8266   rslt_len = VMS_MAXRSS-1;
8267
8268   /* '.' and '..' are "[]" and "[-]" for a quick check */
8269   if (path[0] == '.') {
8270     if (path[1] == '\0') {
8271       strcpy(rslt,"[]");
8272       if (utf8_flag != NULL)
8273         *utf8_flag = 0;
8274       return rslt;
8275     }
8276     else {
8277       if (path[1] == '.' && path[2] == '\0') {
8278         strcpy(rslt,"[-]");
8279         if (utf8_flag != NULL)
8280            *utf8_flag = 0;
8281         return rslt;
8282       }
8283     }
8284   }
8285
8286    /* Posix specifications are now a native VMS format */
8287   /*--------------------------------------------------*/
8288 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8289   if (decc_posix_compliant_pathnames) {
8290     if (strncmp(path,"\"^UP^",5) == 0) {
8291       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8292       return rslt;
8293     }
8294   }
8295 #endif
8296
8297   /* This is really the only way to see if this is already in VMS format */
8298   sts = vms_split_path
8299        (path,
8300         &v_spec,
8301         &v_len,
8302         &r_spec,
8303         &r_len,
8304         &d_spec,
8305         &d_len,
8306         &n_spec,
8307         &n_len,
8308         &e_spec,
8309         &e_len,
8310         &vs_spec,
8311         &vs_len);
8312   if (sts == 0) {
8313     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8314        replacement, because the above parse just took care of most of
8315        what is needed to do vmspath when the specification is already
8316        in VMS format.
8317
8318        And if it is not already, it is easier to do the conversion as
8319        part of this routine than to call this routine and then work on
8320        the result.
8321      */
8322
8323     /* If VMS punctuation was found, it is already VMS format */
8324     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8325       if (utf8_flag != NULL)
8326         *utf8_flag = 0;
8327       my_strlcpy(rslt, path, VMS_MAXRSS);
8328       if (vms_debug_fileify) {
8329           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8330       }
8331       return rslt;
8332     }
8333     /* Now, what to do with trailing "." cases where there is no
8334        extension?  If this is a UNIX specification, and EFS characters
8335        are enabled, then the trailing "." should be converted to a "^.".
8336        But if this was already a VMS specification, then it should be
8337        left alone.
8338
8339        So in the case of ambiguity, leave the specification alone.
8340      */
8341
8342
8343     /* If there is a possibility of UTF8, then if any UTF8 characters
8344         are present, then they must be converted to VTF-7
8345      */
8346     if (utf8_flag != NULL)
8347       *utf8_flag = 0;
8348     my_strlcpy(rslt, path, VMS_MAXRSS);
8349     if (vms_debug_fileify) {
8350         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8351     }
8352     return rslt;
8353   }
8354
8355   dirend = strrchr(path,'/');
8356
8357   if (dirend == NULL) {
8358      char *macro_start;
8359      int has_macro;
8360
8361      /* If we get here with no UNIX directory delimiters, then this is
8362         not a complete file specification, either garbage a UNIX glob
8363         specification that can not be converted to a VMS wildcard, or
8364         it a UNIX shell macro.  MakeMaker wants shell macros passed
8365         through AS-IS,
8366
8367         utf8 flag setting needs to be preserved.
8368       */
8369       hasdir = 0;
8370
8371       has_macro = 0;
8372       macro_start = strchr(path,'$');
8373       if (macro_start != NULL) {
8374           if (macro_start[1] == '(') {
8375               has_macro = 1;
8376           }
8377       }
8378       if ((decc_efs_charset == 0) || (has_macro)) {
8379           my_strlcpy(rslt, path, VMS_MAXRSS);
8380           if (vms_debug_fileify) {
8381               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8382           }
8383           return rslt;
8384       }
8385   }
8386   else if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8387     if (!*(dirend+2)) dirend +=2;
8388     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8389     if (decc_efs_charset == 0) {
8390       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8391     }
8392   }
8393
8394   cp1 = rslt;
8395   cp2 = path;
8396   lastdot = strrchr(cp2,'.');
8397   if (*cp2 == '/') {
8398     char *trndev;
8399     int islnm, rooted;
8400     STRLEN trnend;
8401
8402     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8403     if (!*(cp2+1)) {
8404       if (decc_disable_posix_root) {
8405         strcpy(rslt,"sys$disk:[000000]");
8406       }
8407       else {
8408         strcpy(rslt,"sys$posix_root:[000000]");
8409       }
8410       if (utf8_flag != NULL)
8411         *utf8_flag = 0;
8412       if (vms_debug_fileify) {
8413           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8414       }
8415       return rslt;
8416     }
8417     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8418     *cp1 = '\0';
8419     trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8420     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8421     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8422
8423      /* DECC special handling */
8424     if (!islnm) {
8425       if (strcmp(rslt,"bin") == 0) {
8426         strcpy(rslt,"sys$system");
8427         cp1 = rslt + 10;
8428         *cp1 = 0;
8429         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8430       }
8431       else if (strcmp(rslt,"tmp") == 0) {
8432         strcpy(rslt,"sys$scratch");
8433         cp1 = rslt + 11;
8434         *cp1 = 0;
8435         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8436       }
8437       else if (!decc_disable_posix_root) {
8438         strcpy(rslt, "sys$posix_root");
8439         cp1 = rslt + 14;
8440         *cp1 = 0;
8441         cp2 = path;
8442         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8443         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8444       }
8445       else if (strcmp(rslt,"dev") == 0) {
8446         if (strncmp(cp2,"/null", 5) == 0) {
8447           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8448             strcpy(rslt,"NLA0");
8449             cp1 = rslt + 4;
8450             *cp1 = 0;
8451             cp2 = cp2 + 5;
8452             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8453           }
8454         }
8455       }
8456     }
8457
8458     trnend = islnm ? strlen(trndev) - 1 : 0;
8459     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8460     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8461     /* If the first element of the path is a logical name, determine
8462      * whether it has to be translated so we can add more directories. */
8463     if (!islnm || rooted) {
8464       *(cp1++) = ':';
8465       *(cp1++) = '[';
8466       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8467       else cp2++;
8468     }
8469     else {
8470       if (cp2 != dirend) {
8471         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8472         cp1 = rslt + trnend;
8473         if (*cp2 != 0) {
8474           *(cp1++) = '.';
8475           cp2++;
8476         }
8477       }
8478       else {
8479         if (decc_disable_posix_root) {
8480           *(cp1++) = ':';
8481           hasdir = 0;
8482         }
8483       }
8484     }
8485     PerlMem_free(trndev);
8486   }
8487   else {
8488     *(cp1++) = '[';
8489     if (*cp2 == '.') {
8490       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8491         cp2 += 2;         /* skip over "./" - it's redundant */
8492         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8493       }
8494       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8495         *(cp1++) = '-';                                 /* "../" --> "-" */
8496         cp2 += 3;
8497       }
8498       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8499                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8500         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8501         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8502         cp2 += 4;
8503       }
8504       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8505         /* Escape the extra dots in EFS file specifications */
8506         *(cp1++) = '^';
8507       }
8508       if (cp2 > dirend) cp2 = dirend;
8509     }
8510     else *(cp1++) = '.';
8511   }
8512   for (; cp2 < dirend; cp2++) {
8513     if (*cp2 == '/') {
8514       if (*(cp2-1) == '/') continue;
8515       if (*(cp1-1) != '.') *(cp1++) = '.';
8516       infront = 0;
8517     }
8518     else if (!infront && *cp2 == '.') {
8519       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8520       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8521       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8522         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8523         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8524         else {
8525           *(cp1++) = '-';
8526         }
8527         cp2 += 2;
8528         if (cp2 == dirend) break;
8529       }
8530       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8531                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8532         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8533         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8534         if (!*(cp2+3)) {
8535           *(cp1++) = '.';  /* Simulate trailing '/' */
8536           cp2 += 2;  /* for loop will incr this to == dirend */
8537         }
8538         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8539       }
8540       else {
8541         if (decc_efs_charset == 0)
8542           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8543         else {
8544           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8545           *(cp1++) = '.';
8546         }
8547       }
8548     }
8549     else {
8550       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8551       if (*cp2 == '.') {
8552         if (decc_efs_charset == 0)
8553           *(cp1++) = '_';
8554         else {
8555           *(cp1++) = '^';
8556           *(cp1++) = '.';
8557         }
8558       }
8559       else                  *(cp1++) =  *cp2;
8560       infront = 1;
8561     }
8562   }
8563   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8564   if (hasdir) *(cp1++) = ']';
8565   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8566   /* fixme for ODS5 */
8567   no_type_seen = 0;
8568   if (cp2 > lastdot)
8569     no_type_seen = 1;
8570   while (*cp2) {
8571     switch(*cp2) {
8572     case '?':
8573         if (decc_efs_charset == 0)
8574           *(cp1++) = '%';
8575         else
8576           *(cp1++) = '?';
8577         cp2++;
8578     case ' ':
8579         *(cp1)++ = '^';
8580         *(cp1)++ = '_';
8581         cp2++;
8582         break;
8583     case '.':
8584         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8585             decc_readdir_dropdotnotype) {
8586           *(cp1)++ = '^';
8587           *(cp1)++ = '.';
8588           cp2++;
8589
8590           /* trailing dot ==> '^..' on VMS */
8591           if (*cp2 == '\0') {
8592             *(cp1++) = '.';
8593             no_type_seen = 0;
8594           }
8595         }
8596         else {
8597           *(cp1++) = *(cp2++);
8598           no_type_seen = 0;
8599         }
8600         break;
8601     case '$':
8602          /* This could be a macro to be passed through */
8603         *(cp1++) = *(cp2++);
8604         if (*cp2 == '(') {
8605         const char * save_cp2;
8606         char * save_cp1;
8607         int is_macro;
8608
8609             /* paranoid check */
8610             save_cp2 = cp2;
8611             save_cp1 = cp1;
8612             is_macro = 0;
8613
8614             /* Test through */
8615             *(cp1++) = *(cp2++);
8616             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8617                 *(cp1++) = *(cp2++);
8618                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8619                     *(cp1++) = *(cp2++);
8620                 }
8621                 if (*cp2 == ')') {
8622                     *(cp1++) = *(cp2++);
8623                     is_macro = 1;
8624                 }
8625             }
8626             if (is_macro == 0) {
8627                 /* Not really a macro - never mind */
8628                 cp2 = save_cp2;
8629                 cp1 = save_cp1;
8630             }
8631         }
8632         break;
8633     case '\"':
8634     case '~':
8635     case '`':
8636     case '!':
8637     case '#':
8638     case '%':
8639     case '^':
8640         /* Don't escape again if following character is
8641          * already something we escape.
8642          */
8643         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8644             *(cp1++) = *(cp2++);
8645             break;
8646         }
8647         /* But otherwise fall through and escape it. */
8648     case '&':
8649     case '(':
8650     case ')':
8651     case '=':
8652     case '+':
8653     case '\'':
8654     case '@':
8655     case '[':
8656     case ']':
8657     case '{':
8658     case '}':
8659     case ':':
8660     case '\\':
8661     case '|':
8662     case '<':
8663     case '>':
8664         *(cp1++) = '^';
8665         *(cp1++) = *(cp2++);
8666         break;
8667     case ';':
8668         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8669          * which is wrong.  UNIX notation should be ".dir." unless
8670          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8671          * changing this behavior could break more things at this time.
8672          * efs character set effectively does not allow "." to be a version
8673          * delimiter as a further complication about changing this.
8674          */
8675         if (decc_filename_unix_report != 0) {
8676           *(cp1++) = '^';
8677         }
8678         *(cp1++) = *(cp2++);
8679         break;
8680     default:
8681         *(cp1++) = *(cp2++);
8682     }
8683   }
8684   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8685   char *lcp1;
8686     lcp1 = cp1;
8687     lcp1--;
8688      /* Fix me for "^]", but that requires making sure that you do
8689       * not back up past the start of the filename
8690       */
8691     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8692       *cp1++ = '.';
8693   }
8694   *cp1 = '\0';
8695
8696   if (utf8_flag != NULL)
8697     *utf8_flag = 0;
8698   if (vms_debug_fileify) {
8699       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8700   }
8701   return rslt;
8702
8703 }  /* end of int_tovmsspec() */
8704
8705
8706 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8707 static char *mp_do_tovmsspec
8708    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8709   static char __tovmsspec_retbuf[VMS_MAXRSS];
8710     char * vmsspec, *ret_spec, *ret_buf;
8711
8712     vmsspec = NULL;
8713     ret_buf = buf;
8714     if (ret_buf == NULL) {
8715         if (ts) {
8716             Newx(vmsspec, VMS_MAXRSS, char);
8717             if (vmsspec == NULL)
8718                 _ckvmssts(SS$_INSFMEM);
8719             ret_buf = vmsspec;
8720         } else {
8721             ret_buf = __tovmsspec_retbuf;
8722         }
8723     }
8724
8725     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8726
8727     if (ret_spec == NULL) {
8728        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8729        if (vmsspec)
8730            Safefree(vmsspec);
8731     }
8732
8733     return ret_spec;
8734
8735 }  /* end of mp_do_tovmsspec() */
8736 /*}}}*/
8737 /* External entry points */
8738 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8739   { return do_tovmsspec(path,buf,0,NULL); }
8740 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8741   { return do_tovmsspec(path,buf,1,NULL); }
8742 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8743   { return do_tovmsspec(path,buf,0,utf8_fl); }
8744 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8745   { return do_tovmsspec(path,buf,1,utf8_fl); }
8746
8747 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8748 /* Internal routine for use with out an explicit context present */
8749 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
8750
8751     char * ret_spec, *pathified;
8752
8753     if (path == NULL)
8754         return NULL;
8755
8756     pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8757     if (pathified == NULL)
8758         _ckvmssts_noperl(SS$_INSFMEM);
8759
8760     ret_spec = int_pathify_dirspec(path, pathified);
8761
8762     if (ret_spec == NULL) {
8763         PerlMem_free(pathified);
8764         return NULL;
8765     }
8766
8767     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8768
8769     PerlMem_free(pathified);
8770     return ret_spec;
8771
8772 }
8773
8774 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8775 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8776   static char __tovmspath_retbuf[VMS_MAXRSS];
8777   int vmslen;
8778   char *pathified, *vmsified, *cp;
8779
8780   if (path == NULL) return NULL;
8781   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8782   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8783   if (int_pathify_dirspec(path, pathified) == NULL) {
8784     PerlMem_free(pathified);
8785     return NULL;
8786   }
8787
8788   vmsified = NULL;
8789   if (buf == NULL)
8790      Newx(vmsified, VMS_MAXRSS, char);
8791   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8792     PerlMem_free(pathified);
8793     if (vmsified) Safefree(vmsified);
8794     return NULL;
8795   }
8796   PerlMem_free(pathified);
8797   if (buf) {
8798     return buf;
8799   }
8800   else if (ts) {
8801     vmslen = strlen(vmsified);
8802     Newx(cp,vmslen+1,char);
8803     memcpy(cp,vmsified,vmslen);
8804     cp[vmslen] = '\0';
8805     Safefree(vmsified);
8806     return cp;
8807   }
8808   else {
8809     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8810     Safefree(vmsified);
8811     return __tovmspath_retbuf;
8812   }
8813
8814 }  /* end of do_tovmspath() */
8815 /*}}}*/
8816 /* External entry points */
8817 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8818   { return do_tovmspath(path,buf,0, NULL); }
8819 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8820   { return do_tovmspath(path,buf,1, NULL); }
8821 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8822   { return do_tovmspath(path,buf,0,utf8_fl); }
8823 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8824   { return do_tovmspath(path,buf,1,utf8_fl); }
8825
8826
8827 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8828 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8829   static char __tounixpath_retbuf[VMS_MAXRSS];
8830   int unixlen;
8831   char *pathified, *unixified, *cp;
8832
8833   if (path == NULL) return NULL;
8834   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8835   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8836   if (int_pathify_dirspec(path, pathified) == NULL) {
8837     PerlMem_free(pathified);
8838     return NULL;
8839   }
8840
8841   unixified = NULL;
8842   if (buf == NULL) {
8843       Newx(unixified, VMS_MAXRSS, char);
8844   }
8845   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8846     PerlMem_free(pathified);
8847     if (unixified) Safefree(unixified);
8848     return NULL;
8849   }
8850   PerlMem_free(pathified);
8851   if (buf) {
8852     return buf;
8853   }
8854   else if (ts) {
8855     unixlen = strlen(unixified);
8856     Newx(cp,unixlen+1,char);
8857     memcpy(cp,unixified,unixlen);
8858     cp[unixlen] = '\0';
8859     Safefree(unixified);
8860     return cp;
8861   }
8862   else {
8863     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
8864     Safefree(unixified);
8865     return __tounixpath_retbuf;
8866   }
8867
8868 }  /* end of do_tounixpath() */
8869 /*}}}*/
8870 /* External entry points */
8871 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8872   { return do_tounixpath(path,buf,0,NULL); }
8873 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8874   { return do_tounixpath(path,buf,1,NULL); }
8875 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8876   { return do_tounixpath(path,buf,0,utf8_fl); }
8877 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8878   { return do_tounixpath(path,buf,1,utf8_fl); }
8879
8880 /*
8881  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8882  *
8883  *****************************************************************************
8884  *                                                                           *
8885  *  Copyright (C) 1989-1994, 2007 by                                         *
8886  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8887  *                                                                           *
8888  *  Permission is hereby granted for the reproduction of this software       *
8889  *  on condition that this copyright notice is included in source            *
8890  *  distributions of the software.  The code may be modified and             *
8891  *  distributed under the same terms as Perl itself.                         *
8892  *                                                                           *
8893  *  27-Aug-1994 Modified for inclusion in perl5                              *
8894  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8895  *****************************************************************************
8896  */
8897
8898 /*
8899  * getredirection() is intended to aid in porting C programs
8900  * to VMS (Vax-11 C).  The native VMS environment does not support
8901  * '>' and '<' I/O redirection, or command line wild card expansion,
8902  * or a command line pipe mechanism using the '|' AND background
8903  * command execution '&'.  All of these capabilities are provided to any
8904  * C program which calls this procedure as the first thing in the
8905  * main program.
8906  * The piping mechanism will probably work with almost any 'filter' type
8907  * of program.  With suitable modification, it may useful for other
8908  * portability problems as well.
8909  *
8910  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8911  */
8912 struct list_item
8913     {
8914     struct list_item *next;
8915     char *value;
8916     };
8917
8918 static void add_item(struct list_item **head,
8919                      struct list_item **tail,
8920                      char *value,
8921                      int *count);
8922
8923 static void mp_expand_wild_cards(pTHX_ char *item,
8924                                 struct list_item **head,
8925                                 struct list_item **tail,
8926                                 int *count);
8927
8928 static int background_process(pTHX_ int argc, char **argv);
8929
8930 static void pipe_and_fork(pTHX_ char **cmargv);
8931
8932 /*{{{ void getredirection(int *ac, char ***av)*/
8933 static void
8934 mp_getredirection(pTHX_ int *ac, char ***av)
8935 /*
8936  * Process vms redirection arg's.  Exit if any error is seen.
8937  * If getredirection() processes an argument, it is erased
8938  * from the vector.  getredirection() returns a new argc and argv value.
8939  * In the event that a background command is requested (by a trailing "&"),
8940  * this routine creates a background subprocess, and simply exits the program.
8941  *
8942  * Warning: do not try to simplify the code for vms.  The code
8943  * presupposes that getredirection() is called before any data is
8944  * read from stdin or written to stdout.
8945  *
8946  * Normal usage is as follows:
8947  *
8948  *      main(argc, argv)
8949  *      int             argc;
8950  *      char            *argv[];
8951  *      {
8952  *              getredirection(&argc, &argv);
8953  *      }
8954  */
8955 {
8956     int                 argc = *ac;     /* Argument Count         */
8957     char                **argv = *av;   /* Argument Vector        */
8958     char                *ap;            /* Argument pointer       */
8959     int                 j;              /* argv[] index           */
8960     int                 item_count = 0; /* Count of Items in List */
8961     struct list_item    *list_head = 0; /* First Item in List       */
8962     struct list_item    *list_tail;     /* Last Item in List        */
8963     char                *in = NULL;     /* Input File Name          */
8964     char                *out = NULL;    /* Output File Name         */
8965     char                *outmode = "w"; /* Mode to Open Output File */
8966     char                *err = NULL;    /* Error File Name          */
8967     char                *errmode = "w"; /* Mode to Open Error File  */
8968     int                 cmargc = 0;     /* Piped Command Arg Count  */
8969     char                **cmargv = NULL;/* Piped Command Arg Vector */
8970
8971     /*
8972      * First handle the case where the last thing on the line ends with
8973      * a '&'.  This indicates the desire for the command to be run in a
8974      * subprocess, so we satisfy that desire.
8975      */
8976     ap = argv[argc-1];
8977     if (0 == strcmp("&", ap))
8978        exit(background_process(aTHX_ --argc, argv));
8979     if (*ap && '&' == ap[strlen(ap)-1])
8980         {
8981         ap[strlen(ap)-1] = '\0';
8982        exit(background_process(aTHX_ argc, argv));
8983         }
8984     /*
8985      * Now we handle the general redirection cases that involve '>', '>>',
8986      * '<', and pipes '|'.
8987      */
8988     for (j = 0; j < argc; ++j)
8989         {
8990         if (0 == strcmp("<", argv[j]))
8991             {
8992             if (j+1 >= argc)
8993                 {
8994                 fprintf(stderr,"No input file after < on command line");
8995                 exit(LIB$_WRONUMARG);
8996                 }
8997             in = argv[++j];
8998             continue;
8999             }
9000         if ('<' == *(ap = argv[j]))
9001             {
9002             in = 1 + ap;
9003             continue;
9004             }
9005         if (0 == strcmp(">", ap))
9006             {
9007             if (j+1 >= argc)
9008                 {
9009                 fprintf(stderr,"No output file after > on command line");
9010                 exit(LIB$_WRONUMARG);
9011                 }
9012             out = argv[++j];
9013             continue;
9014             }
9015         if ('>' == *ap)
9016             {
9017             if ('>' == ap[1])
9018                 {
9019                 outmode = "a";
9020                 if ('\0' == ap[2])
9021                     out = argv[++j];
9022                 else
9023                     out = 2 + ap;
9024                 }
9025             else
9026                 out = 1 + ap;
9027             if (j >= argc)
9028                 {
9029                 fprintf(stderr,"No output file after > or >> on command line");
9030                 exit(LIB$_WRONUMARG);
9031                 }
9032             continue;
9033             }
9034         if (('2' == *ap) && ('>' == ap[1]))
9035             {
9036             if ('>' == ap[2])
9037                 {
9038                 errmode = "a";
9039                 if ('\0' == ap[3])
9040                     err = argv[++j];
9041                 else
9042                     err = 3 + ap;
9043                 }
9044             else
9045                 if ('\0' == ap[2])
9046                     err = argv[++j];
9047                 else
9048                     err = 2 + ap;
9049             if (j >= argc)
9050                 {
9051                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9052                 exit(LIB$_WRONUMARG);
9053                 }
9054             continue;
9055             }
9056         if (0 == strcmp("|", argv[j]))
9057             {
9058             if (j+1 >= argc)
9059                 {
9060                 fprintf(stderr,"No command into which to pipe on command line");
9061                 exit(LIB$_WRONUMARG);
9062                 }
9063             cmargc = argc-(j+1);
9064             cmargv = &argv[j+1];
9065             argc = j;
9066             continue;
9067             }
9068         if ('|' == *(ap = argv[j]))
9069             {
9070             ++argv[j];
9071             cmargc = argc-j;
9072             cmargv = &argv[j];
9073             argc = j;
9074             continue;
9075             }
9076         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9077         }
9078     /*
9079      * Allocate and fill in the new argument vector, Some Unix's terminate
9080      * the list with an extra null pointer.
9081      */
9082     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9083     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9084     *av = argv;
9085     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9086         argv[j] = list_head->value;
9087     *ac = item_count;
9088     if (cmargv != NULL)
9089         {
9090         if (out != NULL)
9091             {
9092             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9093             exit(LIB$_INVARGORD);
9094             }
9095         pipe_and_fork(aTHX_ cmargv);
9096         }
9097
9098     /* Check for input from a pipe (mailbox) */
9099
9100     if (in == NULL && 1 == isapipe(0))
9101         {
9102         char mbxname[L_tmpnam];
9103         long int bufsize;
9104         long int dvi_item = DVI$_DEVBUFSIZ;
9105         $DESCRIPTOR(mbxnam, "");
9106         $DESCRIPTOR(mbxdevnam, "");
9107
9108         /* Input from a pipe, reopen it in binary mode to disable       */
9109         /* carriage control processing.                                 */
9110
9111         fgetname(stdin, mbxname, 1);
9112         mbxnam.dsc$a_pointer = mbxname;
9113         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9114         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9115         mbxdevnam.dsc$a_pointer = mbxname;
9116         mbxdevnam.dsc$w_length = sizeof(mbxname);
9117         dvi_item = DVI$_DEVNAM;
9118         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9119         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9120         set_errno(0);
9121         set_vaxc_errno(1);
9122         freopen(mbxname, "rb", stdin);
9123         if (errno != 0)
9124             {
9125             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9126             exit(vaxc$errno);
9127             }
9128         }
9129     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9130         {
9131         fprintf(stderr,"Can't open input file %s as stdin",in);
9132         exit(vaxc$errno);
9133         }
9134     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9135         {
9136         fprintf(stderr,"Can't open output file %s as stdout",out);
9137         exit(vaxc$errno);
9138         }
9139         if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
9140
9141     if (err != NULL) {
9142         if (strcmp(err,"&1") == 0) {
9143             dup2(fileno(stdout), fileno(stderr));
9144             vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
9145         } else {
9146         FILE *tmperr;
9147         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9148             {
9149             fprintf(stderr,"Can't open error file %s as stderr",err);
9150             exit(vaxc$errno);
9151             }
9152             fclose(tmperr);
9153            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9154                 {
9155                 exit(vaxc$errno);
9156                 }
9157             vmssetuserlnm("SYS$ERROR", err);
9158         }
9159         }
9160 #ifdef ARGPROC_DEBUG
9161     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9162     for (j = 0; j < *ac;  ++j)
9163         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9164 #endif
9165    /* Clear errors we may have hit expanding wildcards, so they don't
9166       show up in Perl's $! later */
9167    set_errno(0); set_vaxc_errno(1);
9168 }  /* end of getredirection() */
9169 /*}}}*/
9170
9171 static void add_item(struct list_item **head,
9172                      struct list_item **tail,
9173                      char *value,
9174                      int *count)
9175 {
9176     if (*head == 0)
9177         {
9178         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9179         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9180         *tail = *head;
9181         }
9182     else {
9183         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9184         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9185         *tail = (*tail)->next;
9186         }
9187     (*tail)->value = value;
9188     ++(*count);
9189 }
9190
9191 static void mp_expand_wild_cards(pTHX_ char *item,
9192                               struct list_item **head,
9193                               struct list_item **tail,
9194                               int *count)
9195 {
9196 int expcount = 0;
9197 unsigned long int context = 0;
9198 int isunix = 0;
9199 int item_len = 0;
9200 char *had_version;
9201 char *had_device;
9202 int had_directory;
9203 char *devdir,*cp;
9204 char *vmsspec;
9205 $DESCRIPTOR(filespec, "");
9206 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9207 $DESCRIPTOR(resultspec, "");
9208 unsigned long int lff_flags = 0;
9209 int sts;
9210 int rms_sts;
9211
9212 #ifdef VMS_LONGNAME_SUPPORT
9213     lff_flags = LIB$M_FIL_LONG_NAMES;
9214 #endif
9215
9216     for (cp = item; *cp; cp++) {
9217         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9218         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9219     }
9220     if (!*cp || isspace(*cp))
9221         {
9222         add_item(head, tail, item, count);
9223         return;
9224         }
9225     else
9226         {
9227      /* "double quoted" wild card expressions pass as is */
9228      /* From DCL that means using e.g.:                  */
9229      /* perl program """perl.*"""                        */
9230      item_len = strlen(item);
9231      if ( '"' == *item && '"' == item[item_len-1] )
9232        {
9233        item++;
9234        item[item_len-2] = '\0';
9235        add_item(head, tail, item, count);
9236        return;
9237        }
9238      }
9239     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9240     resultspec.dsc$b_class = DSC$K_CLASS_D;
9241     resultspec.dsc$a_pointer = NULL;
9242     vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9243     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9244     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9245       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9246     if (!isunix || !filespec.dsc$a_pointer)
9247       filespec.dsc$a_pointer = item;
9248     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9249     /*
9250      * Only return version specs, if the caller specified a version
9251      */
9252     had_version = strchr(item, ';');
9253     /*
9254      * Only return device and directory specs, if the caller specified either.
9255      */
9256     had_device = strchr(item, ':');
9257     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9258
9259     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9260                                  (&filespec, &resultspec, &context,
9261                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9262         {
9263         char *string;
9264         char *c;
9265
9266         string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9267         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9268         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9269         if (NULL == had_version)
9270             *(strrchr(string, ';')) = '\0';
9271         if ((!had_directory) && (had_device == NULL))
9272             {
9273             if (NULL == (devdir = strrchr(string, ']')))
9274                 devdir = strrchr(string, '>');
9275             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9276             }
9277         /*
9278          * Be consistent with what the C RTL has already done to the rest of
9279          * the argv items and lowercase all of these names.
9280          */
9281         if (!decc_efs_case_preserve) {
9282             for (c = string; *c; ++c)
9283             if (isupper(*c))
9284                 *c = tolower(*c);
9285         }
9286         if (isunix) trim_unixpath(string,item,1);
9287         add_item(head, tail, string, count);
9288         ++expcount;
9289     }
9290     PerlMem_free(vmsspec);
9291     if (sts != RMS$_NMF)
9292         {
9293         set_vaxc_errno(sts);
9294         switch (sts)
9295             {
9296             case RMS$_FNF: case RMS$_DNF:
9297                 set_errno(ENOENT); break;
9298             case RMS$_DIR:
9299                 set_errno(ENOTDIR); break;
9300             case RMS$_DEV:
9301                 set_errno(ENODEV); break;
9302             case RMS$_FNM: case RMS$_SYN:
9303                 set_errno(EINVAL); break;
9304             case RMS$_PRV:
9305                 set_errno(EACCES); break;
9306             default:
9307                 _ckvmssts_noperl(sts);
9308             }
9309         }
9310     if (expcount == 0)
9311         add_item(head, tail, item, count);
9312     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9313     _ckvmssts_noperl(lib$find_file_end(&context));
9314 }
9315
9316 static int child_st[2];/* Event Flag set when child process completes   */
9317
9318 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9319
9320 static unsigned long int exit_handler(void)
9321 {
9322 short iosb[4];
9323
9324     if (0 == child_st[0])
9325         {
9326 #ifdef ARGPROC_DEBUG
9327         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9328 #endif
9329         fflush(stdout);     /* Have to flush pipe for binary data to    */
9330                             /* terminate properly -- <tp@mccall.com>    */
9331         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9332         sys$dassgn(child_chan);
9333         fclose(stdout);
9334         sys$synch(0, child_st);
9335         }
9336     return(1);
9337 }
9338
9339 static void sig_child(int chan)
9340 {
9341 #ifdef ARGPROC_DEBUG
9342     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9343 #endif
9344     if (child_st[0] == 0)
9345         child_st[0] = 1;
9346 }
9347
9348 static struct exit_control_block exit_block =
9349     {
9350     0,
9351     exit_handler,
9352     1,
9353     &exit_block.exit_status,
9354     0
9355     };
9356
9357 static void
9358 pipe_and_fork(pTHX_ char **cmargv)
9359 {
9360     PerlIO *fp;
9361     struct dsc$descriptor_s *vmscmd;
9362     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9363     int sts, j, l, ismcr, quote, tquote = 0;
9364
9365     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9366     vms_execfree(vmscmd);
9367
9368     j = l = 0;
9369     p = subcmd;
9370     q = cmargv[0];
9371     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9372               && toupper(*(q+2)) == 'R' && !*(q+3);
9373
9374     while (q && l < MAX_DCL_LINE_LENGTH) {
9375         if (!*q) {
9376             if (j > 0 && quote) {
9377                 *p++ = '"';
9378                 l++;
9379             }
9380             q = cmargv[++j];
9381             if (q) {
9382                 if (ismcr && j > 1) quote = 1;
9383                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9384                 *p++ = ' ';
9385                 l++;
9386                 if (quote || tquote) {
9387                     *p++ = '"';
9388                     l++;
9389                 }
9390             }
9391         } else {
9392             if ((quote||tquote) && *q == '"') {
9393                 *p++ = '"';
9394                 l++;
9395             }
9396             *p++ = *q++;
9397             l++;
9398         }
9399     }
9400     *p = '\0';
9401
9402     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9403     if (fp == NULL) {
9404         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9405     }
9406 }
9407
9408 static int background_process(pTHX_ int argc, char **argv)
9409 {
9410 char command[MAX_DCL_SYMBOL + 1] = "$";
9411 $DESCRIPTOR(value, "");
9412 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9413 static $DESCRIPTOR(null, "NLA0:");
9414 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9415 char pidstring[80];
9416 $DESCRIPTOR(pidstr, "");
9417 int pid;
9418 unsigned long int flags = 17, one = 1, retsts;
9419 int len;
9420
9421     len = my_strlcat(command, argv[0], sizeof(command));
9422     while (--argc && (len < MAX_DCL_SYMBOL))
9423         {
9424         my_strlcat(command, " \"", sizeof(command));
9425         my_strlcat(command, *(++argv), sizeof(command));
9426         len = my_strlcat(command, "\"", sizeof(command));
9427         }
9428     value.dsc$a_pointer = command;
9429     value.dsc$w_length = strlen(value.dsc$a_pointer);
9430     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9431     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9432     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9433         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9434     }
9435     else {
9436         _ckvmssts_noperl(retsts);
9437     }
9438 #ifdef ARGPROC_DEBUG
9439     PerlIO_printf(Perl_debug_log, "%s\n", command);
9440 #endif
9441     sprintf(pidstring, "%08X", pid);
9442     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9443     pidstr.dsc$a_pointer = pidstring;
9444     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9445     lib$set_symbol(&pidsymbol, &pidstr);
9446     return(SS$_NORMAL);
9447 }
9448 /*}}}*/
9449 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9450
9451
9452 /* OS-specific initialization at image activation (not thread startup) */
9453 /* Older VAXC header files lack these constants */
9454 #ifndef JPI$_RIGHTS_SIZE
9455 #  define JPI$_RIGHTS_SIZE 817
9456 #endif
9457 #ifndef KGB$M_SUBSYSTEM
9458 #  define KGB$M_SUBSYSTEM 0x8
9459 #endif
9460
9461 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9462
9463 /*{{{void vms_image_init(int *, char ***)*/
9464 void
9465 vms_image_init(int *argcp, char ***argvp)
9466 {
9467   int status;
9468   char eqv[LNM$C_NAMLENGTH+1] = "";
9469   unsigned int len, tabct = 8, tabidx = 0;
9470   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9471   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9472   unsigned short int dummy, rlen;
9473   struct dsc$descriptor_s **tabvec;
9474 #if defined(PERL_IMPLICIT_CONTEXT)
9475   pTHX = NULL;
9476 #endif
9477   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9478                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9479                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9480                                  {          0,                0,    0,      0} };
9481
9482 #ifdef KILL_BY_SIGPRC
9483     Perl_csighandler_init();
9484 #endif
9485
9486 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9487     /* This was moved from the pre-image init handler because on threaded */
9488     /* Perl it was always returning 0 for the default value. */
9489     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9490     if (status > 0) {
9491         int s;
9492         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9493         if (s > 0) {
9494             int initial;
9495             initial = decc$feature_get_value(s, 4);
9496             if (initial > 0) {
9497                 /* initial is: 0 if nothing has set the feature */
9498                 /*            -1 if initialized to default */
9499                 /*             1 if set by logical name */
9500                 /*             2 if set by decc$feature_set_value */
9501                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9502
9503                 /* If the value is not valid, force the feature off */
9504                 if (decc_disable_posix_root < 0) {
9505                     decc$feature_set_value(s, 1, 1);
9506                     decc_disable_posix_root = 1;
9507                 }
9508             }
9509             else {
9510                 /* Nothing has asked for it explicitly, so use our own default. */
9511                 decc_disable_posix_root = 1;
9512                 decc$feature_set_value(s, 1, 1);
9513             }
9514         }
9515     }
9516 #endif
9517
9518   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9519   _ckvmssts_noperl(iosb[0]);
9520   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9521     if (iprv[i]) {           /* Running image installed with privs? */
9522       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9523       will_taint = TRUE;
9524       break;
9525     }
9526   }
9527   /* Rights identifiers might trigger tainting as well. */
9528   if (!will_taint && (rlen || rsz)) {
9529     while (rlen < rsz) {
9530       /* We didn't get all the identifiers on the first pass.  Allocate a
9531        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9532        * were needed to hold all identifiers at time of last call; we'll
9533        * allocate that many unsigned long ints), and go back and get 'em.
9534        * If it gave us less than it wanted to despite ample buffer space,
9535        * something's broken.  Is your system missing a system identifier?
9536        */
9537       if (rsz <= jpilist[1].buflen) {
9538          /* Perl_croak accvios when used this early in startup. */
9539          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9540                          rsz, (unsigned long) jpilist[1].buflen,
9541                          "Check your rights database for corruption.\n");
9542          exit(SS$_ABORT);
9543       }
9544       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9545       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9546       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9547       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9548       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9549       _ckvmssts_noperl(iosb[0]);
9550     }
9551     mask = (unsigned long int *)jpilist[1].bufadr;
9552     /* Check attribute flags for each identifier (2nd longword); protected
9553      * subsystem identifiers trigger tainting.
9554      */
9555     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9556       if (mask[i] & KGB$M_SUBSYSTEM) {
9557         will_taint = TRUE;
9558         break;
9559       }
9560     }
9561     if (mask != rlst) PerlMem_free(mask);
9562   }
9563
9564   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9565    * logical, some versions of the CRTL will add a phanthom /000000/
9566    * directory.  This needs to be removed.
9567    */
9568   if (decc_filename_unix_report) {
9569   char * zeros;
9570   int ulen;
9571     ulen = strlen(argvp[0][0]);
9572     if (ulen > 7) {
9573       zeros = strstr(argvp[0][0], "/000000/");
9574       if (zeros != NULL) {
9575         int mlen;
9576         mlen = ulen - (zeros - argvp[0][0]) - 7;
9577         memmove(zeros, &zeros[7], mlen);
9578         ulen = ulen - 7;
9579         argvp[0][0][ulen] = '\0';
9580       }
9581     }
9582     /* It also may have a trailing dot that needs to be removed otherwise
9583      * it will be converted to VMS mode incorrectly.
9584      */
9585     ulen--;
9586     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9587       argvp[0][0][ulen] = '\0';
9588   }
9589
9590   /* We need to use this hack to tell Perl it should run with tainting,
9591    * since its tainting flag may be part of the PL_curinterp struct, which
9592    * hasn't been allocated when vms_image_init() is called.
9593    */
9594   if (will_taint) {
9595     char **newargv, **oldargv;
9596     oldargv = *argvp;
9597     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9598     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9599     newargv[0] = oldargv[0];
9600     newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9601     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9602     strcpy(newargv[1], "-T");
9603     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9604     (*argcp)++;
9605     newargv[*argcp] = NULL;
9606     /* We orphan the old argv, since we don't know where it's come from,
9607      * so we don't know how to free it.
9608      */
9609     *argvp = newargv;
9610   }
9611   else {  /* Did user explicitly request tainting? */
9612     int i;
9613     char *cp, **av = *argvp;
9614     for (i = 1; i < *argcp; i++) {
9615       if (*av[i] != '-') break;
9616       for (cp = av[i]+1; *cp; cp++) {
9617         if (*cp == 'T') { will_taint = 1; break; }
9618         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9619                   strchr("DFIiMmx",*cp)) break;
9620       }
9621       if (will_taint) break;
9622     }
9623   }
9624
9625   for (tabidx = 0;
9626        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9627        tabidx++) {
9628     if (!tabidx) {
9629       tabvec = (struct dsc$descriptor_s **)
9630             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9631       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9632     }
9633     else if (tabidx >= tabct) {
9634       tabct += 8;
9635       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9636       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9637     }
9638     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9639     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9640     tabvec[tabidx]->dsc$w_length  = 0;
9641     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9642     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9643     tabvec[tabidx]->dsc$a_pointer = NULL;
9644     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9645   }
9646   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9647
9648   getredirection(argcp,argvp);
9649 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9650   {
9651 # include <reentrancy.h>
9652   decc$set_reentrancy(C$C_MULTITHREAD);
9653   }
9654 #endif
9655   return;
9656 }
9657 /*}}}*/
9658
9659
9660 /* trim_unixpath()
9661  * Trim Unix-style prefix off filespec, so it looks like what a shell
9662  * glob expansion would return (i.e. from specified prefix on, not
9663  * full path).  Note that returned filespec is Unix-style, regardless
9664  * of whether input filespec was VMS-style or Unix-style.
9665  *
9666  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9667  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9668  * vector of options; at present, only bit 0 is used, and if set tells
9669  * trim unixpath to try the current default directory as a prefix when
9670  * presented with a possibly ambiguous ... wildcard.
9671  *
9672  * Returns !=0 on success, with trimmed filespec replacing contents of
9673  * fspec, and 0 on failure, with contents of fpsec unchanged.
9674  */
9675 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9676 int
9677 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9678 {
9679   char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9680   int tmplen, reslen = 0, dirs = 0;
9681
9682   if (!wildspec || !fspec) return 0;
9683
9684   unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9685   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9686   tplate = unixwild;
9687   if (strpbrk(wildspec,"]>:") != NULL) {
9688     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9689         PerlMem_free(unixwild);
9690         return 0;
9691     }
9692   }
9693   else {
9694     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9695   }
9696   unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9697   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9698   if (strpbrk(fspec,"]>:") != NULL) {
9699     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9700         PerlMem_free(unixwild);
9701         PerlMem_free(unixified);
9702         return 0;
9703     }
9704     else base = unixified;
9705     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9706      * check to see that final result fits into (isn't longer than) fspec */
9707     reslen = strlen(fspec);
9708   }
9709   else base = fspec;
9710
9711   /* No prefix or absolute path on wildcard, so nothing to remove */
9712   if (!*tplate || *tplate == '/') {
9713     PerlMem_free(unixwild);
9714     if (base == fspec) {
9715         PerlMem_free(unixified);
9716         return 1;
9717     }
9718     tmplen = strlen(unixified);
9719     if (tmplen > reslen) {
9720         PerlMem_free(unixified);
9721         return 0;  /* not enough space */
9722     }
9723     /* Copy unixified resultant, including trailing NUL */
9724     memmove(fspec,unixified,tmplen+1);
9725     PerlMem_free(unixified);
9726     return 1;
9727   }
9728
9729   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9730   if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9731     for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9732     for (cp1 = end ;cp1 >= base; cp1--)
9733       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9734         { cp1++; break; }
9735     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9736     PerlMem_free(unixified);
9737     PerlMem_free(unixwild);
9738     return 1;
9739   }
9740   else {
9741     char *tpl, *lcres;
9742     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9743     int ells = 1, totells, segdirs, match;
9744     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9745                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9746
9747     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9748     totells = ells;
9749     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9750     tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9751     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9752     if (ellipsis == tplate && opts & 1) {
9753       /* Template begins with an ellipsis.  Since we can't tell how many
9754        * directory names at the front of the resultant to keep for an
9755        * arbitrary starting point, we arbitrarily choose the current
9756        * default directory as a starting point.  If it's there as a prefix,
9757        * clip it off.  If not, fall through and act as if the leading
9758        * ellipsis weren't there (i.e. return shortest possible path that
9759        * could match template).
9760        */
9761       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9762           PerlMem_free(tpl);
9763           PerlMem_free(unixified);
9764           PerlMem_free(unixwild);
9765           return 0;
9766       }
9767       if (!decc_efs_case_preserve) {
9768         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9769           if (_tolower(*cp1) != _tolower(*cp2)) break;
9770       }
9771       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9772       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9773       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9774         memmove(fspec,cp2+1,end - cp2);
9775         PerlMem_free(tpl);
9776         PerlMem_free(unixified);
9777         PerlMem_free(unixwild);
9778         return 1;
9779       }
9780     }
9781     /* First off, back up over constant elements at end of path */
9782     if (dirs) {
9783       for (front = end ; front >= base; front--)
9784          if (*front == '/' && !dirs--) { front++; break; }
9785     }
9786     lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9787     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9788     for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9789          cp1++,cp2++) {
9790             if (!decc_efs_case_preserve) {
9791                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9792             }
9793             else {
9794                 *cp2 = *cp1;
9795             }
9796     }
9797     if (cp1 != '\0') {
9798         PerlMem_free(tpl);
9799         PerlMem_free(unixified);
9800         PerlMem_free(unixwild);
9801         PerlMem_free(lcres);
9802         return 0;  /* Path too long. */
9803     }
9804     lcend = cp2;
9805     *cp2 = '\0';  /* Pick up with memcpy later */
9806     lcfront = lcres + (front - base);
9807     /* Now skip over each ellipsis and try to match the path in front of it. */
9808     while (ells--) {
9809       for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9810         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9811             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9812       if (cp1 < tplate) break; /* template started with an ellipsis */
9813       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9814         ellipsis = cp1; continue;
9815       }
9816       wilddsc.dsc$a_pointer = tpl;
9817       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9818       nextell = cp1;
9819       for (segdirs = 0, cp2 = tpl;
9820            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9821            cp1++, cp2++) {
9822          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9823          else {
9824             if (!decc_efs_case_preserve) {
9825               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9826             }
9827             else {
9828               *cp2 = *cp1;  /* else preserve case for match */
9829             }
9830          }
9831          if (*cp2 == '/') segdirs++;
9832       }
9833       if (cp1 != ellipsis - 1) {
9834           PerlMem_free(tpl);
9835           PerlMem_free(unixified);
9836           PerlMem_free(unixwild);
9837           PerlMem_free(lcres);
9838           return 0; /* Path too long */
9839       }
9840       /* Back up at least as many dirs as in template before matching */
9841       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9842         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9843       for (match = 0; cp1 > lcres;) {
9844         resdsc.dsc$a_pointer = cp1;
9845         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9846           match++;
9847           if (match == 1) lcfront = cp1;
9848         }
9849         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9850       }
9851       if (!match) {
9852         PerlMem_free(tpl);
9853         PerlMem_free(unixified);
9854         PerlMem_free(unixwild);
9855         PerlMem_free(lcres);
9856         return 0;  /* Can't find prefix ??? */
9857       }
9858       if (match > 1 && opts & 1) {
9859         /* This ... wildcard could cover more than one set of dirs (i.e.
9860          * a set of similar dir names is repeated).  If the template
9861          * contains more than 1 ..., upstream elements could resolve the
9862          * ambiguity, but it's not worth a full backtracking setup here.
9863          * As a quick heuristic, clip off the current default directory
9864          * if it's present to find the trimmed spec, else use the
9865          * shortest string that this ... could cover.
9866          */
9867         char def[NAM$C_MAXRSS+1], *st;
9868
9869         if (getcwd(def, sizeof def,0) == NULL) {
9870             PerlMem_free(unixified);
9871             PerlMem_free(unixwild);
9872             PerlMem_free(lcres);
9873             PerlMem_free(tpl);
9874             return 0;
9875         }
9876         if (!decc_efs_case_preserve) {
9877           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9878             if (_tolower(*cp1) != _tolower(*cp2)) break;
9879         }
9880         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9881         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9882         if (*cp1 == '\0' && *cp2 == '/') {
9883           memmove(fspec,cp2+1,end - cp2);
9884           PerlMem_free(tpl);
9885           PerlMem_free(unixified);
9886           PerlMem_free(unixwild);
9887           PerlMem_free(lcres);
9888           return 1;
9889         }
9890         /* Nope -- stick with lcfront from above and keep going. */
9891       }
9892     }
9893     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9894     PerlMem_free(tpl);
9895     PerlMem_free(unixified);
9896     PerlMem_free(unixwild);
9897     PerlMem_free(lcres);
9898     return 1;
9899   }
9900
9901 }  /* end of trim_unixpath() */
9902 /*}}}*/
9903
9904
9905 /*
9906  *  VMS readdir() routines.
9907  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9908  *
9909  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9910  *  Minor modifications to original routines.
9911  */
9912
9913 /* readdir may have been redefined by reentr.h, so make sure we get
9914  * the local version for what we do here.
9915  */
9916 #ifdef readdir
9917 # undef readdir
9918 #endif
9919 #if !defined(PERL_IMPLICIT_CONTEXT)
9920 # define readdir Perl_readdir
9921 #else
9922 # define readdir(a) Perl_readdir(aTHX_ a)
9923 #endif
9924
9925     /* Number of elements in vms_versions array */
9926 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9927
9928 /*
9929  *  Open a directory, return a handle for later use.
9930  */
9931 /*{{{ DIR *opendir(char*name) */
9932 DIR *
9933 Perl_opendir(pTHX_ const char *name)
9934 {
9935     DIR *dd;
9936     char *dir;
9937     Stat_t sb;
9938
9939     Newx(dir, VMS_MAXRSS, char);
9940     if (int_tovmspath(name, dir, NULL) == NULL) {
9941       Safefree(dir);
9942       return NULL;
9943     }
9944     /* Check access before stat; otherwise stat does not
9945      * accurately report whether it's a directory.
9946      */
9947     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9948       /* cando_by_name has already set errno */
9949       Safefree(dir);
9950       return NULL;
9951     }
9952     if (flex_stat(dir,&sb) == -1) return NULL;
9953     if (!S_ISDIR(sb.st_mode)) {
9954       Safefree(dir);
9955       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9956       return NULL;
9957     }
9958     /* Get memory for the handle, and the pattern. */
9959     Newx(dd,1,DIR);
9960     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9961
9962     /* Fill in the fields; mainly playing with the descriptor. */
9963     sprintf(dd->pattern, "%s*.*",dir);
9964     Safefree(dir);
9965     dd->context = 0;
9966     dd->count = 0;
9967     dd->flags = 0;
9968     /* By saying we always want the result of readdir() in unix format, we
9969      * are really saying we want all the escapes removed.  Otherwise the caller,
9970      * having no way to know whether it's already in VMS format, might send it
9971      * through tovmsspec again, thus double escaping.
9972      */
9973     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9974     dd->pat.dsc$a_pointer = dd->pattern;
9975     dd->pat.dsc$w_length = strlen(dd->pattern);
9976     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9977     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9978 #if defined(USE_ITHREADS)
9979     Newx(dd->mutex,1,perl_mutex);
9980     MUTEX_INIT( (perl_mutex *) dd->mutex );
9981 #else
9982     dd->mutex = NULL;
9983 #endif
9984
9985     return dd;
9986 }  /* end of opendir() */
9987 /*}}}*/
9988
9989 /*
9990  *  Set the flag to indicate we want versions or not.
9991  */
9992 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9993 void
9994 vmsreaddirversions(DIR *dd, int flag)
9995 {
9996     if (flag)
9997         dd->flags |= PERL_VMSDIR_M_VERSIONS;
9998     else
9999         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10000 }
10001 /*}}}*/
10002
10003 /*
10004  *  Free up an opened directory.
10005  */
10006 /*{{{ void closedir(DIR *dd)*/
10007 void
10008 Perl_closedir(DIR *dd)
10009 {
10010     int sts;
10011
10012     sts = lib$find_file_end(&dd->context);
10013     Safefree(dd->pattern);
10014 #if defined(USE_ITHREADS)
10015     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10016     Safefree(dd->mutex);
10017 #endif
10018     Safefree(dd);
10019 }
10020 /*}}}*/
10021
10022 /*
10023  *  Collect all the version numbers for the current file.
10024  */
10025 static void
10026 collectversions(pTHX_ DIR *dd)
10027 {
10028     struct dsc$descriptor_s     pat;
10029     struct dsc$descriptor_s     res;
10030     struct dirent *e;
10031     char *p, *text, *buff;
10032     int i;
10033     unsigned long context, tmpsts;
10034
10035     /* Convenient shorthand. */
10036     e = &dd->entry;
10037
10038     /* Add the version wildcard, ignoring the "*.*" put on before */
10039     i = strlen(dd->pattern);
10040     Newx(text,i + e->d_namlen + 3,char);
10041     my_strlcpy(text, dd->pattern, i + 1);
10042     sprintf(&text[i - 3], "%s;*", e->d_name);
10043
10044     /* Set up the pattern descriptor. */
10045     pat.dsc$a_pointer = text;
10046     pat.dsc$w_length = i + e->d_namlen - 1;
10047     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10048     pat.dsc$b_class = DSC$K_CLASS_S;
10049
10050     /* Set up result descriptor. */
10051     Newx(buff, VMS_MAXRSS, char);
10052     res.dsc$a_pointer = buff;
10053     res.dsc$w_length = VMS_MAXRSS - 1;
10054     res.dsc$b_dtype = DSC$K_DTYPE_T;
10055     res.dsc$b_class = DSC$K_CLASS_S;
10056
10057     /* Read files, collecting versions. */
10058     for (context = 0, e->vms_verscount = 0;
10059          e->vms_verscount < VERSIZE(e);
10060          e->vms_verscount++) {
10061         unsigned long rsts;
10062         unsigned long flags = 0;
10063
10064 #ifdef VMS_LONGNAME_SUPPORT
10065         flags = LIB$M_FIL_LONG_NAMES;
10066 #endif
10067         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10068         if (tmpsts == RMS$_NMF || context == 0) break;
10069         _ckvmssts(tmpsts);
10070         buff[VMS_MAXRSS - 1] = '\0';
10071         if ((p = strchr(buff, ';')))
10072             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10073         else
10074             e->vms_versions[e->vms_verscount] = -1;
10075     }
10076
10077     _ckvmssts(lib$find_file_end(&context));
10078     Safefree(text);
10079     Safefree(buff);
10080
10081 }  /* end of collectversions() */
10082
10083 /*
10084  *  Read the next entry from the directory.
10085  */
10086 /*{{{ struct dirent *readdir(DIR *dd)*/
10087 struct dirent *
10088 Perl_readdir(pTHX_ DIR *dd)
10089 {
10090     struct dsc$descriptor_s     res;
10091     char *p, *buff;
10092     unsigned long int tmpsts;
10093     unsigned long rsts;
10094     unsigned long flags = 0;
10095     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10096     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10097
10098     /* Set up result descriptor, and get next file. */
10099     Newx(buff, VMS_MAXRSS, char);
10100     res.dsc$a_pointer = buff;
10101     res.dsc$w_length = VMS_MAXRSS - 1;
10102     res.dsc$b_dtype = DSC$K_DTYPE_T;
10103     res.dsc$b_class = DSC$K_CLASS_S;
10104
10105 #ifdef VMS_LONGNAME_SUPPORT
10106     flags = LIB$M_FIL_LONG_NAMES;
10107 #endif
10108
10109     tmpsts = lib$find_file
10110         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10111     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10112     if (!(tmpsts & 1)) {
10113       set_vaxc_errno(tmpsts);
10114       switch (tmpsts) {
10115         case RMS$_PRV:
10116           set_errno(EACCES); break;
10117         case RMS$_DEV:
10118           set_errno(ENODEV); break;
10119         case RMS$_DIR:
10120           set_errno(ENOTDIR); break;
10121         case RMS$_FNF: case RMS$_DNF:
10122           set_errno(ENOENT); break;
10123         default:
10124           set_errno(EVMSERR);
10125       }
10126       Safefree(buff);
10127       return NULL;
10128     }
10129     dd->count++;
10130     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10131     buff[res.dsc$w_length] = '\0';
10132     p = buff + res.dsc$w_length;
10133     while (--p >= buff) if (!isspace(*p)) break;
10134     *p = '\0';
10135     if (!decc_efs_case_preserve) {
10136       for (p = buff; *p; p++) *p = _tolower(*p);
10137     }
10138
10139     /* Skip any directory component and just copy the name. */
10140     sts = vms_split_path
10141        (buff,
10142         &v_spec,
10143         &v_len,
10144         &r_spec,
10145         &r_len,
10146         &d_spec,
10147         &d_len,
10148         &n_spec,
10149         &n_len,
10150         &e_spec,
10151         &e_len,
10152         &vs_spec,
10153         &vs_len);
10154
10155     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10156
10157         /* In Unix report mode, remove the ".dir;1" from the name */
10158         /* if it is a real directory. */
10159         if (decc_filename_unix_report || decc_efs_charset) {
10160             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10161                 Stat_t statbuf;
10162                 int ret_sts;
10163
10164                 ret_sts = flex_lstat(buff, &statbuf);
10165                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10166                     e_len = 0;
10167                     e_spec[0] = 0;
10168                 }
10169             }
10170         }
10171
10172         /* Drop NULL extensions on UNIX file specification */
10173         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10174             e_len = 0;
10175             e_spec[0] = '\0';
10176         }
10177     }
10178
10179     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10180     dd->entry.d_name[n_len + e_len] = '\0';
10181     dd->entry.d_namlen = strlen(dd->entry.d_name);
10182
10183     /* Convert the filename to UNIX format if needed */
10184     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10185
10186         /* Translate the encoded characters. */
10187         /* Fixme: Unicode handling could result in embedded 0 characters */
10188         if (strchr(dd->entry.d_name, '^') != NULL) {
10189             char new_name[256];
10190             char * q;
10191             p = dd->entry.d_name;
10192             q = new_name;
10193             while (*p != 0) {
10194                 int inchars_read, outchars_added;
10195                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10196                 p += inchars_read;
10197                 q += outchars_added;
10198                 /* fix-me */
10199                 /* if outchars_added > 1, then this is a wide file specification */
10200                 /* Wide file specifications need to be passed in Perl */
10201                 /* counted strings apparently with a Unicode flag */
10202             }
10203             *q = 0;
10204             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10205         }
10206     }
10207
10208     dd->entry.vms_verscount = 0;
10209     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10210     Safefree(buff);
10211     return &dd->entry;
10212
10213 }  /* end of readdir() */
10214 /*}}}*/
10215
10216 /*
10217  *  Read the next entry from the directory -- thread-safe version.
10218  */
10219 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10220 int
10221 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10222 {
10223     int retval;
10224
10225     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10226
10227     entry = readdir(dd);
10228     *result = entry;
10229     retval = ( *result == NULL ? errno : 0 );
10230
10231     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10232
10233     return retval;
10234
10235 }  /* end of readdir_r() */
10236 /*}}}*/
10237
10238 /*
10239  *  Return something that can be used in a seekdir later.
10240  */
10241 /*{{{ long telldir(DIR *dd)*/
10242 long
10243 Perl_telldir(DIR *dd)
10244 {
10245     return dd->count;
10246 }
10247 /*}}}*/
10248
10249 /*
10250  *  Return to a spot where we used to be.  Brute force.
10251  */
10252 /*{{{ void seekdir(DIR *dd,long count)*/
10253 void
10254 Perl_seekdir(pTHX_ DIR *dd, long count)
10255 {
10256     int old_flags;
10257
10258     /* If we haven't done anything yet... */
10259     if (dd->count == 0)
10260         return;
10261
10262     /* Remember some state, and clear it. */
10263     old_flags = dd->flags;
10264     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10265     _ckvmssts(lib$find_file_end(&dd->context));
10266     dd->context = 0;
10267
10268     /* The increment is in readdir(). */
10269     for (dd->count = 0; dd->count < count; )
10270         readdir(dd);
10271
10272     dd->flags = old_flags;
10273
10274 }  /* end of seekdir() */
10275 /*}}}*/
10276
10277 /* VMS subprocess management
10278  *
10279  * my_vfork() - just a vfork(), after setting a flag to record that
10280  * the current script is trying a Unix-style fork/exec.
10281  *
10282  * vms_do_aexec() and vms_do_exec() are called in response to the
10283  * perl 'exec' function.  If this follows a vfork call, then they
10284  * call out the regular perl routines in doio.c which do an
10285  * execvp (for those who really want to try this under VMS).
10286  * Otherwise, they do exactly what the perl docs say exec should
10287  * do - terminate the current script and invoke a new command
10288  * (See below for notes on command syntax.)
10289  *
10290  * do_aspawn() and do_spawn() implement the VMS side of the perl
10291  * 'system' function.
10292  *
10293  * Note on command arguments to perl 'exec' and 'system': When handled
10294  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10295  * are concatenated to form a DCL command string.  If the first non-numeric
10296  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10297  * the command string is handed off to DCL directly.  Otherwise,
10298  * the first token of the command is taken as the filespec of an image
10299  * to run.  The filespec is expanded using a default type of '.EXE' and
10300  * the process defaults for device, directory, etc., and if found, the resultant
10301  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10302  * the command string as parameters.  This is perhaps a bit complicated,
10303  * but I hope it will form a happy medium between what VMS folks expect
10304  * from lib$spawn and what Unix folks expect from exec.
10305  */
10306
10307 static int vfork_called;
10308
10309 /*{{{int my_vfork(void)*/
10310 int
10311 my_vfork(void)
10312 {
10313   vfork_called++;
10314   return vfork();
10315 }
10316 /*}}}*/
10317
10318
10319 static void
10320 vms_execfree(struct dsc$descriptor_s *vmscmd)
10321 {
10322   if (vmscmd) {
10323       if (vmscmd->dsc$a_pointer) {
10324           PerlMem_free(vmscmd->dsc$a_pointer);
10325       }
10326       PerlMem_free(vmscmd);
10327   }
10328 }
10329
10330 static char *
10331 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10332 {
10333   char *junk, *tmps = NULL;
10334   size_t cmdlen = 0;
10335   size_t rlen;
10336   SV **idx;
10337   STRLEN n_a;
10338
10339   idx = mark;
10340   if (really) {
10341     tmps = SvPV(really,rlen);
10342     if (*tmps) {
10343       cmdlen += rlen + 1;
10344       idx++;
10345     }
10346   }
10347
10348   for (idx++; idx <= sp; idx++) {
10349     if (*idx) {
10350       junk = SvPVx(*idx,rlen);
10351       cmdlen += rlen ? rlen + 1 : 0;
10352     }
10353   }
10354   Newx(PL_Cmd, cmdlen+1, char);
10355
10356   if (tmps && *tmps) {
10357     my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
10358     mark++;
10359   }
10360   else *PL_Cmd = '\0';
10361   while (++mark <= sp) {
10362     if (*mark) {
10363       char *s = SvPVx(*mark,n_a);
10364       if (!*s) continue;
10365       if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10366       my_strlcat(PL_Cmd, s, cmdlen+1);
10367     }
10368   }
10369   return PL_Cmd;
10370
10371 }  /* end of setup_argstr() */
10372
10373
10374 static unsigned long int
10375 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10376                    struct dsc$descriptor_s **pvmscmd)
10377 {
10378   char * vmsspec;
10379   char * resspec;
10380   char image_name[NAM$C_MAXRSS+1];
10381   char image_argv[NAM$C_MAXRSS+1];
10382   $DESCRIPTOR(defdsc,".EXE");
10383   $DESCRIPTOR(defdsc2,".");
10384   struct dsc$descriptor_s resdsc;
10385   struct dsc$descriptor_s *vmscmd;
10386   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10387   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10388   char *s, *rest, *cp, *wordbreak;
10389   char * cmd;
10390   int cmdlen;
10391   int isdcl;
10392
10393   vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10394   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10395
10396   /* vmsspec is a DCL command buffer, not just a filename */
10397   vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10398   if (vmsspec == NULL)
10399       _ckvmssts_noperl(SS$_INSFMEM);
10400
10401   resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10402   if (resspec == NULL)
10403       _ckvmssts_noperl(SS$_INSFMEM);
10404
10405   /* Make a copy for modification */
10406   cmdlen = strlen(incmd);
10407   cmd = (char *)PerlMem_malloc(cmdlen+1);
10408   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10409   my_strlcpy(cmd, incmd, cmdlen + 1);
10410   image_name[0] = 0;
10411   image_argv[0] = 0;
10412
10413   resdsc.dsc$a_pointer = resspec;
10414   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10415   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10416   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10417
10418   vmscmd->dsc$a_pointer = NULL;
10419   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10420   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10421   vmscmd->dsc$w_length = 0;
10422   if (pvmscmd) *pvmscmd = vmscmd;
10423
10424   if (suggest_quote) *suggest_quote = 0;
10425
10426   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10427     PerlMem_free(cmd);
10428     PerlMem_free(vmsspec);
10429     PerlMem_free(resspec);
10430     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10431   }
10432
10433   s = cmd;
10434
10435   while (*s && isspace(*s)) s++;
10436
10437   if (*s == '@' || *s == '$') {
10438     vmsspec[0] = *s;  rest = s + 1;
10439     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10440   }
10441   else { cp = vmsspec; rest = s; }
10442
10443   /* If the first word is quoted, then we need to unquote it and
10444    * escape spaces within it.  We'll expand into the resspec buffer,
10445    * then copy back into the cmd buffer, expanding the latter if
10446    * necessary.
10447    */
10448   if (*rest == '"') {
10449     char *cp2;
10450     char *r = rest;
10451     bool in_quote = 0;
10452     int clen = cmdlen;
10453     int soff = s - cmd;
10454
10455     for (cp2 = resspec;
10456          *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10457          rest++) {
10458
10459       if (*rest == ' ') {    /* Escape ' ' to '^_'. */
10460         *cp2 = '^';
10461         *(++cp2) = '_';
10462         cp2++;
10463         clen++;
10464       }
10465       else if (*rest == '"') {
10466         clen--;
10467         if (in_quote) {     /* Must be closing quote. */
10468           rest++;
10469           break;
10470         }
10471         in_quote = 1;
10472       }
10473       else {
10474         *cp2 = *rest;
10475         cp2++;
10476       }
10477     }
10478     *cp2 = '\0';
10479
10480     /* Expand the command buffer if necessary. */
10481     if (clen > cmdlen) {
10482       cmd = (char *)PerlMem_realloc(cmd, clen);
10483       if (cmd == NULL)
10484         _ckvmssts_noperl(SS$_INSFMEM);
10485       /* Where we are may have changed, so recompute offsets */
10486       r = cmd + (r - s - soff);
10487       rest = cmd + (rest - s - soff);
10488       s = cmd + soff;
10489     }
10490
10491     /* Shift the non-verb portion of the command (if any) up or
10492      * down as necessary.
10493      */
10494     if (*rest)
10495       memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10496
10497     /* Copy the unquoted and escaped command verb into place. */
10498     memcpy(r, resspec, cp2 - resspec);
10499     cmd[clen] = '\0';
10500     cmdlen = clen;
10501     rest = r;         /* Rewind for subsequent operations. */
10502   }
10503
10504   if (*rest == '.' || *rest == '/') {
10505     char *cp2;
10506     for (cp2 = resspec;
10507          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10508          rest++, cp2++) *cp2 = *rest;
10509     *cp2 = '\0';
10510     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10511       s = vmsspec;
10512
10513       /* When a UNIX spec with no file type is translated to VMS, */
10514       /* A trailing '.' is appended under ODS-5 rules.            */
10515       /* Here we do not want that trailing "." as it prevents     */
10516       /* Looking for a implied ".exe" type. */
10517       if (decc_efs_charset) {
10518           int i;
10519           i = strlen(vmsspec);
10520           if (vmsspec[i-1] == '.') {
10521               vmsspec[i-1] = '\0';
10522           }
10523       }
10524
10525       if (*rest) {
10526         for (cp2 = vmsspec + strlen(vmsspec);
10527              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10528              rest++, cp2++) *cp2 = *rest;
10529         *cp2 = '\0';
10530       }
10531     }
10532   }
10533   /* Intuit whether verb (first word of cmd) is a DCL command:
10534    *   - if first nonspace char is '@', it's a DCL indirection
10535    * otherwise
10536    *   - if verb contains a filespec separator, it's not a DCL command
10537    *   - if it doesn't, caller tells us whether to default to a DCL
10538    *     command, or to a local image unless told it's DCL (by leading '$')
10539    */
10540   if (*s == '@') {
10541       isdcl = 1;
10542       if (suggest_quote) *suggest_quote = 1;
10543   } else {
10544     char *filespec = strpbrk(s,":<[.;");
10545     rest = wordbreak = strpbrk(s," \"\t/");
10546     if (!wordbreak) wordbreak = s + strlen(s);
10547     if (*s == '$') check_img = 0;
10548     if (filespec && (filespec < wordbreak)) isdcl = 0;
10549     else isdcl = !check_img;
10550   }
10551
10552   if (!isdcl) {
10553     int rsts;
10554     imgdsc.dsc$a_pointer = s;
10555     imgdsc.dsc$w_length = wordbreak - s;
10556     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10557     if (!(retsts&1)) {
10558         _ckvmssts_noperl(lib$find_file_end(&cxt));
10559         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10560       if (!(retsts & 1) && *s == '$') {
10561         _ckvmssts_noperl(lib$find_file_end(&cxt));
10562         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10563         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10564         if (!(retsts&1)) {
10565           _ckvmssts_noperl(lib$find_file_end(&cxt));
10566           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10567         }
10568       }
10569     }
10570     _ckvmssts_noperl(lib$find_file_end(&cxt));
10571
10572     if (retsts & 1) {
10573       FILE *fp;
10574       s = resspec;
10575       while (*s && !isspace(*s)) s++;
10576       *s = '\0';
10577
10578       /* check that it's really not DCL with no file extension */
10579       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10580       if (fp) {
10581         char b[256] = {0,0,0,0};
10582         read(fileno(fp), b, 256);
10583         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10584         if (isdcl) {
10585           int shebang_len;
10586
10587           /* Check for script */
10588           shebang_len = 0;
10589           if ((b[0] == '#') && (b[1] == '!'))
10590              shebang_len = 2;
10591 #ifdef ALTERNATE_SHEBANG
10592           else {
10593             shebang_len = strlen(ALTERNATE_SHEBANG);
10594             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10595               char * perlstr;
10596                 perlstr = strstr("perl",b);
10597                 if (perlstr == NULL)
10598                   shebang_len = 0;
10599             }
10600             else
10601               shebang_len = 0;
10602           }
10603 #endif
10604
10605           if (shebang_len > 0) {
10606           int i;
10607           int j;
10608           char tmpspec[NAM$C_MAXRSS + 1];
10609
10610             i = shebang_len;
10611              /* Image is following after white space */
10612             /*--------------------------------------*/
10613             while (isprint(b[i]) && isspace(b[i]))
10614                 i++;
10615
10616             j = 0;
10617             while (isprint(b[i]) && !isspace(b[i])) {
10618                 tmpspec[j++] = b[i++];
10619                 if (j >= NAM$C_MAXRSS)
10620                    break;
10621             }
10622             tmpspec[j] = '\0';
10623
10624              /* There may be some default parameters to the image */
10625             /*---------------------------------------------------*/
10626             j = 0;
10627             while (isprint(b[i])) {
10628                 image_argv[j++] = b[i++];
10629                 if (j >= NAM$C_MAXRSS)
10630                    break;
10631             }
10632             while ((j > 0) && !isprint(image_argv[j-1]))
10633                 j--;
10634             image_argv[j] = 0;
10635
10636             /* It will need to be converted to VMS format and validated */
10637             if (tmpspec[0] != '\0') {
10638               char * iname;
10639
10640                /* Try to find the exact program requested to be run */
10641               /*---------------------------------------------------*/
10642               iname = int_rmsexpand
10643                  (tmpspec, image_name, ".exe",
10644                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10645               if (iname != NULL) {
10646                 if (cando_by_name_int
10647                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10648                   /* MCR prefix needed */
10649                   isdcl = 0;
10650                 }
10651                 else {
10652                    /* Try again with a null type */
10653                   /*----------------------------*/
10654                   iname = int_rmsexpand
10655                     (tmpspec, image_name, ".",
10656                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10657                   if (iname != NULL) {
10658                     if (cando_by_name_int
10659                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10660                       /* MCR prefix needed */
10661                       isdcl = 0;
10662                     }
10663                   }
10664                 }
10665
10666                  /* Did we find the image to run the script? */
10667                 /*------------------------------------------*/
10668                 if (isdcl) {
10669                   char *tchr;
10670
10671                    /* Assume DCL or foreign command exists */
10672                   /*--------------------------------------*/
10673                   tchr = strrchr(tmpspec, '/');
10674                   if (tchr != NULL) {
10675                     tchr++;
10676                   }
10677                   else {
10678                     tchr = tmpspec;
10679                   }
10680                   my_strlcpy(image_name, tchr, sizeof(image_name));
10681                 }
10682               }
10683             }
10684           }
10685         }
10686         fclose(fp);
10687       }
10688       if (check_img && isdcl) {
10689           PerlMem_free(cmd);
10690           PerlMem_free(resspec);
10691           PerlMem_free(vmsspec);
10692           return RMS$_FNF;
10693       }
10694
10695       if (cando_by_name(S_IXUSR,0,resspec)) {
10696         vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10697         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10698         if (!isdcl) {
10699             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10700             if (image_name[0] != 0) {
10701                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10702                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10703             }
10704         } else if (image_name[0] != 0) {
10705             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10706             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10707         } else {
10708             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10709         }
10710         if (suggest_quote) *suggest_quote = 1;
10711
10712         /* If there is an image name, use original command */
10713         if (image_name[0] == 0)
10714             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10715         else {
10716             rest = cmd;
10717             while (*rest && isspace(*rest)) rest++;
10718         }
10719
10720         if (image_argv[0] != 0) {
10721           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10722           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10723         }
10724         if (rest) {
10725            int rest_len;
10726            int vmscmd_len;
10727
10728            rest_len = strlen(rest);
10729            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10730            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10731               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10732            else
10733              retsts = CLI$_BUFOVF;
10734         }
10735         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10736         PerlMem_free(cmd);
10737         PerlMem_free(vmsspec);
10738         PerlMem_free(resspec);
10739         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10740       }
10741       else
10742         retsts = RMS$_PRV;
10743     }
10744   }
10745   /* It's either a DCL command or we couldn't find a suitable image */
10746   vmscmd->dsc$w_length = strlen(cmd);
10747
10748   vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10749   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10750
10751   PerlMem_free(cmd);
10752   PerlMem_free(resspec);
10753   PerlMem_free(vmsspec);
10754
10755   /* check if it's a symbol (for quoting purposes) */
10756   if (suggest_quote && !*suggest_quote) {
10757     int iss;
10758     char equiv[LNM$C_NAMLENGTH];
10759     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10760     eqvdsc.dsc$a_pointer = equiv;
10761
10762     iss = lib$get_symbol(vmscmd,&eqvdsc);
10763     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10764   }
10765   if (!(retsts & 1)) {
10766     /* just hand off status values likely to be due to user error */
10767     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10768         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10769        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10770     else { _ckvmssts_noperl(retsts); }
10771   }
10772
10773   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10774
10775 }  /* end of setup_cmddsc() */
10776
10777
10778 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10779 bool
10780 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10781 {
10782 bool exec_sts;
10783 char * cmd;
10784
10785   if (sp > mark) {
10786     if (vfork_called) {           /* this follows a vfork - act Unixish */
10787       vfork_called--;
10788       if (vfork_called < 0) {
10789         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10790         vfork_called = 0;
10791       }
10792       else return do_aexec(really,mark,sp);
10793     }
10794                                            /* no vfork - act VMSish */
10795     cmd = setup_argstr(aTHX_ really,mark,sp);
10796     exec_sts = vms_do_exec(cmd);
10797     Safefree(cmd);  /* Clean up from setup_argstr() */
10798     return exec_sts;
10799   }
10800
10801   return FALSE;
10802 }  /* end of vms_do_aexec() */
10803 /*}}}*/
10804
10805 /* {{{bool vms_do_exec(char *cmd) */
10806 bool
10807 Perl_vms_do_exec(pTHX_ const char *cmd)
10808 {
10809   struct dsc$descriptor_s *vmscmd;
10810
10811   if (vfork_called) {             /* this follows a vfork - act Unixish */
10812     vfork_called--;
10813     if (vfork_called < 0) {
10814       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10815       vfork_called = 0;
10816     }
10817     else return do_exec(cmd);
10818   }
10819
10820   {                               /* no vfork - act VMSish */
10821     unsigned long int retsts;
10822
10823     TAINT_ENV();
10824     TAINT_PROPER("exec");
10825     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10826       retsts = lib$do_command(vmscmd);
10827
10828     switch (retsts) {
10829       case RMS$_FNF: case RMS$_DNF:
10830         set_errno(ENOENT); break;
10831       case RMS$_DIR:
10832         set_errno(ENOTDIR); break;
10833       case RMS$_DEV:
10834         set_errno(ENODEV); break;
10835       case RMS$_PRV:
10836         set_errno(EACCES); break;
10837       case RMS$_SYN:
10838         set_errno(EINVAL); break;
10839       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10840         set_errno(E2BIG); break;
10841       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10842         _ckvmssts_noperl(retsts); /* fall through */
10843       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10844         set_errno(EVMSERR);
10845     }
10846     set_vaxc_errno(retsts);
10847     if (ckWARN(WARN_EXEC)) {
10848       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10849              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10850     }
10851     vms_execfree(vmscmd);
10852   }
10853
10854   return FALSE;
10855
10856 }  /* end of vms_do_exec() */
10857 /*}}}*/
10858
10859 int do_spawn2(pTHX_ const char *, int);
10860
10861 int
10862 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10863 {
10864 unsigned long int sts;
10865 char * cmd;
10866 int flags = 0;
10867
10868   if (sp > mark) {
10869
10870     /* We'll copy the (undocumented?) Win32 behavior and allow a
10871      * numeric first argument.  But the only value we'll support
10872      * through do_aspawn is a value of 1, which means spawn without
10873      * waiting for completion -- other values are ignored.
10874      */
10875     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10876         ++mark;
10877         flags = SvIVx(*mark);
10878     }
10879
10880     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10881         flags = CLI$M_NOWAIT;
10882     else
10883         flags = 0;
10884
10885     cmd = setup_argstr(aTHX_ really, mark, sp);
10886     sts = do_spawn2(aTHX_ cmd, flags);
10887     /* pp_sys will clean up cmd */
10888     return sts;
10889   }
10890   return SS$_ABORT;
10891 }  /* end of do_aspawn() */
10892 /*}}}*/
10893
10894
10895 /* {{{int do_spawn(char* cmd) */
10896 int
10897 Perl_do_spawn(pTHX_ char* cmd)
10898 {
10899     PERL_ARGS_ASSERT_DO_SPAWN;
10900
10901     return do_spawn2(aTHX_ cmd, 0);
10902 }
10903 /*}}}*/
10904
10905 /* {{{int do_spawn_nowait(char* cmd) */
10906 int
10907 Perl_do_spawn_nowait(pTHX_ char* cmd)
10908 {
10909     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10910
10911     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10912 }
10913 /*}}}*/
10914
10915 /* {{{int do_spawn2(char *cmd) */
10916 int
10917 do_spawn2(pTHX_ const char *cmd, int flags)
10918 {
10919   unsigned long int sts, substs;
10920
10921   /* The caller of this routine expects to Safefree(PL_Cmd) */
10922   Newx(PL_Cmd,10,char);
10923
10924   TAINT_ENV();
10925   TAINT_PROPER("spawn");
10926   if (!cmd || !*cmd) {
10927     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10928     if (!(sts & 1)) {
10929       switch (sts) {
10930         case RMS$_FNF:  case RMS$_DNF:
10931           set_errno(ENOENT); break;
10932         case RMS$_DIR:
10933           set_errno(ENOTDIR); break;
10934         case RMS$_DEV:
10935           set_errno(ENODEV); break;
10936         case RMS$_PRV:
10937           set_errno(EACCES); break;
10938         case RMS$_SYN:
10939           set_errno(EINVAL); break;
10940         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10941           set_errno(E2BIG); break;
10942         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10943           _ckvmssts_noperl(sts); /* fall through */
10944         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10945           set_errno(EVMSERR);
10946       }
10947       set_vaxc_errno(sts);
10948       if (ckWARN(WARN_EXEC)) {
10949         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10950                     Strerror(errno));
10951       }
10952     }
10953     sts = substs;
10954   }
10955   else {
10956     char mode[3];
10957     PerlIO * fp;
10958     if (flags & CLI$M_NOWAIT)
10959         strcpy(mode, "n");
10960     else
10961         strcpy(mode, "nW");
10962
10963     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10964     if (fp != NULL)
10965       my_pclose(fp);
10966     /* sts will be the pid in the nowait case */
10967   }
10968   return sts;
10969 }  /* end of do_spawn2() */
10970 /*}}}*/
10971
10972
10973 static unsigned int *sockflags, sockflagsize;
10974
10975 /*
10976  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10977  * routines found in some versions of the CRTL can't deal with sockets.
10978  * We don't shim the other file open routines since a socket isn't
10979  * likely to be opened by a name.
10980  */
10981 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10982 FILE *my_fdopen(int fd, const char *mode)
10983 {
10984   FILE *fp = fdopen(fd, mode);
10985
10986   if (fp) {
10987     unsigned int fdoff = fd / sizeof(unsigned int);
10988     Stat_t sbuf; /* native stat; we don't need flex_stat */
10989     if (!sockflagsize || fdoff > sockflagsize) {
10990       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10991       else           Newx  (sockflags,fdoff+2,unsigned int);
10992       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10993       sockflagsize = fdoff + 2;
10994     }
10995     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
10996       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10997   }
10998   return fp;
10999
11000 }
11001 /*}}}*/
11002
11003
11004 /*
11005  * Clear the corresponding bit when the (possibly) socket stream is closed.
11006  * There still a small hole: we miss an implicit close which might occur
11007  * via freopen().  >> Todo
11008  */
11009 /*{{{ int my_fclose(FILE *fp)*/
11010 int my_fclose(FILE *fp) {
11011   if (fp) {
11012     unsigned int fd = fileno(fp);
11013     unsigned int fdoff = fd / sizeof(unsigned int);
11014
11015     if (sockflagsize && fdoff < sockflagsize)
11016       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11017   }
11018   return fclose(fp);
11019 }
11020 /*}}}*/
11021
11022
11023 /*
11024  * A simple fwrite replacement which outputs itmsz*nitm chars without
11025  * introducing record boundaries every itmsz chars.
11026  * We are using fputs, which depends on a terminating null.  We may
11027  * well be writing binary data, so we need to accommodate not only
11028  * data with nulls sprinkled in the middle but also data with no null
11029  * byte at the end.
11030  */
11031 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11032 int
11033 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11034 {
11035   char *cp, *end, *cpd;
11036   char *data;
11037   unsigned int fd = fileno(dest);
11038   unsigned int fdoff = fd / sizeof(unsigned int);
11039   int retval;
11040   int bufsize = itmsz * nitm + 1;
11041
11042   if (fdoff < sockflagsize &&
11043       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11044     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11045     return nitm;
11046   }
11047
11048   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11049   memcpy( data, src, itmsz*nitm );
11050   data[itmsz*nitm] = '\0';
11051
11052   end = data + itmsz * nitm;
11053   retval = (int) nitm; /* on success return # items written */
11054
11055   cpd = data;
11056   while (cpd <= end) {
11057     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11058     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11059     if (cp < end)
11060       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11061     cpd = cp + 1;
11062   }
11063
11064   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11065   return retval;
11066
11067 }  /* end of my_fwrite() */
11068 /*}}}*/
11069
11070 /*{{{ int my_flush(FILE *fp)*/
11071 int
11072 Perl_my_flush(pTHX_ FILE *fp)
11073 {
11074     int res;
11075     if ((res = fflush(fp)) == 0 && fp) {
11076 #ifdef VMS_DO_SOCKETS
11077         Stat_t s;
11078         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11079 #endif
11080             res = fsync(fileno(fp));
11081     }
11082 /*
11083  * If the flush succeeded but set end-of-file, we need to clear
11084  * the error because our caller may check ferror().  BTW, this
11085  * probably means we just flushed an empty file.
11086  */
11087     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11088
11089     return res;
11090 }
11091 /*}}}*/
11092
11093 /* fgetname() is not returning the correct file specifications when
11094  * decc_filename_unix_report mode is active.  So we have to have it
11095  * aways return filenames in VMS mode and convert it ourselves.
11096  */
11097
11098 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11099 char *
11100 Perl_my_fgetname(FILE *fp, char * buf) {
11101     char * retname;
11102     char * vms_name;
11103
11104     retname = fgetname(fp, buf, 1);
11105
11106     /* If we are in VMS mode, then we are done */
11107     if (!decc_filename_unix_report || (retname == NULL)) {
11108        return retname;
11109     }
11110
11111     /* Convert this to Unix format */
11112     vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11113     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11114     retname = int_tounixspec(vms_name, buf, NULL);
11115     PerlMem_free(vms_name);
11116
11117     return retname;
11118 }
11119 /*}}}*/
11120
11121 /*
11122  * Here are replacements for the following Unix routines in the VMS environment:
11123  *      getpwuid    Get information for a particular UIC or UID
11124  *      getpwnam    Get information for a named user
11125  *      getpwent    Get information for each user in the rights database
11126  *      setpwent    Reset search to the start of the rights database
11127  *      endpwent    Finish searching for users in the rights database
11128  *
11129  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11130  * (defined in pwd.h), which contains the following fields:-
11131  *      struct passwd {
11132  *              char        *pw_name;    Username (in lower case)
11133  *              char        *pw_passwd;  Hashed password
11134  *              unsigned int pw_uid;     UIC
11135  *              unsigned int pw_gid;     UIC group  number
11136  *              char        *pw_unixdir; Default device/directory (VMS-style)
11137  *              char        *pw_gecos;   Owner name
11138  *              char        *pw_dir;     Default device/directory (Unix-style)
11139  *              char        *pw_shell;   Default CLI name (eg. DCL)
11140  *      };
11141  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11142  *
11143  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11144  * not the UIC member number (eg. what's returned by getuid()),
11145  * getpwuid() can accept either as input (if uid is specified, the caller's
11146  * UIC group is used), though it won't recognise gid=0.
11147  *
11148  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11149  * information about other users in your group or in other groups, respectively.
11150  * If the required privilege is not available, then these routines fill only
11151  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11152  * string).
11153  *
11154  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11155  */
11156
11157 /* sizes of various UAF record fields */
11158 #define UAI$S_USERNAME 12
11159 #define UAI$S_IDENT    31
11160 #define UAI$S_OWNER    31
11161 #define UAI$S_DEFDEV   31
11162 #define UAI$S_DEFDIR   63
11163 #define UAI$S_DEFCLI   31
11164 #define UAI$S_PWD       8
11165
11166 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11167                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11168                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11169
11170 static char __empty[]= "";
11171 static struct passwd __passwd_empty=
11172     {(char *) __empty, (char *) __empty, 0, 0,
11173      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11174 static int contxt= 0;
11175 static struct passwd __pwdcache;
11176 static char __pw_namecache[UAI$S_IDENT+1];
11177
11178 /*
11179  * This routine does most of the work extracting the user information.
11180  */
11181 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11182 {
11183     static struct {
11184         unsigned char length;
11185         char pw_gecos[UAI$S_OWNER+1];
11186     } owner;
11187     static union uicdef uic;
11188     static struct {
11189         unsigned char length;
11190         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11191     } defdev;
11192     static struct {
11193         unsigned char length;
11194         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11195     } defdir;
11196     static struct {
11197         unsigned char length;
11198         char pw_shell[UAI$S_DEFCLI+1];
11199     } defcli;
11200     static char pw_passwd[UAI$S_PWD+1];
11201
11202     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11203     struct dsc$descriptor_s name_desc;
11204     unsigned long int sts;
11205
11206     static struct itmlst_3 itmlst[]= {
11207         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11208         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11209         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11210         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11211         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11212         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11213         {0,                0,           NULL,    NULL}};
11214
11215     name_desc.dsc$w_length=  strlen(name);
11216     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11217     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11218     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11219
11220 /*  Note that sys$getuai returns many fields as counted strings. */
11221     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11222     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11223       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11224     }
11225     else { _ckvmssts(sts); }
11226     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11227
11228     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11229     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11230     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11231     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11232     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11233     owner.pw_gecos[lowner]=            '\0';
11234     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11235     defcli.pw_shell[ldefcli]=          '\0';
11236     if (valid_uic(uic)) {
11237         pwd->pw_uid= uic.uic$l_uic;
11238         pwd->pw_gid= uic.uic$v_group;
11239     }
11240     else
11241       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11242     pwd->pw_passwd=  pw_passwd;
11243     pwd->pw_gecos=   owner.pw_gecos;
11244     pwd->pw_dir=     defdev.pw_dir;
11245     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11246     pwd->pw_shell=   defcli.pw_shell;
11247     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11248         int ldir;
11249         ldir= strlen(pwd->pw_unixdir) - 1;
11250         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11251     }
11252     else
11253         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11254     if (!decc_efs_case_preserve)
11255         __mystrtolower(pwd->pw_unixdir);
11256     return 1;
11257 }
11258
11259 /*
11260  * Get information for a named user.
11261 */
11262 /*{{{struct passwd *getpwnam(char *name)*/
11263 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11264 {
11265     struct dsc$descriptor_s name_desc;
11266     union uicdef uic;
11267     unsigned long int sts;
11268
11269     __pwdcache = __passwd_empty;
11270     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11271       /* We still may be able to determine pw_uid and pw_gid */
11272       name_desc.dsc$w_length=  strlen(name);
11273       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11274       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11275       name_desc.dsc$a_pointer= (char *) name;
11276       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11277         __pwdcache.pw_uid= uic.uic$l_uic;
11278         __pwdcache.pw_gid= uic.uic$v_group;
11279       }
11280       else {
11281         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11282           set_vaxc_errno(sts);
11283           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11284           return NULL;
11285         }
11286         else { _ckvmssts(sts); }
11287       }
11288     }
11289     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11290     __pwdcache.pw_name= __pw_namecache;
11291     return &__pwdcache;
11292 }  /* end of my_getpwnam() */
11293 /*}}}*/
11294
11295 /*
11296  * Get information for a particular UIC or UID.
11297  * Called by my_getpwent with uid=-1 to list all users.
11298 */
11299 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11300 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11301 {
11302     const $DESCRIPTOR(name_desc,__pw_namecache);
11303     unsigned short lname;
11304     union uicdef uic;
11305     unsigned long int status;
11306
11307     if (uid == (unsigned int) -1) {
11308       do {
11309         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11310         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11311           set_vaxc_errno(status);
11312           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11313           my_endpwent();
11314           return NULL;
11315         }
11316         else { _ckvmssts(status); }
11317       } while (!valid_uic (uic));
11318     }
11319     else {
11320       uic.uic$l_uic= uid;
11321       if (!uic.uic$v_group)
11322         uic.uic$v_group= PerlProc_getgid();
11323       if (valid_uic(uic))
11324         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11325       else status = SS$_IVIDENT;
11326       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11327           status == RMS$_PRV) {
11328         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11329         return NULL;
11330       }
11331       else { _ckvmssts(status); }
11332     }
11333     __pw_namecache[lname]= '\0';
11334     __mystrtolower(__pw_namecache);
11335
11336     __pwdcache = __passwd_empty;
11337     __pwdcache.pw_name = __pw_namecache;
11338
11339 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11340     The identifier's value is usually the UIC, but it doesn't have to be,
11341     so if we can, we let fillpasswd update this. */
11342     __pwdcache.pw_uid =  uic.uic$l_uic;
11343     __pwdcache.pw_gid =  uic.uic$v_group;
11344
11345     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11346     return &__pwdcache;
11347
11348 }  /* end of my_getpwuid() */
11349 /*}}}*/
11350
11351 /*
11352  * Get information for next user.
11353 */
11354 /*{{{struct passwd *my_getpwent()*/
11355 struct passwd *Perl_my_getpwent(pTHX)
11356 {
11357     return (my_getpwuid((unsigned int) -1));
11358 }
11359 /*}}}*/
11360
11361 /*
11362  * Finish searching rights database for users.
11363 */
11364 /*{{{void my_endpwent()*/
11365 void Perl_my_endpwent(pTHX)
11366 {
11367     if (contxt) {
11368       _ckvmssts(sys$finish_rdb(&contxt));
11369       contxt= 0;
11370     }
11371 }
11372 /*}}}*/
11373
11374 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11375  * my_utime(), and flex_stat(), all of which operate on UTC unless
11376  * VMSISH_TIMES is true.
11377  */
11378 /* method used to handle UTC conversions:
11379  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11380  */
11381 static int gmtime_emulation_type;
11382 /* number of secs to add to UTC POSIX-style time to get local time */
11383 static long int utc_offset_secs;
11384
11385 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11386  * in vmsish.h.  #undef them here so we can call the CRTL routines
11387  * directly.
11388  */
11389 #undef gmtime
11390 #undef localtime
11391 #undef time
11392
11393
11394 static time_t toutc_dst(time_t loc) {
11395   struct tm *rsltmp;
11396
11397   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11398   loc -= utc_offset_secs;
11399   if (rsltmp->tm_isdst) loc -= 3600;
11400   return loc;
11401 }
11402 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11403        ((gmtime_emulation_type || my_time(NULL)), \
11404        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11405        ((secs) - utc_offset_secs))))
11406
11407 static time_t toloc_dst(time_t utc) {
11408   struct tm *rsltmp;
11409
11410   utc += utc_offset_secs;
11411   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11412   if (rsltmp->tm_isdst) utc += 3600;
11413   return utc;
11414 }
11415 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11416        ((gmtime_emulation_type || my_time(NULL)), \
11417        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11418        ((secs) + utc_offset_secs))))
11419
11420 /* my_time(), my_localtime(), my_gmtime()
11421  * By default traffic in UTC time values, using CRTL gmtime() or
11422  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11423  * Note: We need to use these functions even when the CRTL has working
11424  * UTC support, since they also handle C<use vmsish qw(times);>
11425  *
11426  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11427  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11428  */
11429
11430 /*{{{time_t my_time(time_t *timep)*/
11431 time_t Perl_my_time(pTHX_ time_t *timep)
11432 {
11433   time_t when;
11434   struct tm *tm_p;
11435
11436   if (gmtime_emulation_type == 0) {
11437     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11438                               /* results of calls to gmtime() and localtime() */
11439                               /* for same &base */
11440
11441     gmtime_emulation_type++;
11442     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11443       char off[LNM$C_NAMLENGTH+1];;
11444
11445       gmtime_emulation_type++;
11446       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11447         gmtime_emulation_type++;
11448         utc_offset_secs = 0;
11449         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11450       }
11451       else { utc_offset_secs = atol(off); }
11452     }
11453     else { /* We've got a working gmtime() */
11454       struct tm gmt, local;
11455
11456       gmt = *tm_p;
11457       tm_p = localtime(&base);
11458       local = *tm_p;
11459       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11460       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11461       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11462       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11463     }
11464   }
11465
11466   when = time(NULL);
11467 # ifdef VMSISH_TIME
11468   if (VMSISH_TIME) when = _toloc(when);
11469 # endif
11470   if (timep != NULL) *timep = when;
11471   return when;
11472
11473 }  /* end of my_time() */
11474 /*}}}*/
11475
11476
11477 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11478 struct tm *
11479 Perl_my_gmtime(pTHX_ const time_t *timep)
11480 {
11481   time_t when;
11482   struct tm *rsltmp;
11483
11484   if (timep == NULL) {
11485     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11486     return NULL;
11487   }
11488   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11489
11490   when = *timep;
11491 # ifdef VMSISH_TIME
11492   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11493 #  endif
11494   return gmtime(&when);
11495 }  /* end of my_gmtime() */
11496 /*}}}*/
11497
11498
11499 /*{{{struct tm *my_localtime(const time_t *timep)*/
11500 struct tm *
11501 Perl_my_localtime(pTHX_ const time_t *timep)
11502 {
11503   time_t when;
11504
11505   if (timep == NULL) {
11506     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11507     return NULL;
11508   }
11509   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11510   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11511
11512   when = *timep;
11513 # ifdef VMSISH_TIME
11514   if (VMSISH_TIME) when = _toutc(when);
11515 # endif
11516   /* CRTL localtime() wants UTC as input, does tz correction itself */
11517   return localtime(&when);
11518 } /*  end of my_localtime() */
11519 /*}}}*/
11520
11521 /* Reset definitions for later calls */
11522 #define gmtime(t)    my_gmtime(t)
11523 #define localtime(t) my_localtime(t)
11524 #define time(t)      my_time(t)
11525
11526
11527 /* my_utime - update modification/access time of a file
11528  *
11529  * VMS 7.3 and later implementation
11530  * Only the UTC translation is home-grown. The rest is handled by the
11531  * CRTL utime(), which will take into account the relevant feature
11532  * logicals and ODS-5 volume characteristics for true access times.
11533  *
11534  * pre VMS 7.3 implementation:
11535  * The calling sequence is identical to POSIX utime(), but under
11536  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11537  * not maintain access times.  Restrictions differ from the POSIX
11538  * definition in that the time can be changed as long as the
11539  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11540  * no separate checks are made to insure that the caller is the
11541  * owner of the file or has special privs enabled.
11542  * Code here is based on Joe Meadows' FILE utility.
11543  *
11544  */
11545
11546 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11547  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11548  * in 100 ns intervals.
11549  */
11550 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11551
11552 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11553 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11554 {
11555 #if __CRTL_VER >= 70300000
11556   struct utimbuf utc_utimes, *utc_utimesp;
11557
11558   if (utimes != NULL) {
11559     utc_utimes.actime = utimes->actime;
11560     utc_utimes.modtime = utimes->modtime;
11561 # ifdef VMSISH_TIME
11562     /* If input was local; convert to UTC for sys svc */
11563     if (VMSISH_TIME) {
11564       utc_utimes.actime = _toutc(utimes->actime);
11565       utc_utimes.modtime = _toutc(utimes->modtime);
11566     }
11567 # endif
11568     utc_utimesp = &utc_utimes;
11569   }
11570   else {
11571     utc_utimesp = NULL;
11572   }
11573
11574   return utime(file, utc_utimesp);
11575
11576 #else /* __CRTL_VER < 70300000 */
11577
11578   int i;
11579   int sts;
11580   long int bintime[2], len = 2, lowbit, unixtime,
11581            secscale = 10000000; /* seconds --> 100 ns intervals */
11582   unsigned long int chan, iosb[2], retsts;
11583   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11584   struct FAB myfab = cc$rms_fab;
11585   struct NAM mynam = cc$rms_nam;
11586 #if defined (__DECC) && defined (__VAX)
11587   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11588    * at least through VMS V6.1, which causes a type-conversion warning.
11589    */
11590 #  pragma message save
11591 #  pragma message disable cvtdiftypes
11592 #endif
11593   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11594   struct fibdef myfib;
11595 #if defined (__DECC) && defined (__VAX)
11596   /* This should be right after the declaration of myatr, but due
11597    * to a bug in VAX DEC C, this takes effect a statement early.
11598    */
11599 #  pragma message restore
11600 #endif
11601   /* cast ok for read only parameter */
11602   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11603                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11604                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11605
11606   if (file == NULL || *file == '\0') {
11607     SETERRNO(ENOENT, LIB$_INVARG);
11608     return -1;
11609   }
11610
11611   /* Convert to VMS format ensuring that it will fit in 255 characters */
11612   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
11613       SETERRNO(ENOENT, LIB$_INVARG);
11614       return -1;
11615   }
11616   if (utimes != NULL) {
11617     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11618      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11619      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11620      * as input, we force the sign bit to be clear by shifting unixtime right
11621      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11622      */
11623     lowbit = (utimes->modtime & 1) ? secscale : 0;
11624     unixtime = (long int) utimes->modtime;
11625 #   ifdef VMSISH_TIME
11626     /* If input was UTC; convert to local for sys svc */
11627     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11628 #   endif
11629     unixtime >>= 1;  secscale <<= 1;
11630     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11631     if (!(retsts & 1)) {
11632       SETERRNO(EVMSERR, retsts);
11633       return -1;
11634     }
11635     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11636     if (!(retsts & 1)) {
11637       SETERRNO(EVMSERR, retsts);
11638       return -1;
11639     }
11640   }
11641   else {
11642     /* Just get the current time in VMS format directly */
11643     retsts = sys$gettim(bintime);
11644     if (!(retsts & 1)) {
11645       SETERRNO(EVMSERR, retsts);
11646       return -1;
11647     }
11648   }
11649
11650   myfab.fab$l_fna = vmsspec;
11651   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11652   myfab.fab$l_nam = &mynam;
11653   mynam.nam$l_esa = esa;
11654   mynam.nam$b_ess = (unsigned char) sizeof esa;
11655   mynam.nam$l_rsa = rsa;
11656   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11657   if (decc_efs_case_preserve)
11658       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11659
11660   /* Look for the file to be affected, letting RMS parse the file
11661    * specification for us as well.  I have set errno using only
11662    * values documented in the utime() man page for VMS POSIX.
11663    */
11664   retsts = sys$parse(&myfab,0,0);
11665   if (!(retsts & 1)) {
11666     set_vaxc_errno(retsts);
11667     if      (retsts == RMS$_PRV) set_errno(EACCES);
11668     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11669     else                         set_errno(EVMSERR);
11670     return -1;
11671   }
11672   retsts = sys$search(&myfab,0,0);
11673   if (!(retsts & 1)) {
11674     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11675     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11676     set_vaxc_errno(retsts);
11677     if      (retsts == RMS$_PRV) set_errno(EACCES);
11678     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11679     else                         set_errno(EVMSERR);
11680     return -1;
11681   }
11682
11683   devdsc.dsc$w_length = mynam.nam$b_dev;
11684   /* cast ok for read only parameter */
11685   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11686
11687   retsts = sys$assign(&devdsc,&chan,0,0);
11688   if (!(retsts & 1)) {
11689     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11690     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11691     set_vaxc_errno(retsts);
11692     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11693     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11694     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11695     else                               set_errno(EVMSERR);
11696     return -1;
11697   }
11698
11699   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11700   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11701
11702   memset((void *) &myfib, 0, sizeof myfib);
11703 #if defined(__DECC) || defined(__DECCXX)
11704   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11705   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11706   /* This prevents the revision time of the file being reset to the current
11707    * time as a result of our IO$_MODIFY $QIO. */
11708   myfib.fib$l_acctl = FIB$M_NORECORD;
11709 #else
11710   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11711   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11712   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11713 #endif
11714   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11715   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11716   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11717   _ckvmssts(sys$dassgn(chan));
11718   if (retsts & 1) retsts = iosb[0];
11719   if (!(retsts & 1)) {
11720     set_vaxc_errno(retsts);
11721     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11722     else                      set_errno(EVMSERR);
11723     return -1;
11724   }
11725
11726   return 0;
11727
11728 #endif /* #if __CRTL_VER >= 70300000 */
11729
11730 }  /* end of my_utime() */
11731 /*}}}*/
11732
11733 /*
11734  * flex_stat, flex_lstat, flex_fstat
11735  * basic stat, but gets it right when asked to stat
11736  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11737  */
11738
11739 #ifndef _USE_STD_STAT
11740 /* encode_dev packs a VMS device name string into an integer to allow
11741  * simple comparisons. This can be used, for example, to check whether two
11742  * files are located on the same device, by comparing their encoded device
11743  * names. Even a string comparison would not do, because stat() reuses the
11744  * device name buffer for each call; so without encode_dev, it would be
11745  * necessary to save the buffer and use strcmp (this would mean a number of
11746  * changes to the standard Perl code, to say nothing of what a Perl script
11747  * would have to do.
11748  *
11749  * The device lock id, if it exists, should be unique (unless perhaps compared
11750  * with lock ids transferred from other nodes). We have a lock id if the disk is
11751  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11752  * device names. Thus we use the lock id in preference, and only if that isn't
11753  * available, do we try to pack the device name into an integer (flagged by
11754  * the sign bit (LOCKID_MASK) being set).
11755  *
11756  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11757  * name and its encoded form, but it seems very unlikely that we will find
11758  * two files on different disks that share the same encoded device names,
11759  * and even more remote that they will share the same file id (if the test
11760  * is to check for the same file).
11761  *
11762  * A better method might be to use sys$device_scan on the first call, and to
11763  * search for the device, returning an index into the cached array.
11764  * The number returned would be more intelligible.
11765  * This is probably not worth it, and anyway would take quite a bit longer
11766  * on the first call.
11767  */
11768 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11769 static mydev_t encode_dev (pTHX_ const char *dev)
11770 {
11771   int i;
11772   unsigned long int f;
11773   mydev_t enc;
11774   char c;
11775   const char *q;
11776
11777   if (!dev || !dev[0]) return 0;
11778
11779 #if LOCKID_MASK
11780   {
11781     struct dsc$descriptor_s dev_desc;
11782     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11783
11784     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11785        can try that first. */
11786     dev_desc.dsc$w_length =  strlen (dev);
11787     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11788     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11789     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11790     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11791     if (!$VMS_STATUS_SUCCESS(status)) {
11792       switch (status) {
11793         case SS$_NOSUCHDEV:
11794           SETERRNO(ENODEV, status);
11795           return 0;
11796         default:
11797           _ckvmssts(status);
11798       }
11799     }
11800     if (lockid) return (lockid & ~LOCKID_MASK);
11801   }
11802 #endif
11803
11804   /* Otherwise we try to encode the device name */
11805   enc = 0;
11806   f = 1;
11807   i = 0;
11808   for (q = dev + strlen(dev); q--; q >= dev) {
11809     if (*q == ':')
11810         break;
11811     if (isdigit (*q))
11812       c= (*q) - '0';
11813     else if (isalpha (toupper (*q)))
11814       c= toupper (*q) - 'A' + (char)10;
11815     else
11816       continue; /* Skip '$'s */
11817     i++;
11818     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11819     if (i>1) f *= 36;
11820     enc += f * (unsigned long int) c;
11821   }
11822   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11823
11824 }  /* end of encode_dev() */
11825 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11826         device_no = encode_dev(aTHX_ devname)
11827 #else
11828 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11829         device_no = new_dev_no
11830 #endif
11831
11832 static int
11833 is_null_device(const char *name)
11834 {
11835   if (decc_bug_devnull != 0) {
11836     if (strncmp("/dev/null", name, 9) == 0)
11837       return 1;
11838   }
11839     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11840        The underscore prefix, controller letter, and unit number are
11841        independently optional; for our purposes, the colon punctuation
11842        is not.  The colon can be trailed by optional directory and/or
11843        filename, but two consecutive colons indicates a nodename rather
11844        than a device.  [pr]  */
11845   if (*name == '_') ++name;
11846   if (tolower(*name++) != 'n') return 0;
11847   if (tolower(*name++) != 'l') return 0;
11848   if (tolower(*name) == 'a') ++name;
11849   if (*name == '0') ++name;
11850   return (*name++ == ':') && (*name != ':');
11851 }
11852
11853 static int
11854 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11855
11856 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11857
11858 static I32
11859 Perl_cando_by_name_int
11860    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11861 {
11862   char usrname[L_cuserid];
11863   struct dsc$descriptor_s usrdsc =
11864          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11865   char *vmsname = NULL, *fileified = NULL;
11866   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11867   unsigned short int retlen, trnlnm_iter_count;
11868   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11869   union prvdef curprv;
11870   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11871          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11872          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11873   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11874          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11875          {0,0,0,0}};
11876   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11877          {0,0,0,0}};
11878   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11879   Stat_t st;
11880   static int profile_context = -1;
11881
11882   if (!fname || !*fname) return FALSE;
11883
11884   /* Make sure we expand logical names, since sys$check_access doesn't */
11885   fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11886   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11887   if (!strpbrk(fname,"/]>:")) {
11888       my_strlcpy(fileified, fname, VMS_MAXRSS);
11889       trnlnm_iter_count = 0;
11890       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11891         trnlnm_iter_count++;
11892         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11893       }
11894       fname = fileified;
11895   }
11896
11897   vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11898   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11899   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11900     /* Don't know if already in VMS format, so make sure */
11901     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11902       PerlMem_free(fileified);
11903       PerlMem_free(vmsname);
11904       return FALSE;
11905     }
11906   }
11907   else {
11908     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11909   }
11910
11911   /* sys$check_access needs a file spec, not a directory spec.
11912    * flex_stat now will handle a null thread context during startup.
11913    */
11914
11915   retlen = namdsc.dsc$w_length = strlen(vmsname);
11916   if (vmsname[retlen-1] == ']'
11917       || vmsname[retlen-1] == '>'
11918       || vmsname[retlen-1] == ':'
11919       || (!flex_stat_int(vmsname, &st, 1) &&
11920           S_ISDIR(st.st_mode))) {
11921
11922       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11923         PerlMem_free(fileified);
11924         PerlMem_free(vmsname);
11925         return FALSE;
11926       }
11927       fname = fileified;
11928   }
11929   else {
11930       fname = vmsname;
11931   }
11932
11933   retlen = namdsc.dsc$w_length = strlen(fname);
11934   namdsc.dsc$a_pointer = (char *)fname;
11935
11936   switch (bit) {
11937     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11938       access = ARM$M_EXECUTE;
11939       flags = CHP$M_READ;
11940       break;
11941     case S_IRUSR: case S_IRGRP: case S_IROTH:
11942       access = ARM$M_READ;
11943       flags = CHP$M_READ | CHP$M_USEREADALL;
11944       break;
11945     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11946       access = ARM$M_WRITE;
11947       flags = CHP$M_READ | CHP$M_WRITE;
11948       break;
11949     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11950       access = ARM$M_DELETE;
11951       flags = CHP$M_READ | CHP$M_WRITE;
11952       break;
11953     default:
11954       if (fileified != NULL)
11955         PerlMem_free(fileified);
11956       if (vmsname != NULL)
11957         PerlMem_free(vmsname);
11958       return FALSE;
11959   }
11960
11961   /* Before we call $check_access, create a user profile with the current
11962    * process privs since otherwise it just uses the default privs from the
11963    * UAF and might give false positives or negatives.  This only works on
11964    * VMS versions v6.0 and later since that's when sys$create_user_profile
11965    * became available.
11966    */
11967
11968   /* get current process privs and username */
11969   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11970   _ckvmssts_noperl(iosb[0]);
11971
11972   /* find out the space required for the profile */
11973   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11974                                     &usrprodsc.dsc$w_length,&profile_context));
11975
11976   /* allocate space for the profile and get it filled in */
11977   usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
11978   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11979   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11980                                     &usrprodsc.dsc$w_length,&profile_context));
11981
11982   /* use the profile to check access to the file; free profile & analyze results */
11983   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11984   PerlMem_free(usrprodsc.dsc$a_pointer);
11985   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11986
11987   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11988       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11989       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11990     set_vaxc_errno(retsts);
11991     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11992     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11993     else set_errno(ENOENT);
11994     if (fileified != NULL)
11995       PerlMem_free(fileified);
11996     if (vmsname != NULL)
11997       PerlMem_free(vmsname);
11998     return FALSE;
11999   }
12000   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12001     if (fileified != NULL)
12002       PerlMem_free(fileified);
12003     if (vmsname != NULL)
12004       PerlMem_free(vmsname);
12005     return TRUE;
12006   }
12007   _ckvmssts_noperl(retsts);
12008
12009   if (fileified != NULL)
12010     PerlMem_free(fileified);
12011   if (vmsname != NULL)
12012     PerlMem_free(vmsname);
12013   return FALSE;  /* Should never get here */
12014
12015 }
12016
12017 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12018 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12019  * subset of the applicable information.
12020  */
12021 bool
12022 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12023 {
12024   return cando_by_name_int
12025         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12026 }  /* end of cando() */
12027 /*}}}*/
12028
12029
12030 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12031 I32
12032 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12033 {
12034    return cando_by_name_int(bit, effective, fname, 0);
12035
12036 }  /* end of cando_by_name() */
12037 /*}}}*/
12038
12039
12040 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12041 int
12042 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12043 {
12044   if (!fstat(fd, &statbufp->crtl_stat)) {
12045     char *cptr;
12046     char *vms_filename;
12047     vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12048     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12049
12050     /* Save name for cando by name in VMS format */
12051     cptr = getname(fd, vms_filename, 1);
12052
12053     /* This should not happen, but just in case */
12054     if (cptr == NULL) {
12055         statbufp->st_devnam[0] = 0;
12056     }
12057     else {
12058         /* Make sure that the saved name fits in 255 characters */
12059         cptr = int_rmsexpand_vms
12060                        (vms_filename,
12061                         statbufp->st_devnam,
12062                         0);
12063         if (cptr == NULL)
12064             statbufp->st_devnam[0] = 0;
12065     }
12066     PerlMem_free(vms_filename);
12067
12068     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12069     VMS_DEVICE_ENCODE
12070         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12071
12072 #   ifdef VMSISH_TIME
12073     if (VMSISH_TIME) {
12074       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12075       statbufp->st_atime = _toloc(statbufp->st_atime);
12076       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12077     }
12078 #   endif
12079     return 0;
12080   }
12081   return -1;
12082
12083 }  /* end of flex_fstat() */
12084 /*}}}*/
12085
12086 static int
12087 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12088 {
12089     char *temp_fspec = NULL;
12090     char *fileified = NULL;
12091     const char *save_spec;
12092     char *ret_spec;
12093     int retval = -1;
12094     char efs_hack = 0;
12095     char already_fileified = 0;
12096     dSAVEDERRNO;
12097
12098     if (!fspec) {
12099         errno = EINVAL;
12100         return retval;
12101     }
12102
12103     if (decc_bug_devnull != 0) {
12104       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12105         memset(statbufp,0,sizeof *statbufp);
12106         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12107         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12108         statbufp->st_uid = 0x00010001;
12109         statbufp->st_gid = 0x0001;
12110         time((time_t *)&statbufp->st_mtime);
12111         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12112         return 0;
12113       }
12114     }
12115
12116     SAVE_ERRNO;
12117
12118 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12119   /*
12120    * If we are in POSIX filespec mode, accept the filename as is.
12121    */
12122   if (decc_posix_compliant_pathnames == 0) {
12123 #endif
12124
12125     /* Try for a simple stat first.  If fspec contains a filename without
12126      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12127      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12128      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12129      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12130      * the file with null type, specify this by calling flex_stat() with
12131      * a '.' at the end of fspec.
12132      */
12133
12134     if (lstat_flag == 0)
12135         retval = stat(fspec, &statbufp->crtl_stat);
12136     else
12137         retval = lstat(fspec, &statbufp->crtl_stat);
12138
12139     if (!retval) {
12140         save_spec = fspec;
12141     }
12142     else {
12143         /* In the odd case where we have write but not read access
12144          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12145          */
12146         fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12147         if (fileified == NULL)
12148               _ckvmssts_noperl(SS$_INSFMEM);
12149
12150         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12151         if (ret_spec != NULL) {
12152             if (lstat_flag == 0)
12153                 retval = stat(fileified, &statbufp->crtl_stat);
12154             else
12155                 retval = lstat(fileified, &statbufp->crtl_stat);
12156             save_spec = fileified;
12157             already_fileified = 1;
12158         }
12159     }
12160
12161     if (retval && vms_bug_stat_filename) {
12162
12163         temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12164         if (temp_fspec == NULL)
12165             _ckvmssts_noperl(SS$_INSFMEM);
12166
12167         /* We should try again as a vmsified file specification. */
12168
12169         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12170         if (ret_spec != NULL) {
12171             if (lstat_flag == 0)
12172                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12173             else
12174                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12175             save_spec = temp_fspec;
12176         }
12177     }
12178
12179     if (retval) {
12180         /* Last chance - allow multiple dots without EFS CHARSET */
12181         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12182          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12183          * enable it if it isn't already.
12184          */
12185 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12186         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12187             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12188 #endif
12189         if (lstat_flag == 0)
12190             retval = stat(fspec, &statbufp->crtl_stat);
12191         else
12192             retval = lstat(fspec, &statbufp->crtl_stat);
12193         save_spec = fspec;
12194 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12195         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12196             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12197             efs_hack = 1;
12198         }
12199 #endif
12200     }
12201
12202 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12203   } else {
12204     if (lstat_flag == 0)
12205       retval = stat(temp_fspec, &statbufp->crtl_stat);
12206     else
12207       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12208       save_spec = temp_fspec;
12209   }
12210 #endif
12211
12212 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12213   /* As you were... */
12214   if (!decc_efs_charset)
12215     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12216 #endif
12217
12218     if (!retval) {
12219       char *cptr;
12220       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12221
12222       /* If this is an lstat, do not follow the link */
12223       if (lstat_flag)
12224         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12225
12226 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12227       /* If we used the efs_hack above, we must also use it here for */
12228       /* perl_cando to work */
12229       if (efs_hack && (decc_efs_charset_index > 0)) {
12230           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12231       }
12232 #endif
12233
12234       /* If we've got a directory, save a fileified, expanded version of it
12235        * in st_devnam.  If not a directory, just an expanded version.
12236        */
12237       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12238           fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12239           if (fileified == NULL)
12240               _ckvmssts_noperl(SS$_INSFMEM);
12241
12242           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12243           if (cptr != NULL)
12244               save_spec = fileified;
12245       }
12246
12247       cptr = int_rmsexpand(save_spec,
12248                            statbufp->st_devnam,
12249                            NULL,
12250                            rmsex_flags,
12251                            0,
12252                            0);
12253
12254 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12255       if (efs_hack && (decc_efs_charset_index > 0)) {
12256           decc$feature_set_value(decc_efs_charset, 1, 0);
12257       }
12258 #endif
12259
12260       /* Fix me: If this is NULL then stat found a file, and we could */
12261       /* not convert the specification to VMS - Should never happen */
12262       if (cptr == NULL)
12263         statbufp->st_devnam[0] = 0;
12264
12265       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12266       VMS_DEVICE_ENCODE
12267         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12268 #     ifdef VMSISH_TIME
12269       if (VMSISH_TIME) {
12270         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12271         statbufp->st_atime = _toloc(statbufp->st_atime);
12272         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12273       }
12274 #     endif
12275     }
12276     /* If we were successful, leave errno where we found it */
12277     if (retval == 0) RESTORE_ERRNO;
12278     if (temp_fspec)
12279         PerlMem_free(temp_fspec);
12280     if (fileified)
12281         PerlMem_free(fileified);
12282     return retval;
12283
12284 }  /* end of flex_stat_int() */
12285
12286
12287 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12288 int
12289 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12290 {
12291    return flex_stat_int(fspec, statbufp, 0);
12292 }
12293 /*}}}*/
12294
12295 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12296 int
12297 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12298 {
12299    return flex_stat_int(fspec, statbufp, 1);
12300 }
12301 /*}}}*/
12302
12303
12304 /*{{{char *my_getlogin()*/
12305 /* VMS cuserid == Unix getlogin, except calling sequence */
12306 char *
12307 my_getlogin(void)
12308 {
12309     static char user[L_cuserid];
12310     return cuserid(user);
12311 }
12312 /*}}}*/
12313
12314
12315 /*  rmscopy - copy a file using VMS RMS routines
12316  *
12317  *  Copies contents and attributes of spec_in to spec_out, except owner
12318  *  and protection information.  Name and type of spec_in are used as
12319  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12320  *  should try to propagate timestamps from the input file to the output file.
12321  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12322  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12323  *  propagated to the output file at creation iff the output file specification
12324  *  did not contain an explicit name or type, and the revision date is always
12325  *  updated at the end of the copy operation.  If it is greater than 0, then
12326  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12327  *  other than the revision date should be propagated, and bit 1 indicates
12328  *  that the revision date should be propagated.
12329  *
12330  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12331  *
12332  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12333  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12334  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12335  * as part of the Perl standard distribution under the terms of the
12336  * GNU General Public License or the Perl Artistic License.  Copies
12337  * of each may be found in the Perl standard distribution.
12338  */ /* FIXME */
12339 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12340 int
12341 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12342 {
12343     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12344          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12345     unsigned long int sts;
12346     int dna_len;
12347     struct FAB fab_in, fab_out;
12348     struct RAB rab_in, rab_out;
12349     rms_setup_nam(nam);
12350     rms_setup_nam(nam_out);
12351     struct XABDAT xabdat;
12352     struct XABFHC xabfhc;
12353     struct XABRDT xabrdt;
12354     struct XABSUM xabsum;
12355
12356     vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12357     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12358     vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12359     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12360     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12361         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12362       PerlMem_free(vmsin);
12363       PerlMem_free(vmsout);
12364       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12365       return 0;
12366     }
12367
12368     esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12369     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12370     esal = NULL;
12371 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12372     esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12373     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12374 #endif
12375     fab_in = cc$rms_fab;
12376     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12377     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12378     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12379     fab_in.fab$l_fop = FAB$M_SQO;
12380     rms_bind_fab_nam(fab_in, nam);
12381     fab_in.fab$l_xab = (void *) &xabdat;
12382
12383     rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12384     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12385     rsal = NULL;
12386 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12387     rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12388     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12389 #endif
12390     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12391     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12392     rms_nam_esl(nam) = 0;
12393     rms_nam_rsl(nam) = 0;
12394     rms_nam_esll(nam) = 0;
12395     rms_nam_rsll(nam) = 0;
12396 #ifdef NAM$M_NO_SHORT_UPCASE
12397     if (decc_efs_case_preserve)
12398         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12399 #endif
12400
12401     xabdat = cc$rms_xabdat;        /* To get creation date */
12402     xabdat.xab$l_nxt = (void *) &xabfhc;
12403
12404     xabfhc = cc$rms_xabfhc;        /* To get record length */
12405     xabfhc.xab$l_nxt = (void *) &xabsum;
12406
12407     xabsum = cc$rms_xabsum;        /* To get key and area information */
12408
12409     if (!((sts = sys$open(&fab_in)) & 1)) {
12410       PerlMem_free(vmsin);
12411       PerlMem_free(vmsout);
12412       PerlMem_free(esa);
12413       if (esal != NULL)
12414         PerlMem_free(esal);
12415       PerlMem_free(rsa);
12416       if (rsal != NULL)
12417         PerlMem_free(rsal);
12418       set_vaxc_errno(sts);
12419       switch (sts) {
12420         case RMS$_FNF: case RMS$_DNF:
12421           set_errno(ENOENT); break;
12422         case RMS$_DIR:
12423           set_errno(ENOTDIR); break;
12424         case RMS$_DEV:
12425           set_errno(ENODEV); break;
12426         case RMS$_SYN:
12427           set_errno(EINVAL); break;
12428         case RMS$_PRV:
12429           set_errno(EACCES); break;
12430         default:
12431           set_errno(EVMSERR);
12432       }
12433       return 0;
12434     }
12435
12436     nam_out = nam;
12437     fab_out = fab_in;
12438     fab_out.fab$w_ifi = 0;
12439     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12440     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12441     fab_out.fab$l_fop = FAB$M_SQO;
12442     rms_bind_fab_nam(fab_out, nam_out);
12443     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12444     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12445     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12446     esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12447     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12448     rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12449     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12450     esal_out = NULL;
12451     rsal_out = NULL;
12452 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12453     esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12454     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12455     rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12456     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12457 #endif
12458     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12459     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12460
12461     if (preserve_dates == 0) {  /* Act like DCL COPY */
12462       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12463       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12464       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12465         PerlMem_free(vmsin);
12466         PerlMem_free(vmsout);
12467         PerlMem_free(esa);
12468         if (esal != NULL)
12469             PerlMem_free(esal);
12470         PerlMem_free(rsa);
12471         if (rsal != NULL)
12472             PerlMem_free(rsal);
12473         PerlMem_free(esa_out);
12474         if (esal_out != NULL)
12475             PerlMem_free(esal_out);
12476         PerlMem_free(rsa_out);
12477         if (rsal_out != NULL)
12478             PerlMem_free(rsal_out);
12479         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12480         set_vaxc_errno(sts);
12481         return 0;
12482       }
12483       fab_out.fab$l_xab = (void *) &xabdat;
12484       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12485         preserve_dates = 1;
12486     }
12487     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12488       preserve_dates =0;      /* bitmask from this point forward   */
12489
12490     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12491     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12492       PerlMem_free(vmsin);
12493       PerlMem_free(vmsout);
12494       PerlMem_free(esa);
12495       if (esal != NULL)
12496           PerlMem_free(esal);
12497       PerlMem_free(rsa);
12498       if (rsal != NULL)
12499           PerlMem_free(rsal);
12500       PerlMem_free(esa_out);
12501       if (esal_out != NULL)
12502           PerlMem_free(esal_out);
12503       PerlMem_free(rsa_out);
12504       if (rsal_out != NULL)
12505           PerlMem_free(rsal_out);
12506       set_vaxc_errno(sts);
12507       switch (sts) {
12508         case RMS$_DNF:
12509           set_errno(ENOENT); break;
12510         case RMS$_DIR:
12511           set_errno(ENOTDIR); break;
12512         case RMS$_DEV:
12513           set_errno(ENODEV); break;
12514         case RMS$_SYN:
12515           set_errno(EINVAL); break;
12516         case RMS$_PRV:
12517           set_errno(EACCES); break;
12518         default:
12519           set_errno(EVMSERR);
12520       }
12521       return 0;
12522     }
12523     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12524     if (preserve_dates & 2) {
12525       /* sys$close() will process xabrdt, not xabdat */
12526       xabrdt = cc$rms_xabrdt;
12527 #ifndef __GNUC__
12528       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12529 #else
12530       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12531        * is unsigned long[2], while DECC & VAXC use a struct */
12532       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12533 #endif
12534       fab_out.fab$l_xab = (void *) &xabrdt;
12535     }
12536
12537     ubf = (char *)PerlMem_malloc(32256);
12538     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12539     rab_in = cc$rms_rab;
12540     rab_in.rab$l_fab = &fab_in;
12541     rab_in.rab$l_rop = RAB$M_BIO;
12542     rab_in.rab$l_ubf = ubf;
12543     rab_in.rab$w_usz = 32256;
12544     if (!((sts = sys$connect(&rab_in)) & 1)) {
12545       sys$close(&fab_in); sys$close(&fab_out);
12546       PerlMem_free(vmsin);
12547       PerlMem_free(vmsout);
12548       PerlMem_free(ubf);
12549       PerlMem_free(esa);
12550       if (esal != NULL)
12551           PerlMem_free(esal);
12552       PerlMem_free(rsa);
12553       if (rsal != NULL)
12554           PerlMem_free(rsal);
12555       PerlMem_free(esa_out);
12556       if (esal_out != NULL)
12557           PerlMem_free(esal_out);
12558       PerlMem_free(rsa_out);
12559       if (rsal_out != NULL)
12560           PerlMem_free(rsal_out);
12561       set_errno(EVMSERR); set_vaxc_errno(sts);
12562       return 0;
12563     }
12564
12565     rab_out = cc$rms_rab;
12566     rab_out.rab$l_fab = &fab_out;
12567     rab_out.rab$l_rbf = ubf;
12568     if (!((sts = sys$connect(&rab_out)) & 1)) {
12569       sys$close(&fab_in); sys$close(&fab_out);
12570       PerlMem_free(vmsin);
12571       PerlMem_free(vmsout);
12572       PerlMem_free(ubf);
12573       PerlMem_free(esa);
12574       if (esal != NULL)
12575           PerlMem_free(esal);
12576       PerlMem_free(rsa);
12577       if (rsal != NULL)
12578           PerlMem_free(rsal);
12579       PerlMem_free(esa_out);
12580       if (esal_out != NULL)
12581           PerlMem_free(esal_out);
12582       PerlMem_free(rsa_out);
12583       if (rsal_out != NULL)
12584           PerlMem_free(rsal_out);
12585       set_errno(EVMSERR); set_vaxc_errno(sts);
12586       return 0;
12587     }
12588
12589     while ((sts = sys$read(&rab_in))) {  /* always true  */
12590       if (sts == RMS$_EOF) break;
12591       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12592       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12593         sys$close(&fab_in); sys$close(&fab_out);
12594         PerlMem_free(vmsin);
12595         PerlMem_free(vmsout);
12596         PerlMem_free(ubf);
12597         PerlMem_free(esa);
12598         if (esal != NULL)
12599             PerlMem_free(esal);
12600         PerlMem_free(rsa);
12601         if (rsal != NULL)
12602             PerlMem_free(rsal);
12603         PerlMem_free(esa_out);
12604         if (esal_out != NULL)
12605             PerlMem_free(esal_out);
12606         PerlMem_free(rsa_out);
12607         if (rsal_out != NULL)
12608             PerlMem_free(rsal_out);
12609         set_errno(EVMSERR); set_vaxc_errno(sts);
12610         return 0;
12611       }
12612     }
12613
12614
12615     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12616     sys$close(&fab_in);  sys$close(&fab_out);
12617     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12618
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
12635     if (!(sts & 1)) {
12636       set_errno(EVMSERR); set_vaxc_errno(sts);
12637       return 0;
12638     }
12639
12640     return 1;
12641
12642 }  /* end of rmscopy() */
12643 /*}}}*/
12644
12645
12646 /***  The following glue provides 'hooks' to make some of the routines
12647  * from this file available from Perl.  These routines are sufficiently
12648  * basic, and are required sufficiently early in the build process,
12649  * that's it's nice to have them available to miniperl as well as the
12650  * full Perl, so they're set up here instead of in an extension.  The
12651  * Perl code which handles importation of these names into a given
12652  * package lives in [.VMS]Filespec.pm in @INC.
12653  */
12654
12655 void
12656 rmsexpand_fromperl(pTHX_ CV *cv)
12657 {
12658   dXSARGS;
12659   char *fspec, *defspec = NULL, *rslt;
12660   STRLEN n_a;
12661   int fs_utf8, dfs_utf8;
12662
12663   fs_utf8 = 0;
12664   dfs_utf8 = 0;
12665   if (!items || items > 2)
12666     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12667   fspec = SvPV(ST(0),n_a);
12668   fs_utf8 = SvUTF8(ST(0));
12669   if (!fspec || !*fspec) XSRETURN_UNDEF;
12670   if (items == 2) {
12671     defspec = SvPV(ST(1),n_a);
12672     dfs_utf8 = SvUTF8(ST(1));
12673   }
12674   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12675   ST(0) = sv_newmortal();
12676   if (rslt != NULL) {
12677     sv_usepvn(ST(0),rslt,strlen(rslt));
12678     if (fs_utf8) {
12679         SvUTF8_on(ST(0));
12680     }
12681   }
12682   XSRETURN(1);
12683 }
12684
12685 void
12686 vmsify_fromperl(pTHX_ CV *cv)
12687 {
12688   dXSARGS;
12689   char *vmsified;
12690   STRLEN n_a;
12691   int utf8_fl;
12692
12693   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12694   utf8_fl = SvUTF8(ST(0));
12695   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12696   ST(0) = sv_newmortal();
12697   if (vmsified != NULL) {
12698     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12699     if (utf8_fl) {
12700         SvUTF8_on(ST(0));
12701     }
12702   }
12703   XSRETURN(1);
12704 }
12705
12706 void
12707 unixify_fromperl(pTHX_ CV *cv)
12708 {
12709   dXSARGS;
12710   char *unixified;
12711   STRLEN n_a;
12712   int utf8_fl;
12713
12714   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12715   utf8_fl = SvUTF8(ST(0));
12716   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12717   ST(0) = sv_newmortal();
12718   if (unixified != NULL) {
12719     sv_usepvn(ST(0),unixified,strlen(unixified));
12720     if (utf8_fl) {
12721         SvUTF8_on(ST(0));
12722     }
12723   }
12724   XSRETURN(1);
12725 }
12726
12727 void
12728 fileify_fromperl(pTHX_ CV *cv)
12729 {
12730   dXSARGS;
12731   char *fileified;
12732   STRLEN n_a;
12733   int utf8_fl;
12734
12735   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12736   utf8_fl = SvUTF8(ST(0));
12737   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12738   ST(0) = sv_newmortal();
12739   if (fileified != NULL) {
12740     sv_usepvn(ST(0),fileified,strlen(fileified));
12741     if (utf8_fl) {
12742         SvUTF8_on(ST(0));
12743     }
12744   }
12745   XSRETURN(1);
12746 }
12747
12748 void
12749 pathify_fromperl(pTHX_ CV *cv)
12750 {
12751   dXSARGS;
12752   char *pathified;
12753   STRLEN n_a;
12754   int utf8_fl;
12755
12756   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12757   utf8_fl = SvUTF8(ST(0));
12758   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12759   ST(0) = sv_newmortal();
12760   if (pathified != NULL) {
12761     sv_usepvn(ST(0),pathified,strlen(pathified));
12762     if (utf8_fl) {
12763         SvUTF8_on(ST(0));
12764     }
12765   }
12766   XSRETURN(1);
12767 }
12768
12769 void
12770 vmspath_fromperl(pTHX_ CV *cv)
12771 {
12772   dXSARGS;
12773   char *vmspath;
12774   STRLEN n_a;
12775   int utf8_fl;
12776
12777   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12778   utf8_fl = SvUTF8(ST(0));
12779   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12780   ST(0) = sv_newmortal();
12781   if (vmspath != NULL) {
12782     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12783     if (utf8_fl) {
12784         SvUTF8_on(ST(0));
12785     }
12786   }
12787   XSRETURN(1);
12788 }
12789
12790 void
12791 unixpath_fromperl(pTHX_ CV *cv)
12792 {
12793   dXSARGS;
12794   char *unixpath;
12795   STRLEN n_a;
12796   int utf8_fl;
12797
12798   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12799   utf8_fl = SvUTF8(ST(0));
12800   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12801   ST(0) = sv_newmortal();
12802   if (unixpath != NULL) {
12803     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12804     if (utf8_fl) {
12805         SvUTF8_on(ST(0));
12806     }
12807   }
12808   XSRETURN(1);
12809 }
12810
12811 void
12812 candelete_fromperl(pTHX_ CV *cv)
12813 {
12814   dXSARGS;
12815   char *fspec, *fsp;
12816   SV *mysv;
12817   IO *io;
12818   STRLEN n_a;
12819
12820   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12821
12822   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12823   Newx(fspec, VMS_MAXRSS, char);
12824   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12825   if (isGV_with_GP(mysv)) {
12826     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12827       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12828       ST(0) = &PL_sv_no;
12829       Safefree(fspec);
12830       XSRETURN(1);
12831     }
12832     fsp = fspec;
12833   }
12834   else {
12835     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12836       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12837       ST(0) = &PL_sv_no;
12838       Safefree(fspec);
12839       XSRETURN(1);
12840     }
12841   }
12842
12843   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12844   Safefree(fspec);
12845   XSRETURN(1);
12846 }
12847
12848 void
12849 rmscopy_fromperl(pTHX_ CV *cv)
12850 {
12851   dXSARGS;
12852   char *inspec, *outspec, *inp, *outp;
12853   int date_flag;
12854   SV *mysv;
12855   IO *io;
12856   STRLEN n_a;
12857
12858   if (items < 2 || items > 3)
12859     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12860
12861   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12862   Newx(inspec, VMS_MAXRSS, char);
12863   if (isGV_with_GP(mysv)) {
12864     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12865       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12866       ST(0) = sv_2mortal(newSViv(0));
12867       Safefree(inspec);
12868       XSRETURN(1);
12869     }
12870     inp = inspec;
12871   }
12872   else {
12873     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12874       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12875       ST(0) = sv_2mortal(newSViv(0));
12876       Safefree(inspec);
12877       XSRETURN(1);
12878     }
12879   }
12880   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12881   Newx(outspec, VMS_MAXRSS, char);
12882   if (isGV_with_GP(mysv)) {
12883     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12884       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12885       ST(0) = sv_2mortal(newSViv(0));
12886       Safefree(inspec);
12887       Safefree(outspec);
12888       XSRETURN(1);
12889     }
12890     outp = outspec;
12891   }
12892   else {
12893     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12894       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12895       ST(0) = sv_2mortal(newSViv(0));
12896       Safefree(inspec);
12897       Safefree(outspec);
12898       XSRETURN(1);
12899     }
12900   }
12901   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12902
12903   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12904   Safefree(inspec);
12905   Safefree(outspec);
12906   XSRETURN(1);
12907 }
12908
12909 /* The mod2fname is limited to shorter filenames by design, so it should
12910  * not be modified to support longer EFS pathnames
12911  */
12912 void
12913 mod2fname(pTHX_ CV *cv)
12914 {
12915   dXSARGS;
12916   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12917        workbuff[NAM$C_MAXRSS*1 + 1];
12918   int counter, num_entries;
12919   /* ODS-5 ups this, but we want to be consistent, so... */
12920   int max_name_len = 39;
12921   AV *in_array = (AV *)SvRV(ST(0));
12922
12923   num_entries = av_len(in_array);
12924
12925   /* All the names start with PL_. */
12926   strcpy(ultimate_name, "PL_");
12927
12928   /* Clean up our working buffer */
12929   Zero(work_name, sizeof(work_name), char);
12930
12931   /* Run through the entries and build up a working name */
12932   for(counter = 0; counter <= num_entries; counter++) {
12933     /* If it's not the first name then tack on a __ */
12934     if (counter) {
12935       my_strlcat(work_name, "__", sizeof(work_name));
12936     }
12937     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12938   }
12939
12940   /* Check to see if we actually have to bother...*/
12941   if (strlen(work_name) + 3 <= max_name_len) {
12942     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12943   } else {
12944     /* It's too darned big, so we need to go strip. We use the same */
12945     /* algorithm as xsubpp does. First, strip out doubled __ */
12946     char *source, *dest, last;
12947     dest = workbuff;
12948     last = 0;
12949     for (source = work_name; *source; source++) {
12950       if (last == *source && last == '_') {
12951         continue;
12952       }
12953       *dest++ = *source;
12954       last = *source;
12955     }
12956     /* Go put it back */
12957     my_strlcpy(work_name, workbuff, sizeof(work_name));
12958     /* Is it still too big? */
12959     if (strlen(work_name) + 3 > max_name_len) {
12960       /* Strip duplicate letters */
12961       last = 0;
12962       dest = workbuff;
12963       for (source = work_name; *source; source++) {
12964         if (last == toupper(*source)) {
12965         continue;
12966         }
12967         *dest++ = *source;
12968         last = toupper(*source);
12969       }
12970       my_strlcpy(work_name, workbuff, sizeof(work_name));
12971     }
12972
12973     /* Is it *still* too big? */
12974     if (strlen(work_name) + 3 > max_name_len) {
12975       /* Too bad, we truncate */
12976       work_name[max_name_len - 2] = 0;
12977     }
12978     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12979   }
12980
12981   /* Okay, return it */
12982   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12983   XSRETURN(1);
12984 }
12985
12986 void
12987 hushexit_fromperl(pTHX_ CV *cv)
12988 {
12989     dXSARGS;
12990
12991     if (items > 0) {
12992         VMSISH_HUSHED = SvTRUE(ST(0));
12993     }
12994     ST(0) = boolSV(VMSISH_HUSHED);
12995     XSRETURN(1);
12996 }
12997
12998
12999 PerlIO *
13000 Perl_vms_start_glob
13001    (pTHX_ SV *tmpglob,
13002     IO *io)
13003 {
13004     PerlIO *fp;
13005     struct vs_str_st *rslt;
13006     char *vmsspec;
13007     char *rstr;
13008     char *begin, *cp;
13009     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13010     PerlIO *tmpfp;
13011     STRLEN i;
13012     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13013     struct dsc$descriptor_vs rsdsc;
13014     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13015     unsigned long hasver = 0, isunix = 0;
13016     unsigned long int lff_flags = 0;
13017     int rms_sts;
13018     int vms_old_glob = 1;
13019
13020     if (!SvOK(tmpglob)) {
13021         SETERRNO(ENOENT,RMS$_FNF);
13022         return NULL;
13023     }
13024
13025     vms_old_glob = !decc_filename_unix_report;
13026
13027 #ifdef VMS_LONGNAME_SUPPORT
13028     lff_flags = LIB$M_FIL_LONG_NAMES;
13029 #endif
13030     /* The Newx macro will not allow me to assign a smaller array
13031      * to the rslt pointer, so we will assign it to the begin char pointer
13032      * and then copy the value into the rslt pointer.
13033      */
13034     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13035     rslt = (struct vs_str_st *)begin;
13036     rslt->length = 0;
13037     rstr = &rslt->str[0];
13038     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13039     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13040     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13041     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13042
13043     Newx(vmsspec, VMS_MAXRSS, char);
13044
13045         /* We could find out if there's an explicit dev/dir or version
13046            by peeking into lib$find_file's internal context at
13047            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13048            but that's unsupported, so I don't want to do it now and
13049            have it bite someone in the future. */
13050         /* Fix-me: vms_split_path() is the only way to do this, the
13051            existing method will fail with many legal EFS or UNIX specifications
13052          */
13053
13054     cp = SvPV(tmpglob,i);
13055
13056     for (; i; i--) {
13057         if (cp[i] == ';') hasver = 1;
13058         if (cp[i] == '.') {
13059             if (sts) hasver = 1;
13060             else sts = 1;
13061         }
13062         if (cp[i] == '/') {
13063             hasdir = isunix = 1;
13064             break;
13065         }
13066         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13067             hasdir = 1;
13068             break;
13069         }
13070     }
13071
13072     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13073     if ((hasdir == 0) && decc_filename_unix_report) {
13074         isunix = 1;
13075     }
13076
13077     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13078         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13079         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13080         int wildstar = 0;
13081         int wildquery = 0;
13082         int found = 0;
13083         Stat_t st;
13084         int stat_sts;
13085         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13086         if (!stat_sts && S_ISDIR(st.st_mode)) {
13087             char * vms_dir;
13088             const char * fname;
13089             STRLEN fname_len;
13090
13091             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13092             /* path delimiter of ':>]', if so, then the old behavior has */
13093             /* obviously been specifically requested */
13094
13095             fname = SvPVX_const(tmpglob);
13096             fname_len = strlen(fname);
13097             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13098             if (vms_old_glob || (vms_dir != NULL)) {
13099                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13100                                             SvPVX(tmpglob),vmsspec,NULL);
13101                 ok = (wilddsc.dsc$a_pointer != NULL);
13102                 /* maybe passed 'foo' rather than '[.foo]', thus not
13103                    detected above */
13104                 hasdir = 1;
13105             } else {
13106                 /* Operate just on the directory, the special stat/fstat for */
13107                 /* leaves the fileified  specification in the st_devnam */
13108                 /* member. */
13109                 wilddsc.dsc$a_pointer = st.st_devnam;
13110                 ok = 1;
13111             }
13112         }
13113         else {
13114             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13115             ok = (wilddsc.dsc$a_pointer != NULL);
13116         }
13117         if (ok)
13118             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13119
13120         /* If not extended character set, replace ? with % */
13121         /* With extended character set, ? is a wildcard single character */
13122         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13123             if (*cp == '?') {
13124                 wildquery = 1;
13125                 if (!decc_efs_charset)
13126                     *cp = '%';
13127             } else if (*cp == '%') {
13128                 wildquery = 1;
13129             } else if (*cp == '*') {
13130                 wildstar = 1;
13131             }
13132         }
13133
13134         if (ok) {
13135             wv_sts = vms_split_path(
13136                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13137                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13138                 &wvs_spec, &wvs_len);
13139         } else {
13140             wn_spec = NULL;
13141             wn_len = 0;
13142             we_spec = NULL;
13143             we_len = 0;
13144         }
13145
13146         sts = SS$_NORMAL;
13147         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13148          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13149          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13150          int valid_find;
13151
13152             valid_find = 0;
13153             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13154                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13155             if (!$VMS_STATUS_SUCCESS(sts))
13156                 break;
13157
13158             /* with varying string, 1st word of buffer contains result length */
13159             rstr[rslt->length] = '\0';
13160
13161              /* Find where all the components are */
13162              v_sts = vms_split_path
13163                        (rstr,
13164                         &v_spec,
13165                         &v_len,
13166                         &r_spec,
13167                         &r_len,
13168                         &d_spec,
13169                         &d_len,
13170                         &n_spec,
13171                         &n_len,
13172                         &e_spec,
13173                         &e_len,
13174                         &vs_spec,
13175                         &vs_len);
13176
13177             /* If no version on input, truncate the version on output */
13178             if (!hasver && (vs_len > 0)) {
13179                 *vs_spec = '\0';
13180                 vs_len = 0;
13181             }
13182
13183             if (isunix) {
13184
13185                 /* In Unix report mode, remove the ".dir;1" from the name */
13186                 /* if it is a real directory */
13187                 if (decc_filename_unix_report || decc_efs_charset) {
13188                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13189                         Stat_t statbuf;
13190                         int ret_sts;
13191
13192                         ret_sts = flex_lstat(rstr, &statbuf);
13193                         if ((ret_sts == 0) &&
13194                             S_ISDIR(statbuf.st_mode)) {
13195                             e_len = 0;
13196                             e_spec[0] = 0;
13197                         }
13198                     }
13199                 }
13200
13201                 /* No version & a null extension on UNIX handling */
13202                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13203                     e_len = 0;
13204                     *e_spec = '\0';
13205                 }
13206             }
13207
13208             if (!decc_efs_case_preserve) {
13209                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13210             }
13211
13212             /* Find File treats a Null extension as return all extensions */
13213             /* This is contrary to Perl expectations */
13214
13215             if (wildstar || wildquery || vms_old_glob) {
13216                 /* really need to see if the returned file name matched */
13217                 /* but for now will assume that it matches */
13218                 valid_find = 1;
13219             } else {
13220                 /* Exact Match requested */
13221                 /* How are directories handled? - like a file */
13222                 if ((e_len == we_len) && (n_len == wn_len)) {
13223                     int t1;
13224                     t1 = e_len;
13225                     if (t1 > 0)
13226                         t1 = strncmp(e_spec, we_spec, e_len);
13227                     if (t1 == 0) {
13228                        t1 = n_len;
13229                        if (t1 > 0)
13230                            t1 = strncmp(n_spec, we_spec, n_len);
13231                        if (t1 == 0)
13232                            valid_find = 1;
13233                     }
13234                 }
13235             }
13236
13237             if (valid_find) {
13238                 found++;
13239
13240                 if (hasdir) {
13241                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13242                     begin = rstr;
13243                 }
13244                 else {
13245                     /* Start with the name */
13246                     begin = n_spec;
13247                 }
13248                 strcat(begin,"\n");
13249                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13250             }
13251         }
13252         if (cxt) (void)lib$find_file_end(&cxt);
13253
13254         if (!found) {
13255             /* Be POSIXish: return the input pattern when no matches */
13256             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13257             strcat(rstr,"\n");
13258             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13259         }
13260
13261         if (ok && sts != RMS$_NMF &&
13262             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13263         if (!ok) {
13264             if (!(sts & 1)) {
13265                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13266             }
13267             PerlIO_close(tmpfp);
13268             fp = NULL;
13269         }
13270         else {
13271             PerlIO_rewind(tmpfp);
13272             IoTYPE(io) = IoTYPE_RDONLY;
13273             IoIFP(io) = fp = tmpfp;
13274             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13275         }
13276     }
13277     Safefree(vmsspec);
13278     Safefree(rslt);
13279     return fp;
13280 }
13281
13282
13283 static char *
13284 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13285                    int *utf8_fl);
13286
13287 void
13288 unixrealpath_fromperl(pTHX_ CV *cv)
13289 {
13290     dXSARGS;
13291     char *fspec, *rslt_spec, *rslt;
13292     STRLEN n_a;
13293
13294     if (!items || items != 1)
13295         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13296
13297     fspec = SvPV(ST(0),n_a);
13298     if (!fspec || !*fspec) XSRETURN_UNDEF;
13299
13300     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13301     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13302
13303     ST(0) = sv_newmortal();
13304     if (rslt != NULL)
13305         sv_usepvn(ST(0),rslt,strlen(rslt));
13306     else
13307         Safefree(rslt_spec);
13308         XSRETURN(1);
13309 }
13310
13311 static char *
13312 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13313                    int *utf8_fl);
13314
13315 void
13316 vmsrealpath_fromperl(pTHX_ CV *cv)
13317 {
13318     dXSARGS;
13319     char *fspec, *rslt_spec, *rslt;
13320     STRLEN n_a;
13321
13322     if (!items || items != 1)
13323         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13324
13325     fspec = SvPV(ST(0),n_a);
13326     if (!fspec || !*fspec) XSRETURN_UNDEF;
13327
13328     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13329     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13330
13331     ST(0) = sv_newmortal();
13332     if (rslt != NULL)
13333         sv_usepvn(ST(0),rslt,strlen(rslt));
13334     else
13335         Safefree(rslt_spec);
13336         XSRETURN(1);
13337 }
13338
13339 #ifdef HAS_SYMLINK
13340 /*
13341  * A thin wrapper around decc$symlink to make sure we follow the
13342  * standard and do not create a symlink with a zero-length name,
13343  * and convert the target to Unix format, as the CRTL can't handle
13344  * targets in VMS format.
13345  */
13346 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13347 int
13348 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13349 {
13350     int sts;
13351     char * utarget;
13352
13353     if (!link_name || !*link_name) {
13354       SETERRNO(ENOENT, SS$_NOSUCHFILE);
13355       return -1;
13356     }
13357
13358     utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13359     /* An untranslatable filename should be passed through. */
13360     (void) int_tounixspec(contents, utarget, NULL);
13361     sts = symlink(utarget, link_name);
13362     PerlMem_free(utarget);
13363     return sts;
13364 }
13365 /*}}}*/
13366
13367 #endif /* HAS_SYMLINK */
13368
13369 int do_vms_case_tolerant(void);
13370
13371 void
13372 case_tolerant_process_fromperl(pTHX_ CV *cv)
13373 {
13374   dXSARGS;
13375   ST(0) = boolSV(do_vms_case_tolerant());
13376   XSRETURN(1);
13377 }
13378
13379 #ifdef USE_ITHREADS
13380
13381 void
13382 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13383                           struct interp_intern *dst)
13384 {
13385     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13386
13387     memcpy(dst,src,sizeof(struct interp_intern));
13388 }
13389
13390 #endif
13391
13392 void
13393 Perl_sys_intern_clear(pTHX)
13394 {
13395 }
13396
13397 void
13398 Perl_sys_intern_init(pTHX)
13399 {
13400     unsigned int ix = RAND_MAX;
13401     double x;
13402
13403     VMSISH_HUSHED = 0;
13404
13405     MY_POSIX_EXIT = vms_posix_exit;
13406
13407     x = (float)ix;
13408     MY_INV_RAND_MAX = 1./x;
13409 }
13410
13411 void
13412 init_os_extras(void)
13413 {
13414   dTHX;
13415   char* file = __FILE__;
13416   if (decc_disable_to_vms_logname_translation) {
13417     no_translate_barewords = TRUE;
13418   } else {
13419     no_translate_barewords = FALSE;
13420   }
13421
13422   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13423   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13424   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13425   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13426   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13427   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13428   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13429   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13430   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13431   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13432   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13433   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13434   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13435   newXSproto("VMS::Filespec::case_tolerant_process",
13436       case_tolerant_process_fromperl,file,"");
13437
13438   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13439
13440   return;
13441 }
13442
13443 #if __CRTL_VER == 80200000
13444 /* This missed getting in to the DECC SDK for 8.2 */
13445 char *realpath(const char *file_name, char * resolved_name, ...);
13446 #endif
13447
13448 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13449 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13450  * The perl fallback routine to provide realpath() is not as efficient
13451  * on OpenVMS.
13452  */
13453
13454 #ifdef __cplusplus
13455 extern "C" {
13456 #endif
13457
13458 /* Hack, use old stat() as fastest way of getting ino_t and device */
13459 int decc$stat(const char *name, void * statbuf);
13460 #if !defined(__VAX) && __CRTL_VER >= 80200000
13461 int decc$lstat(const char *name, void * statbuf);
13462 #else
13463 #define decc$lstat decc$stat
13464 #endif
13465
13466 #ifdef __cplusplus
13467 }
13468 #endif
13469
13470
13471 /* Realpath is fragile.  In 8.3 it does not work if the feature
13472  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13473  * links are implemented in RMS, not the CRTL. It also can fail if the
13474  * user does not have read/execute access to some of the directories.
13475  * So in order for Do What I Mean mode to work, if realpath() fails,
13476  * fall back to looking up the filename by the device name and FID.
13477  */
13478
13479 int vms_fid_to_name(char * outname, int outlen,
13480                     const char * name, int lstat_flag, mode_t * mode)
13481 {
13482 #pragma message save
13483 #pragma message disable MISALGNDSTRCT
13484 #pragma message disable MISALGNDMEM
13485 #pragma member_alignment save
13486 #pragma nomember_alignment
13487 struct statbuf_t {
13488     char           * st_dev;
13489     unsigned short st_ino[3];
13490     unsigned short old_st_mode;
13491     unsigned long  padl[30];  /* plenty of room */
13492 } statbuf;
13493 #pragma message restore
13494 #pragma member_alignment restore
13495
13496     int sts;
13497     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13498     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13499     char *fileified;
13500     char *temp_fspec;
13501     char *ret_spec;
13502
13503     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13504      * unexpected answers
13505      */
13506
13507     fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13508     if (fileified == NULL)
13509         _ckvmssts_noperl(SS$_INSFMEM);
13510
13511     temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13512     if (temp_fspec == NULL)
13513         _ckvmssts_noperl(SS$_INSFMEM);
13514
13515     sts = -1;
13516     /* First need to try as a directory */
13517     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13518     if (ret_spec != NULL) {
13519         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13520         if (ret_spec != NULL) {
13521             if (lstat_flag == 0)
13522                 sts = decc$stat(fileified, &statbuf);
13523             else
13524                 sts = decc$lstat(fileified, &statbuf);
13525         }
13526     }
13527
13528     /* Then as a VMS file spec */
13529     if (sts != 0) {
13530         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13531         if (ret_spec != NULL) {
13532             if (lstat_flag == 0) {
13533                 sts = decc$stat(temp_fspec, &statbuf);
13534             } else {
13535                 sts = decc$lstat(temp_fspec, &statbuf);
13536             }
13537         }
13538     }
13539
13540     if (sts) {
13541         /* Next try - allow multiple dots with out EFS CHARSET */
13542         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13543          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13544          * enable it if it isn't already.
13545          */
13546 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13547         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13548             decc$feature_set_value(decc_efs_charset_index, 1, 1);
13549 #endif
13550         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13551         if (lstat_flag == 0) {
13552             sts = decc$stat(name, &statbuf);
13553         } else {
13554             sts = decc$lstat(name, &statbuf);
13555         }
13556 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13557         if (!decc_efs_charset && (decc_efs_charset_index > 0))
13558             decc$feature_set_value(decc_efs_charset_index, 1, 0);
13559 #endif
13560     }
13561
13562
13563     /* and then because the Perl Unix to VMS conversion is not perfect */
13564     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13565     /* characters from filenames so we need to try it as-is */
13566     if (sts) {
13567         if (lstat_flag == 0) {
13568             sts = decc$stat(name, &statbuf);
13569         } else {
13570             sts = decc$lstat(name, &statbuf);
13571         }
13572     }
13573
13574     if (sts == 0) {
13575         int vms_sts;
13576
13577         dvidsc.dsc$a_pointer=statbuf.st_dev;
13578         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13579
13580         specdsc.dsc$a_pointer = outname;
13581         specdsc.dsc$w_length = outlen-1;
13582
13583         vms_sts = lib$fid_to_name
13584             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13585         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13586             outname[specdsc.dsc$w_length] = 0;
13587
13588             /* Return the mode */
13589             if (mode) {
13590                 *mode = statbuf.old_st_mode;
13591             }
13592         }
13593     }
13594     PerlMem_free(temp_fspec);
13595     PerlMem_free(fileified);
13596     return sts;
13597 }
13598
13599
13600
13601 static char *
13602 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13603                    int *utf8_fl)
13604 {
13605     char * rslt = NULL;
13606
13607 #ifdef HAS_SYMLINK
13608     if (decc_posix_compliant_pathnames > 0 ) {
13609         /* realpath currently only works if posix compliant pathnames are
13610          * enabled.  It may start working when they are not, but in that
13611          * case we still want the fallback behavior for backwards compatibility
13612          */
13613         rslt = realpath(filespec, outbuf);
13614     }
13615 #endif
13616
13617     if (rslt == NULL) {
13618         char * vms_spec;
13619         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13620         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13621         mode_t my_mode;
13622
13623         /* Fall back to fid_to_name */
13624
13625         Newx(vms_spec, VMS_MAXRSS + 1, char);
13626
13627         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13628         if (sts == 0) {
13629
13630
13631             /* Now need to trim the version off */
13632             sts = vms_split_path
13633                   (vms_spec,
13634                    &v_spec,
13635                    &v_len,
13636                    &r_spec,
13637                    &r_len,
13638                    &d_spec,
13639                    &d_len,
13640                    &n_spec,
13641                    &n_len,
13642                    &e_spec,
13643                    &e_len,
13644                    &vs_spec,
13645                    &vs_len);
13646
13647
13648                 if (sts == 0) {
13649                     int haslower = 0;
13650                     const char *cp;
13651
13652                     /* Trim off the version */
13653                     int file_len = v_len + r_len + d_len + n_len + e_len;
13654                     vms_spec[file_len] = 0;
13655
13656                     /* Trim off the .DIR if this is a directory */
13657                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13658                         if (S_ISDIR(my_mode)) {
13659                             e_len = 0;
13660                             e_spec[0] = 0;
13661                         }
13662                     }
13663
13664                     /* Drop NULL extensions on UNIX file specification */
13665                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
13666                         e_len = 0;
13667                         e_spec[0] = '\0';
13668                     }
13669
13670                     /* The result is expected to be in UNIX format */
13671                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13672
13673                     /* Downcase if input had any lower case letters and
13674                      * case preservation is not in effect.
13675                      */
13676                     if (!decc_efs_case_preserve) {
13677                         for (cp = filespec; *cp; cp++)
13678                             if (islower(*cp)) { haslower = 1; break; }
13679
13680                         if (haslower) __mystrtolower(rslt);
13681                     }
13682                 }
13683         } else {
13684
13685             /* Now for some hacks to deal with backwards and forward */
13686             /* compatibility */
13687             if (!decc_efs_charset) {
13688
13689                 /* 1. ODS-2 mode wants to do a syntax only translation */
13690                 rslt = int_rmsexpand(filespec, outbuf,
13691                                     NULL, 0, NULL, utf8_fl);
13692
13693             } else {
13694                 if (decc_filename_unix_report) {
13695                     char * dir_name;
13696                     char * vms_dir_name;
13697                     char * file_name;
13698
13699                     /* 2. ODS-5 / UNIX report mode should return a failure */
13700                     /*    if the parent directory also does not exist */
13701                     /*    Otherwise, get the real path for the parent */
13702                     /*    and add the child to it. */
13703
13704                     /* basename / dirname only available for VMS 7.0+ */
13705                     /* So we may need to implement them as common routines */
13706
13707                     Newx(dir_name, VMS_MAXRSS + 1, char);
13708                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13709                     dir_name[0] = '\0';
13710                     file_name = NULL;
13711
13712                     /* First try a VMS parse */
13713                     sts = vms_split_path
13714                           (filespec,
13715                            &v_spec,
13716                            &v_len,
13717                            &r_spec,
13718                            &r_len,
13719                            &d_spec,
13720                            &d_len,
13721                            &n_spec,
13722                            &n_len,
13723                            &e_spec,
13724                            &e_len,
13725                            &vs_spec,
13726                            &vs_len);
13727
13728                     if (sts == 0) {
13729                         /* This is VMS */
13730
13731                         int dir_len = v_len + r_len + d_len + n_len;
13732                         if (dir_len > 0) {
13733                            memcpy(dir_name, filespec, dir_len);
13734                            dir_name[dir_len] = '\0';
13735                            file_name = (char *)&filespec[dir_len + 1];
13736                         }
13737                     } else {
13738                         /* This must be UNIX */
13739                         char * tchar;
13740
13741                         tchar = strrchr(filespec, '/');
13742
13743                         if (tchar != NULL) {
13744                             int dir_len = tchar - filespec;
13745                             memcpy(dir_name, filespec, dir_len);
13746                             dir_name[dir_len] = '\0';
13747                             file_name = (char *) &filespec[dir_len + 1];
13748                         }
13749                     }
13750
13751                     /* Dir name is defaulted */
13752                     if (dir_name[0] == 0) {
13753                         dir_name[0] = '.';
13754                         dir_name[1] = '\0';
13755                     }
13756
13757                     /* Need realpath for the directory */
13758                     sts = vms_fid_to_name(vms_dir_name,
13759                                           VMS_MAXRSS + 1,
13760                                           dir_name, 0, NULL);
13761
13762                     if (sts == 0) {
13763                         /* Now need to pathify it. */
13764                         char *tdir = int_pathify_dirspec(vms_dir_name,
13765                                                          outbuf);
13766
13767                         /* And now add the original filespec to it */
13768                         if (file_name != NULL) {
13769                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13770                         }
13771                         return outbuf;
13772                     }
13773                     Safefree(vms_dir_name);
13774                     Safefree(dir_name);
13775                 }
13776             }
13777         }
13778         Safefree(vms_spec);
13779     }
13780     return rslt;
13781 }
13782
13783 static char *
13784 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13785                    int *utf8_fl)
13786 {
13787     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13788     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13789
13790     /* Fall back to fid_to_name */
13791
13792     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13793     if (sts != 0) {
13794         return NULL;
13795     }
13796     else {
13797
13798
13799         /* Now need to trim the version off */
13800         sts = vms_split_path
13801                   (outbuf,
13802                    &v_spec,
13803                    &v_len,
13804                    &r_spec,
13805                    &r_len,
13806                    &d_spec,
13807                    &d_len,
13808                    &n_spec,
13809                    &n_len,
13810                    &e_spec,
13811                    &e_len,
13812                    &vs_spec,
13813                    &vs_len);
13814
13815
13816         if (sts == 0) {
13817             int haslower = 0;
13818             const char *cp;
13819
13820             /* Trim off the version */
13821             int file_len = v_len + r_len + d_len + n_len + e_len;
13822             outbuf[file_len] = 0;
13823
13824             /* Downcase if input had any lower case letters and
13825              * case preservation is not in effect.
13826              */
13827             if (!decc_efs_case_preserve) {
13828                 for (cp = filespec; *cp; cp++)
13829                     if (islower(*cp)) { haslower = 1; break; }
13830
13831                 if (haslower) __mystrtolower(outbuf);
13832             }
13833         }
13834     }
13835     return outbuf;
13836 }
13837
13838
13839 /*}}}*/
13840 /* External entry points */
13841 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13842 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13843
13844 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13845 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13846
13847 /* case_tolerant */
13848
13849 /*{{{int do_vms_case_tolerant(void)*/
13850 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13851  * controlled by a process setting.
13852  */
13853 int do_vms_case_tolerant(void)
13854 {
13855     return vms_process_case_tolerant;
13856 }
13857 /*}}}*/
13858 /* External entry points */
13859 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13860 int Perl_vms_case_tolerant(void)
13861 { return do_vms_case_tolerant(); }
13862 #else
13863 int Perl_vms_case_tolerant(void)
13864 { return vms_process_case_tolerant; }
13865 #endif
13866
13867
13868  /* Start of DECC RTL Feature handling */
13869
13870 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13871
13872 static int
13873 set_feature_default(const char *name, int value)
13874 {
13875     int status;
13876     int index;
13877
13878     index = decc$feature_get_index(name);
13879
13880     status = decc$feature_set_value(index, 1, value);
13881     if (index == -1 || (status == -1)) {
13882       return -1;
13883     }
13884
13885     status = decc$feature_get_value(index, 1);
13886     if (status != value) {
13887       return -1;
13888     }
13889
13890     /* Various things may check for an environment setting
13891      * rather than the feature directly, so set that too.
13892      */
13893     vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13894
13895     return 0;
13896 }
13897 #endif
13898
13899
13900 /* C RTL Feature settings */
13901
13902 #if defined(__DECC) || defined(__DECCXX)
13903
13904 #ifdef __cplusplus
13905 extern "C" {
13906 #endif
13907
13908 extern void
13909 vmsperl_set_features(void)
13910 {
13911     int status;
13912     int s;
13913     char val_str[10];
13914 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13915     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13916     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13917     unsigned long case_perm;
13918     unsigned long case_image;
13919 #endif
13920
13921     /* Allow an exception to bring Perl into the VMS debugger */
13922     vms_debug_on_exception = 0;
13923     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13924     if ($VMS_STATUS_SUCCESS(status)) {
13925        val_str[0] = _toupper(val_str[0]);
13926        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13927          vms_debug_on_exception = 1;
13928        else
13929          vms_debug_on_exception = 0;
13930     }
13931
13932     /* Debug unix/vms file translation routines */
13933     vms_debug_fileify = 0;
13934     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13935     if ($VMS_STATUS_SUCCESS(status)) {
13936         val_str[0] = _toupper(val_str[0]);
13937         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13938             vms_debug_fileify = 1;
13939         else
13940             vms_debug_fileify = 0;
13941     }
13942
13943
13944     /* Historically PERL has been doing vmsify / stat differently than */
13945     /* the CRTL.  In particular, under some conditions the CRTL will   */
13946     /* remove some illegal characters like spaces from filenames       */
13947     /* resulting in some differences.  The stat()/lstat() wrapper has  */
13948     /* been reporting such file names as invalid and fails to stat them */
13949     /* fixing this bug so that stat()/lstat() accept these like the     */
13950     /* CRTL does will result in several tests failing.                  */
13951     /* This should really be fixed, but for now, set up a feature to    */
13952     /* enable it so that the impact can be studied.                     */
13953     vms_bug_stat_filename = 0;
13954     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13955     if ($VMS_STATUS_SUCCESS(status)) {
13956         val_str[0] = _toupper(val_str[0]);
13957         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13958             vms_bug_stat_filename = 1;
13959         else
13960             vms_bug_stat_filename = 0;
13961     }
13962
13963
13964     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13965     vms_vtf7_filenames = 0;
13966     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13967     if ($VMS_STATUS_SUCCESS(status)) {
13968        val_str[0] = _toupper(val_str[0]);
13969        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13970          vms_vtf7_filenames = 1;
13971        else
13972          vms_vtf7_filenames = 0;
13973     }
13974
13975     /* unlink all versions on unlink() or rename() */
13976     vms_unlink_all_versions = 0;
13977     status = simple_trnlnm
13978         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13979     if ($VMS_STATUS_SUCCESS(status)) {
13980        val_str[0] = _toupper(val_str[0]);
13981        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13982          vms_unlink_all_versions = 1;
13983        else
13984          vms_unlink_all_versions = 0;
13985     }
13986
13987 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13988     /* Detect running under GNV Bash or other UNIX like shell */
13989     gnv_unix_shell = 0;
13990     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13991     if ($VMS_STATUS_SUCCESS(status)) {
13992          gnv_unix_shell = 1;
13993          set_feature_default("DECC$EFS_CHARSET", 1);
13994          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13995          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13996          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13997          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13998          vms_unlink_all_versions = 1;
13999          vms_posix_exit = 1;
14000     }
14001     /* Some reasonable defaults that are not CRTL defaults */
14002     set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14003 #endif
14004
14005     /* hacks to see if known bugs are still present for testing */
14006
14007     /* PCP mode requires creating /dev/null special device file */
14008     decc_bug_devnull = 0;
14009     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14010     if ($VMS_STATUS_SUCCESS(status)) {
14011        val_str[0] = _toupper(val_str[0]);
14012        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14013           decc_bug_devnull = 1;
14014        else
14015           decc_bug_devnull = 0;
14016     }
14017
14018     /* UNIX directory names with no paths are broken in a lot of places */
14019     decc_dir_barename = 1;
14020     status = simple_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14021     if ($VMS_STATUS_SUCCESS(status)) {
14022       val_str[0] = _toupper(val_str[0]);
14023       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14024         decc_dir_barename = 1;
14025       else
14026         decc_dir_barename = 0;
14027     }
14028
14029 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14030     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14031     if (s >= 0) {
14032         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14033         if (decc_disable_to_vms_logname_translation < 0)
14034             decc_disable_to_vms_logname_translation = 0;
14035     }
14036
14037     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14038     if (s >= 0) {
14039         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14040         if (decc_efs_case_preserve < 0)
14041             decc_efs_case_preserve = 0;
14042     }
14043
14044     s = decc$feature_get_index("DECC$EFS_CHARSET");
14045     decc_efs_charset_index = s;
14046     if (s >= 0) {
14047         decc_efs_charset = decc$feature_get_value(s, 1);
14048         if (decc_efs_charset < 0)
14049             decc_efs_charset = 0;
14050     }
14051
14052     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14053     if (s >= 0) {
14054         decc_filename_unix_report = decc$feature_get_value(s, 1);
14055         if (decc_filename_unix_report > 0) {
14056             decc_filename_unix_report = 1;
14057             vms_posix_exit = 1;
14058         }
14059         else
14060             decc_filename_unix_report = 0;
14061     }
14062
14063     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14064     if (s >= 0) {
14065         decc_filename_unix_only = decc$feature_get_value(s, 1);
14066         if (decc_filename_unix_only > 0) {
14067             decc_filename_unix_only = 1;
14068         }
14069         else {
14070             decc_filename_unix_only = 0;
14071         }
14072     }
14073
14074     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14075     if (s >= 0) {
14076         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14077         if (decc_filename_unix_no_version < 0)
14078             decc_filename_unix_no_version = 0;
14079     }
14080
14081     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14082     if (s >= 0) {
14083         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14084         if (decc_readdir_dropdotnotype < 0)
14085             decc_readdir_dropdotnotype = 0;
14086     }
14087
14088 #if __CRTL_VER >= 80200000
14089     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14090     if (s >= 0) {
14091         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14092         if (decc_posix_compliant_pathnames < 0)
14093             decc_posix_compliant_pathnames = 0;
14094         if (decc_posix_compliant_pathnames > 4)
14095             decc_posix_compliant_pathnames = 0;
14096     }
14097
14098 #endif
14099 #else
14100     status = simple_trnlnm
14101         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14102     if ($VMS_STATUS_SUCCESS(status)) {
14103         val_str[0] = _toupper(val_str[0]);
14104         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14105            decc_disable_to_vms_logname_translation = 1;
14106         }
14107     }
14108
14109 #ifndef __VAX
14110     status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14111     if ($VMS_STATUS_SUCCESS(status)) {
14112         val_str[0] = _toupper(val_str[0]);
14113         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14114            decc_efs_case_preserve = 1;
14115         }
14116     }
14117 #endif
14118
14119     status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14120     if ($VMS_STATUS_SUCCESS(status)) {
14121         val_str[0] = _toupper(val_str[0]);
14122         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14123            decc_filename_unix_report = 1;
14124         }
14125     }
14126     status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14127     if ($VMS_STATUS_SUCCESS(status)) {
14128         val_str[0] = _toupper(val_str[0]);
14129         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14130            decc_filename_unix_only = 1;
14131            decc_filename_unix_report = 1;
14132         }
14133     }
14134     status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14135     if ($VMS_STATUS_SUCCESS(status)) {
14136         val_str[0] = _toupper(val_str[0]);
14137         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14138            decc_filename_unix_no_version = 1;
14139         }
14140     }
14141     status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14142     if ($VMS_STATUS_SUCCESS(status)) {
14143         val_str[0] = _toupper(val_str[0]);
14144         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14145            decc_readdir_dropdotnotype = 1;
14146         }
14147     }
14148 #endif
14149
14150 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14151
14152      /* Report true case tolerance */
14153     /*----------------------------*/
14154     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14155     if (!$VMS_STATUS_SUCCESS(status))
14156         case_perm = PPROP$K_CASE_BLIND;
14157     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14158     if (!$VMS_STATUS_SUCCESS(status))
14159         case_image = PPROP$K_CASE_BLIND;
14160     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14161         (case_image == PPROP$K_CASE_SENSITIVE))
14162         vms_process_case_tolerant = 0;
14163
14164 #endif
14165
14166     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14167     /* for strict backward compatibility */
14168     status = simple_trnlnm
14169         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14170     if ($VMS_STATUS_SUCCESS(status)) {
14171        val_str[0] = _toupper(val_str[0]);
14172        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14173          vms_posix_exit = 1;
14174        else
14175          vms_posix_exit = 0;
14176     }
14177 }
14178
14179 /* Use 32-bit pointers because that's what the image activator
14180  * assumes for the LIB$INITIALZE psect.
14181  */
14182 #if __INITIAL_POINTER_SIZE
14183 #pragma pointer_size save
14184 #pragma pointer_size 32
14185 #endif
14186
14187 /* Create a reference to the LIB$INITIALIZE function. */
14188 extern void LIB$INITIALIZE(void);
14189 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14190
14191 /* Create an array of pointers to the init functions in the special
14192  * LIB$INITIALIZE section. In our case, the array only has one entry.
14193  */
14194 #pragma extern_model save
14195 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
14196 extern void (* const vmsperl_unused_global_2[])() =
14197 {
14198    vmsperl_set_features,
14199 };
14200 #pragma extern_model restore
14201
14202 #if __INITIAL_POINTER_SIZE
14203 #pragma pointer_size restore
14204 #endif
14205
14206 #ifdef __cplusplus
14207 }
14208 #endif
14209
14210 #endif /* defined(__DECC) || defined(__DECCXX) */
14211 /*  End of vms.c */