vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993-2015 by Charles Bailey and others.
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  */
  10
  11 /*
  12  *   Yet small as was their hunted band
  13  *   still fell and fearless was each hand,
  14  *   and strong deeds they wrought yet oft,
  15  *   and loved the woods, whose ways more soft
  16  *   them seemed than thralls of that black throne
  17  *   to live and languish in halls of stone.
  18  *        "The Lay of Leithian", Canto II, lines 135-40
  19  *
  20  *     [p.162 of _The Lays of Beleriand_]
  21  */
  22
  23 #include <acedef.h>
  24 #include <acldef.h>
  25 #include <armdef.h>
  26 #include <chpdef.h>
  27 #include <clidef.h>
  28 #include <climsgdef.h>
  29 #include <dcdef.h>
  30 #include <descrip.h>
  31 #include <devdef.h>
  32 #include <dvidef.h>
  33 #include <float.h>
  34 #include <fscndef.h>
  35 #include <iodef.h>
  36 #include <jpidef.h>
  37 #include <kgbdef.h>
  38 #include <libclidef.h>
  39 #include <libdef.h>
  40 #include <lib$routines.h>
  41 #include <lnmdef.h>
  42 #include <ossdef.h>
  43 #include <ppropdef.h>
  44 #include <prvdef.h>
  45 #include <pscandef.h>
  46 #include <psldef.h>
  47 #include <rms.h>
  48 #include <shrdef.h>
  49 #include <ssdef.h>
  50 #include <starlet.h>
  51 #include <strdef.h>
  52 #include <str$routines.h>
  53 #include <syidef.h>
  54 #include <uaidef.h>
  55 #include <uicdef.h>
  56 #include <stsdef.h>
  57 #include <efndef.h>
  58 #define NO_EFN EFN$C_ENF
  59
  60 #include <unixlib.h>
  61
  62 #pragma member_alignment save
  63 #pragma nomember_alignment longword
  64 struct item_list_3 {
  65         unsigned short len;
  66         unsigned short code;
  67         void * bufadr;
  68         unsigned short * retadr;
  69 };
  70 #pragma member_alignment restore
  71
  72 /* Older versions of ssdef.h don't have these */
  73 #ifndef SS$_INVFILFOROP
  74 #  define SS$_INVFILFOROP 3930
  75 #endif
  76 #ifndef SS$_NOSUCHOBJECT
  77 #  define SS$_NOSUCHOBJECT 2696
  78 #endif
  79
  80 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
  81 #define PERLIO_NOT_STDIO 0
  82
  83 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
  84  * code below needs to get to the underlying CRTL routines. */
  85 #define DONT_MASK_RTL_CALLS
  86 #include "EXTERN.h"
  87 #include "perl.h"
  88 #include "XSUB.h"
  89 /* Anticipating future expansion in lexical warnings . . . */
  90 #ifndef WARN_INTERNAL
  91 #  define WARN_INTERNAL WARN_MISC
  92 #endif
  93
  94 #ifdef VMS_LONGNAME_SUPPORT
  95 #include <libfildef.h>
  96 #endif
  97
  98 #if __CRTL_VER >= 80200000
  99 #ifdef lstat
 100 #undef lstat
 101 #endif
 102 #else
 103 #ifdef lstat
 104 #undef lstat
 105 #endif
 106 #define lstat(_x, _y) stat(_x, _y)
 107 #endif
 108
 109 /* Routine to create a decterm for use with the Perl debugger */
 110 /* No headers, this information was found in the Programming Concepts Manual */
 111
 112 static int (*decw_term_port)
 113    (const struct dsc$descriptor_s * display,
 114     const struct dsc$descriptor_s * setup_file,
 115     const struct dsc$descriptor_s * customization,
 116     struct dsc$descriptor_s * result_device_name,
 117     unsigned short * result_device_name_length,
 118     void * controller,
 119     void * char_buffer,
 120     void * char_change_buffer) = 0;
 121
 122 #if defined(NEED_AN_H_ERRNO)
 123 dEXT int h_errno;
 124 #endif
 125
 126 #if defined(__DECC) || defined(__DECCXX)
 127 #pragma member_alignment save
 128 #pragma nomember_alignment longword
 129 #pragma message save
 130 #pragma message disable misalgndmem
 131 #endif
 132 struct itmlst_3 {
 133   unsigned short int buflen;
 134   unsigned short int itmcode;
 135   void *bufadr;
 136   unsigned short int *retlen;
 137 };
 138
 139 struct filescan_itmlst_2 {
 140     unsigned short length;
 141     unsigned short itmcode;
 142     char * component;
 143 };
 144
 145 struct vs_str_st {
 146     unsigned short length;
 147     char str[VMS_MAXRSS];
 148     unsigned short pad; /* for longword struct alignment */
 149 };
 150
 151 #if defined(__DECC) || defined(__DECCXX)
 152 #pragma message restore
 153 #pragma member_alignment restore
 154 #endif
 155
 156 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 157 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 158 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 159 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 160 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 161 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 162 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 163 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 164 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 165 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 166 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 167 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 168
 169 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 170 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 171 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 172 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 173
 174 static char *  int_rmsexpand_vms(
 175     const char * filespec, char * outbuf, unsigned opts);
 176 static char * int_rmsexpand_tovms(
 177     const char * filespec, char * outbuf, unsigned opts);
 178 static char *int_tovmsspec
 179    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 180 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 181 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 182 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 183
 184 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 185 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 186
 187 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 188  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 189  * the Perl facility.
 190  */
 191 #define PERL_LNM_MAX_ITER 10
 192
 193   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 194 #define MAX_DCL_SYMBOL          (8192)
 195 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 196
 197 static char *__mystrtolower(char *str)
 198 {
 199   if (str) for (; *str; ++str) *str= toLOWER_L1(*str);
 200   return str;
 201 }
 202
 203 static struct dsc$descriptor_s fildevdsc =
 204   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 205 static struct dsc$descriptor_s crtlenvdsc =
 206   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 207 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 208 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 209 static struct dsc$descriptor_s **env_tables = defenv;
 210 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 211
 212 /* True if we shouldn't treat barewords as logicals during directory */
 213 /* munching */
 214 static int no_translate_barewords;
 215
 216 /* DECC feature indexes.  We grab the indexes at start-up
 217  * time for later use with decc$feature_get_value.
 218  */
 219 static int disable_to_vms_logname_translation_index = -1;
 220 static int disable_posix_root_index = -1;
 221 static int efs_case_preserve_index = -1;
 222 static int efs_charset_index = -1;
 223 static int filename_unix_no_version_index = -1;
 224 static int filename_unix_only_index = -1;
 225 static int filename_unix_report_index = -1;
 226 static int posix_compliant_pathnames_index = -1;
 227 static int readdir_dropdotnotype_index = -1;
 228
 229 #define DECC_DISABLE_TO_VMS_LOGNAME_TRANSLATION \
 230     (decc$feature_get_value(disable_to_vms_logname_translation_index,__FEATURE_MODE_CURVAL)>0)
 231 #define DECC_DISABLE_POSIX_ROOT  \
 232     (decc$feature_get_value(disable_posix_root_index,__FEATURE_MODE_CURVAL)>0)
 233 #define DECC_EFS_CASE_PRESERVE  \
 234     (decc$feature_get_value(efs_case_preserve_index,__FEATURE_MODE_CURVAL)>0)
 235 #define DECC_EFS_CHARSET  \
 236     (decc$feature_get_value(efs_charset_index,__FEATURE_MODE_CURVAL)>0)
 237 #define DECC_FILENAME_UNIX_NO_VERSION  \
 238     (decc$feature_get_value(filename_unix_no_version_index,__FEATURE_MODE_CURVAL)>0)
 239 #define DECC_FILENAME_UNIX_ONLY  \
 240     (decc$feature_get_value(filename_unix_only_index,__FEATURE_MODE_CURVAL)>0)
 241 #define DECC_FILENAME_UNIX_REPORT  \
 242     (decc$feature_get_value(filename_unix_report_index,__FEATURE_MODE_CURVAL)>0)
 243 #define DECC_POSIX_COMPLIANT_PATHNAMES   \
 244     (decc$feature_get_value(posix_compliant_pathnames_index,__FEATURE_MODE_CURVAL)>0)
 245 #define DECC_READDIR_DROPDOTNOTYPE  \
 246     (decc$feature_get_value(readdir_dropdotnotype_index,__FEATURE_MODE_CURVAL)>0)
 247
 248 static int vms_process_case_tolerant = 1;
 249 int vms_vtf7_filenames = 0;
 250 int gnv_unix_shell = 0;
 251 static int vms_unlink_all_versions = 0;
 252 static int vms_posix_exit = 0;
 253
 254 /* bug workarounds if needed */
 255 int decc_bug_devnull = 1;
 256 int vms_bug_stat_filename = 0;
 257
 258 static int vms_debug_on_exception = 0;
 259 static int vms_debug_fileify = 0;
 260
 261 /* Simple logical name translation */
 262 static int
 263 simple_trnlnm(const char * logname, char * value, int value_len)
 264 {
 265     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 266     const unsigned long attr = LNM$M_CASE_BLIND;
 267     struct dsc$descriptor_s name_dsc;
 268     int status;
 269     unsigned short result;
 270     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 271                                 {0, 0, 0, 0}};
 272
 273     name_dsc.dsc$w_length = strlen(logname);
 274     name_dsc.dsc$a_pointer = (char *)logname;
 275     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 276     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 277
 278     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 279
 280     if ($VMS_STATUS_SUCCESS(status)) {
 281
 282          /* Null terminate and return the string */
 283         /*--------------------------------------*/
 284         value[result] = 0;
 285         return result;
 286     }
 287
 288     return 0;
 289 }
 290
 291
 292 /* Is this a UNIX file specification?
 293  *   No longer a simple check with EFS file specs
 294  *   For now, not a full check, but need to
 295  *   handle POSIX ^UP^ specifications
 296  *   Fixing to handle ^/ cases would require
 297  *   changes to many other conversion routines.
 298  */
 299
 300 static int
 301 is_unix_filespec(const char *path)
 302 {
 303     int ret_val;
 304     const char * pch1;
 305
 306     ret_val = 0;
 307     if (! strBEGINs(path,"\"^UP^")) {
 308         pch1 = strchr(path, '/');
 309         if (pch1 != NULL)
 310             ret_val = 1;
 311         else {
 312
 313             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 314             if (DECC_FILENAME_UNIX_REPORT || DECC_FILENAME_UNIX_ONLY) {
 315               if (strEQ(path,"."))
 316                 ret_val = 1;
 317             }
 318         }
 319     }
 320     return ret_val;
 321 }
 322
 323 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 324  */
 325
 326 static void
 327 ucs2_to_vtf7(char *outspec, unsigned long ucs2_char, int * output_cnt)
 328 {
 329     unsigned char * ucs_ptr;
 330     int hex;
 331
 332     ucs_ptr = (unsigned char *)&ucs2_char;
 333
 334     outspec[0] = '^';
 335     outspec[1] = 'U';
 336     hex = (ucs_ptr[1] >> 4) & 0xf;
 337     if (hex < 0xA)
 338         outspec[2] = hex + '0';
 339     else
 340         outspec[2] = (hex - 9) + 'A';
 341     hex = ucs_ptr[1] & 0xF;
 342     if (hex < 0xA)
 343         outspec[3] = hex + '0';
 344     else {
 345         outspec[3] = (hex - 9) + 'A';
 346     }
 347     hex = (ucs_ptr[0] >> 4) & 0xf;
 348     if (hex < 0xA)
 349         outspec[4] = hex + '0';
 350     else
 351         outspec[4] = (hex - 9) + 'A';
 352     hex = ucs_ptr[1] & 0xF;
 353     if (hex < 0xA)
 354         outspec[5] = hex + '0';
 355     else {
 356         outspec[5] = (hex - 9) + 'A';
 357     }
 358     *output_cnt = 6;
 359 }
 360
 361
 362 /* This handles the conversion of a UNIX extended character set to a ^
 363  * escaped VMS character.
 364  * in a UNIX file specification.
 365  *
 366  * The output count variable contains the number of characters added
 367  * to the output string.
 368  *
 369  * The return value is the number of characters read from the input string
 370  */
 371 static int
 372 copy_expand_unix_filename_escape(char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 373 {
 374     int count;
 375     int utf8_flag;
 376
 377     utf8_flag = 0;
 378     if (utf8_fl)
 379       utf8_flag = *utf8_fl;
 380
 381     count = 0;
 382     *output_cnt = 0;
 383     if (*inspec >= 0x80) {
 384         if (utf8_fl && vms_vtf7_filenames) {
 385         unsigned long ucs_char;
 386
 387             ucs_char = 0;
 388
 389             if ((*inspec & 0xE0) == 0xC0) {
 390                 /* 2 byte Unicode */
 391                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 392                 if (ucs_char >= 0x80) {
 393                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 394                     return 2;
 395                 }
 396             } else if ((*inspec & 0xF0) == 0xE0) {
 397                 /* 3 byte Unicode */
 398                 ucs_char = ((inspec[0] & 0xF) << 12) +
 399                    ((inspec[1] & 0x3f) << 6) +
 400                    (inspec[2] & 0x3f);
 401                 if (ucs_char >= 0x800) {
 402                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 403                     return 3;
 404                 }
 405
 406 #if 0 /* I do not see longer sequences supported by OpenVMS */
 407       /* Maybe some one can fix this later */
 408             } else if ((*inspec & 0xF8) == 0xF0) {
 409                 /* 4 byte Unicode */
 410                 /* UCS-4 to UCS-2 */
 411             } else if ((*inspec & 0xFC) == 0xF8) {
 412                 /* 5 byte Unicode */
 413                 /* UCS-4 to UCS-2 */
 414             } else if ((*inspec & 0xFE) == 0xFC) {
 415                 /* 6 byte Unicode */
 416                 /* UCS-4 to UCS-2 */
 417 #endif
 418             }
 419         }
 420
 421         /* High bit set, but not a Unicode character! */
 422
 423         /* Non printing DECMCS or ISO Latin-1 character? */
 424         if ((unsigned char)*inspec <= 0x9F) {
 425             int hex;
 426             outspec[0] = '^';
 427             outspec++;
 428             hex = (*inspec >> 4) & 0xF;
 429             if (hex < 0xA)
 430                 outspec[1] = hex + '0';
 431             else {
 432                 outspec[1] = (hex - 9) + 'A';
 433             }
 434             hex = *inspec & 0xF;
 435             if (hex < 0xA)
 436                 outspec[2] = hex + '0';
 437             else {
 438                 outspec[2] = (hex - 9) + 'A';
 439             }
 440             *output_cnt = 3;
 441             return 1;
 442         } else if ((unsigned char)*inspec == 0xA0) {
 443             outspec[0] = '^';
 444             outspec[1] = 'A';
 445             outspec[2] = '0';
 446             *output_cnt = 3;
 447             return 1;
 448         } else if ((unsigned char)*inspec == 0xFF) {
 449             outspec[0] = '^';
 450             outspec[1] = 'F';
 451             outspec[2] = 'F';
 452             *output_cnt = 3;
 453             return 1;
 454         }
 455         *outspec = *inspec;
 456         *output_cnt = 1;
 457         return 1;
 458     }
 459
 460     /* Is this a macro that needs to be passed through?
 461      * Macros start with $( and an alpha character, followed
 462      * by a string of alpha numeric characters ending with a )
 463      * If this does not match, then encode it as ODS-5.
 464      */
 465     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 466     int tcnt;
 467
 468         if (isALPHA_L1(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 469             tcnt = 3;
 470             outspec[0] = inspec[0];
 471             outspec[1] = inspec[1];
 472             outspec[2] = inspec[2];
 473
 474             while(isALPHA_L1(inspec[tcnt]) ||
 475                   (inspec[2] == '.') || (inspec[2] == '_')) {
 476                 outspec[tcnt] = inspec[tcnt];
 477                 tcnt++;
 478             }
 479             if (inspec[tcnt] == ')') {
 480                 outspec[tcnt] = inspec[tcnt];
 481                 tcnt++;
 482                 *output_cnt = tcnt;
 483                 return tcnt;
 484             }
 485         }
 486     }
 487
 488     switch (*inspec) {
 489     case 0x7f:
 490         outspec[0] = '^';
 491         outspec[1] = '7';
 492         outspec[2] = 'F';
 493         *output_cnt = 3;
 494         return 1;
 495         break;
 496     case '?':
 497         if (!DECC_EFS_CHARSET)
 498           outspec[0] = '%';
 499         else
 500           outspec[0] = '?';
 501         *output_cnt = 1;
 502         return 1;
 503         break;
 504     case '.':
 505     case '!':
 506     case '#':
 507     case '&':
 508     case '\'':
 509     case '`':
 510     case '(':
 511     case ')':
 512     case '+':
 513     case '@':
 514     case '{':
 515     case '}':
 516     case ',':
 517     case ';':
 518     case '[':
 519     case ']':
 520     case '%':
 521     case '^':
 522     case '\\':
 523         /* Don't escape again if following character is
 524          * already something we escape.
 525          */
 526         if (strchr(".!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 527             *outspec = *inspec;
 528             *output_cnt = 1;
 529             return 1;
 530             break;
 531         }
 532         /* But otherwise fall through and escape it. */
 533     case '=':
 534         /* Assume that this is to be escaped */
 535         outspec[0] = '^';
 536         outspec[1] = *inspec;
 537         *output_cnt = 2;
 538         return 1;
 539         break;
 540     case ' ': /* space */
 541         /* Assume that this is to be escaped */
 542         outspec[0] = '^';
 543         outspec[1] = '_';
 544         *output_cnt = 2;
 545         return 1;
 546         break;
 547     default:
 548         *outspec = *inspec;
 549         *output_cnt = 1;
 550         return 1;
 551         break;
 552     }
 553     return 0;
 554 }
 555
 556
 557 /* This handles the expansion of a '^' prefix to the proper character
 558  * in a UNIX file specification.
 559  *
 560  * The output count variable contains the number of characters added
 561  * to the output string.
 562  *
 563  * The return value is the number of characters read from the input
 564  * string
 565  */
 566 static int
 567 copy_expand_vms_filename_escape(char *outspec, const char *inspec, int *output_cnt)
 568 {
 569     int count;
 570     int scnt;
 571
 572     count = 0;
 573     *output_cnt = 0;
 574     if (*inspec == '^') {
 575         inspec++;
 576         switch (*inspec) {
 577         /* Spaces and non-trailing dots should just be passed through,
 578          * but eat the escape character.
 579          */
 580         case '.':
 581             *outspec = *inspec;
 582             count += 2;
 583             (*output_cnt)++;
 584             break;
 585         case '_': /* space */
 586             *outspec = ' ';
 587             count += 2;
 588             (*output_cnt)++;
 589             break;
 590         case '^':
 591             /* Hmm.  Better leave the escape escaped. */
 592             outspec[0] = '^';
 593             outspec[1] = '^';
 594             count += 2;
 595             (*output_cnt) += 2;
 596             break;
 597         case 'U': /* Unicode - FIX-ME this is wrong. */
 598             inspec++;
 599             count++;
 600             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 601             if (scnt == 4) {
 602                 unsigned int c1, c2;
 603                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 604                 outspec[0] = c1 & 0xff;
 605                 outspec[1] = c2 & 0xff;
 606                 if (scnt > 1) {
 607                     (*output_cnt) += 2;
 608                     count += 4;
 609                 }
 610             }
 611             else {
 612                 /* Error - do best we can to continue */
 613                 *outspec = 'U';
 614                 outspec++;
 615                 (*output_cnt++);
 616                 *outspec = *inspec;
 617                 count++;
 618                 (*output_cnt++);
 619             }
 620             break;
 621         default:
 622             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 623             if (scnt == 2) {
 624                 /* Hex encoded */
 625                 unsigned int c1;
 626                 scnt = sscanf(inspec, "%2x", &c1);
 627                 outspec[0] = c1 & 0xff;
 628                 if (scnt > 0) {
 629                     (*output_cnt++);
 630                     count += 2;
 631                 }
 632             }
 633             else {
 634                 *outspec = *inspec;
 635                 count++;
 636                 (*output_cnt++);
 637             }
 638         }
 639     }
 640     else {
 641         *outspec = *inspec;
 642         count++;
 643         (*output_cnt)++;
 644     }
 645     return count;
 646 }
 647
 648 /* vms_split_path - Verify that the input file specification is a
 649  * VMS format file specification, and provide pointers to the components of
 650  * it.  With EFS format filenames, this is virtually the only way to
 651  * parse a VMS path specification into components.
 652  *
 653  * If the sum of the components do not add up to the length of the
 654  * string, then the passed file specification is probably a UNIX style
 655  * path.
 656  */
 657 static int
 658 vms_split_path(const char * path, char * * volume, int * vol_len, char * * root, int * root_len,
 659                char * * dir, int * dir_len, char * * name, int * name_len,
 660                char * * ext, int * ext_len, char * * version, int * ver_len)
 661 {
 662     struct dsc$descriptor path_desc;
 663     int status;
 664     unsigned long flags;
 665     int ret_stat;
 666     struct filescan_itmlst_2 item_list[9];
 667     const int filespec = 0;
 668     const int nodespec = 1;
 669     const int devspec = 2;
 670     const int rootspec = 3;
 671     const int dirspec = 4;
 672     const int namespec = 5;
 673     const int typespec = 6;
 674     const int verspec = 7;
 675
 676     /* Assume the worst for an easy exit */
 677     ret_stat = -1;
 678     *volume = NULL;
 679     *vol_len = 0;
 680     *root = NULL;
 681     *root_len = 0;
 682     *dir = NULL;
 683     *name = NULL;
 684     *name_len = 0;
 685     *ext = NULL;
 686     *ext_len = 0;
 687     *version = NULL;
 688     *ver_len = 0;
 689
 690     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 691     path_desc.dsc$w_length = strlen(path);
 692     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 693     path_desc.dsc$b_class = DSC$K_CLASS_S;
 694
 695     /* Get the total length, if it is shorter than the string passed
 696      * then this was probably not a VMS formatted file specification
 697      */
 698     item_list[filespec].itmcode = FSCN$_FILESPEC;
 699     item_list[filespec].length = 0;
 700     item_list[filespec].component = NULL;
 701
 702     /* If the node is present, then it gets considered as part of the
 703      * volume name to hopefully make things simple.
 704      */
 705     item_list[nodespec].itmcode = FSCN$_NODE;
 706     item_list[nodespec].length = 0;
 707     item_list[nodespec].component = NULL;
 708
 709     item_list[devspec].itmcode = FSCN$_DEVICE;
 710     item_list[devspec].length = 0;
 711     item_list[devspec].component = NULL;
 712
 713     /* root is a special case,  adding it to either the directory or
 714      * the device components will probably complicate things for the
 715      * callers of this routine, so leave it separate.
 716      */
 717     item_list[rootspec].itmcode = FSCN$_ROOT;
 718     item_list[rootspec].length = 0;
 719     item_list[rootspec].component = NULL;
 720
 721     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 722     item_list[dirspec].length = 0;
 723     item_list[dirspec].component = NULL;
 724
 725     item_list[namespec].itmcode = FSCN$_NAME;
 726     item_list[namespec].length = 0;
 727     item_list[namespec].component = NULL;
 728
 729     item_list[typespec].itmcode = FSCN$_TYPE;
 730     item_list[typespec].length = 0;
 731     item_list[typespec].component = NULL;
 732
 733     item_list[verspec].itmcode = FSCN$_VERSION;
 734     item_list[verspec].length = 0;
 735     item_list[verspec].component = NULL;
 736
 737     item_list[8].itmcode = 0;
 738     item_list[8].length = 0;
 739     item_list[8].component = NULL;
 740
 741     status = sys$filescan
 742        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 743         &flags, NULL, NULL);
 744     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 745
 746     /* If we parsed it successfully these two lengths should be the same */
 747     if (path_desc.dsc$w_length != item_list[filespec].length)
 748         return ret_stat;
 749
 750     /* If we got here, then it is a VMS file specification */
 751     ret_stat = 0;
 752
 753     /* set the volume name */
 754     if (item_list[nodespec].length > 0) {
 755         *volume = item_list[nodespec].component;
 756         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 757     }
 758     else {
 759         *volume = item_list[devspec].component;
 760         *vol_len = item_list[devspec].length;
 761     }
 762
 763     *root = item_list[rootspec].component;
 764     *root_len = item_list[rootspec].length;
 765
 766     *dir = item_list[dirspec].component;
 767     *dir_len = item_list[dirspec].length;
 768
 769     /* Now fun with versions and EFS file specifications
 770      * The parser can not tell the difference when a "." is a version
 771      * delimiter or a part of the file specification.
 772      */
 773     if ((DECC_EFS_CHARSET) &&
 774         (item_list[verspec].length > 0) &&
 775         (item_list[verspec].component[0] == '.')) {
 776         *name = item_list[namespec].component;
 777         *name_len = item_list[namespec].length + item_list[typespec].length;
 778         *ext = item_list[verspec].component;
 779         *ext_len = item_list[verspec].length;
 780         *version = NULL;
 781         *ver_len = 0;
 782     }
 783     else {
 784         *name = item_list[namespec].component;
 785         *name_len = item_list[namespec].length;
 786         *ext = item_list[typespec].component;
 787         *ext_len = item_list[typespec].length;
 788         *version = item_list[verspec].component;
 789         *ver_len = item_list[verspec].length;
 790     }
 791     return ret_stat;
 792 }
 793
 794 /* Routine to determine if the file specification ends with .dir */
 795 static int
 796 is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len)
 797 {
 798
 799     /* e_len must be 4, and version must be <= 2 characters */
 800     if (e_len != 4 || vs_len > 2)
 801         return 0;
 802
 803     /* If a version number is present, it needs to be one */
 804     if ((vs_len == 2) && (vs_spec[1] != '1'))
 805         return 0;
 806
 807     /* Look for the DIR on the extension */
 808     if (vms_process_case_tolerant) {
 809         if ((toUPPER_A(e_spec[1]) == 'D') &&
 810             (toUPPER_A(e_spec[2]) == 'I') &&
 811             (toUPPER_A(e_spec[3]) == 'R')) {
 812             return 1;
 813         }
 814     } else {
 815         /* Directory extensions are supposed to be in upper case only */
 816         /* I would not be surprised if this rule can not be enforced */
 817         /* if and when someone fully debugs the case sensitive mode */
 818         if ((e_spec[1] == 'D') &&
 819             (e_spec[2] == 'I') &&
 820             (e_spec[3] == 'R')) {
 821             return 1;
 822         }
 823     }
 824     return 0;
 825 }
 826
 827
 828 /* my_maxidx
 829  * Routine to retrieve the maximum equivalence index for an input
 830  * logical name.  Some calls to this routine have no knowledge if
 831  * the variable is a logical or not.  So on error we return a max
 832  * index of zero.
 833  */
 834 /*{{{int my_maxidx(const char *lnm) */
 835 static int
 836 my_maxidx(const char *lnm)
 837 {
 838     int status;
 839     int midx;
 840     int attr = LNM$M_CASE_BLIND;
 841     struct dsc$descriptor lnmdsc;
 842     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 843                                 {0, 0, 0, 0}};
 844
 845     lnmdsc.dsc$w_length = strlen(lnm);
 846     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 847     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 848     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 849
 850     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 851     if ((status & 1) == 0)
 852        midx = 0;
 853
 854     return (midx);
 855 }
 856 /*}}}*/
 857
 858 /* Routine to remove the 2-byte prefix from the translation of a
 859  * process-permanent file (PPF).
 860  */
 861 static inline unsigned short int
 862 S_remove_ppf_prefix(const char *lnm, char *eqv, unsigned short int eqvlen)
 863 {
 864     if (*((int *)lnm) == *((int *)"SYS$")                    &&
 865         eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00      &&
 866         ( (lnm[4] == 'O' && strEQ(lnm,"SYS$OUTPUT"))  ||
 867           (lnm[4] == 'I' && strEQ(lnm,"SYS$INPUT"))   ||
 868           (lnm[4] == 'E' && strEQ(lnm,"SYS$ERROR"))   ||
 869           (lnm[4] == 'C' && strEQ(lnm,"SYS$COMMAND")) )  ) {
 870
 871         memmove(eqv, eqv+4, eqvlen-4);
 872         eqvlen -= 4;
 873     }
 874     return eqvlen;
 875 }
 876
 877 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 878 int
 879 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 880   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 881 {
 882     const char *cp1;
 883     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 884     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 885     bool found_in_crtlenv = 0, found_in_clisym = 0;
 886     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 887     int midx;
 888     unsigned char acmode;
 889     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 890                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 891     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 892                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 893                                  {0, 0, 0, 0}};
 894     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 895 #if defined(PERL_IMPLICIT_CONTEXT)
 896     pTHX = NULL;
 897     if (PL_curinterp) {
 898       aTHX = PERL_GET_INTERP;
 899     } else {
 900       aTHX = NULL;
 901     }
 902 #endif
 903
 904     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 905       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 906     }
 907     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 908       *cp2 = toUPPER_A(*cp1);
 909       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 910         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 911         return 0;
 912       }
 913     }
 914     lnmdsc.dsc$w_length = cp1 - lnm;
 915     lnmdsc.dsc$a_pointer = uplnm;
 916     uplnm[lnmdsc.dsc$w_length] = '\0';
 917     secure = flags & PERL__TRNENV_SECURE;
 918     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 919     if (!tabvec || !*tabvec) tabvec = env_tables;
 920
 921     for (curtab = 0; tabvec[curtab]; curtab++) {
 922       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 923         if (!ivenv && !secure) {
 924           char *eq;
 925           int i;
 926           if (!environ) {
 927             ivenv = 1;
 928 #if defined(PERL_IMPLICIT_CONTEXT)
 929             if (aTHX == NULL) {
 930                 fprintf(stderr,
 931                     "Can't read CRTL environ\n");
 932             } else
 933 #endif
 934                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 935             continue;
 936           }
 937           retsts = SS$_NOLOGNAM;
 938           for (i = 0; environ[i]; i++) {
 939             if ((eq = strchr(environ[i],'=')) &&
 940                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 941                 strnEQ(environ[i],lnm,eq - environ[i])) {
 942               eq++;
 943               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 944               if (!eqvlen) continue;
 945               retsts = SS$_NORMAL;
 946               break;
 947             }
 948           }
 949           if (retsts != SS$_NOLOGNAM) {
 950               found_in_crtlenv = 1;
 951               break;
 952           }
 953         }
 954       }
 955       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 956                !str$case_blind_compare(&tmpdsc,&clisym)) {
 957         if (!ivsym && !secure) {
 958           unsigned short int deflen = LNM$C_NAMLENGTH;
 959           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 960           /* dynamic dsc to accommodate possible long value */
 961           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 962           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 963           if (retsts & 1) {
 964             if (eqvlen > MAX_DCL_SYMBOL) {
 965               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 966               eqvlen = MAX_DCL_SYMBOL;
 967               /* Special hack--we might be called before the interpreter's */
 968               /* fully initialized, in which case either thr or PL_curcop */
 969               /* might be bogus. We have to check, since ckWARN needs them */
 970               /* both to be valid if running threaded */
 971 #if defined(PERL_IMPLICIT_CONTEXT)
 972               if (aTHX == NULL) {
 973                   fprintf(stderr,
 974                      "Value of CLI symbol \"%s\" too long",lnm);
 975               } else
 976 #endif
 977                 if (ckWARN(WARN_MISC)) {
 978                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 979                 }
 980             }
 981             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 982           }
 983           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
 984           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 985           if (retsts == LIB$_NOSUCHSYM) continue;
 986           found_in_clisym = 1;
 987           break;
 988         }
 989       }
 990       else if (!ivlnm) {
 991         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 992           midx = my_maxidx(lnm);
 993           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 994             lnmlst[1].bufadr = cp2;
 995             eqvlen = 0;
 996             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 997             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 998             if (retsts == SS$_NOLOGNAM) break;
 999             eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
1000             cp2 += eqvlen;
1001             *cp2 = '\0';
1002           }
1003           if ((retsts == SS$_IVLOGNAM) ||
1004               (retsts == SS$_NOLOGNAM)) { continue; }
1005           eqvlen = strlen(eqv);
1006         }
1007         else {
1008           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1009           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1010           if (retsts == SS$_NOLOGNAM) continue;
1011           eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
1012           eqv[eqvlen] = '\0';
1013         }
1014         break;
1015       }
1016     }
1017     /* An index only makes sense for logical names, so make sure we aren't
1018      * iterating over an index for an environ var or DCL symbol and getting
1019      * the same answer ad infinitum.
1020      */
1021     if (idx > 0 && (found_in_crtlenv || found_in_clisym)) {
1022         return 0;
1023     }
1024     else if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1025     else if (retsts == LIB$_NOSUCHSYM ||
1026              retsts == SS$_NOLOGNAM) {
1027      /* Unsuccessful lookup is normal -- no need to set errno */
1028      return 0;
1029     }
1030     else if (retsts == LIB$_INVSYMNAM ||
1031              retsts == SS$_IVLOGNAM   ||
1032              retsts == SS$_IVLOGTAB) {
1033       set_errno(EINVAL);  set_vaxc_errno(retsts);
1034     }
1035     else _ckvmssts_noperl(retsts);
1036     return 0;
1037 }  /* end of vmstrnenv */
1038 /*}}}*/
1039
1040 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1041 /* Define as a function so we can access statics. */
1042 int
1043 Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1044 {
1045     int flags = 0;
1046
1047 #if defined(PERL_IMPLICIT_CONTEXT)
1048     if (aTHX != NULL)
1049 #endif
1050 #ifdef SECURE_INTERNAL_GETENV
1051         flags = (PL_curinterp ? TAINTING_get : will_taint) ?
1052                  PERL__TRNENV_SECURE : 0;
1053 #endif
1054
1055     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1056 }
1057 /*}}}*/
1058
1059 /* my_getenv
1060  * Note: Uses Perl temp to store result so char * can be returned to
1061  * caller; this pointer will be invalidated at next Perl statement
1062  * transition.
1063  * We define this as a function rather than a macro in terms of my_getenv_len()
1064  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1065  * allocate SVs).
1066  */
1067 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1068 char *
1069 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1070 {
1071     const char *cp1;
1072     static char *__my_getenv_eqv = NULL;
1073     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1074     unsigned long int idx = 0;
1075     int success, secure;
1076     int midx, flags;
1077     SV *tmpsv;
1078
1079     midx = my_maxidx(lnm) + 1;
1080
1081     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1082       /* Set up a temporary buffer for the return value; Perl will
1083        * clean it up at the next statement transition */
1084       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1085       if (!tmpsv) return NULL;
1086       eqv = SvPVX(tmpsv);
1087     }
1088     else {
1089       /* Assume no interpreter ==> single thread */
1090       if (__my_getenv_eqv != NULL) {
1091         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1092       }
1093       else {
1094         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1095       }
1096       eqv = __my_getenv_eqv;
1097     }
1098
1099     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = toUPPER_A(*cp1);
1100     if (memEQs(eqv, cp1 - lnm, "DEFAULT")) {
1101       int len;
1102       getcwd(eqv,LNM$C_NAMLENGTH);
1103
1104       len = strlen(eqv);
1105
1106       /* Get rid of "000000/ in rooted filespecs */
1107       if (len > 7) {
1108         char * zeros;
1109         zeros = strstr(eqv, "/000000/");
1110         if (zeros != NULL) {
1111           int mlen;
1112           mlen = len - (zeros - eqv) - 7;
1113           memmove(zeros, &zeros[7], mlen);
1114           len = len - 7;
1115           eqv[len] = '\0';
1116         }
1117       }
1118       return eqv;
1119     }
1120     else {
1121       /* Impose security constraints only if tainting */
1122       if (sys) {
1123         /* Impose security constraints only if tainting */
1124         secure = PL_curinterp ? TAINTING_get : will_taint;
1125       }
1126       else {
1127         secure = 0;
1128       }
1129
1130       flags =
1131 #ifdef SECURE_INTERNAL_GETENV
1132               secure ? PERL__TRNENV_SECURE : 0
1133 #else
1134               0
1135 #endif
1136       ;
1137
1138       /* For the getenv interface we combine all the equivalence names
1139        * of a search list logical into one value to acquire a maximum
1140        * value length of 255*128 (assuming %ENV is using logicals).
1141        */
1142       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1143
1144       /* If the name contains a semicolon-delimited index, parse it
1145        * off and make sure we only retrieve the equivalence name for
1146        * that index.  */
1147       if ((cp2 = strchr(lnm,';')) != NULL) {
1148         my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
1149         idx = strtoul(cp2+1,NULL,0);
1150         lnm = uplnm;
1151         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1152       }
1153
1154       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1155
1156       return success ? eqv : NULL;
1157     }
1158
1159 }  /* end of my_getenv() */
1160 /*}}}*/
1161
1162
1163 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1164 char *
1165 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1166 {
1167     const char *cp1;
1168     char *buf, *cp2;
1169     unsigned long idx = 0;
1170     int midx, flags;
1171     static char *__my_getenv_len_eqv = NULL;
1172     int secure;
1173     SV *tmpsv;
1174
1175     midx = my_maxidx(lnm) + 1;
1176
1177     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1178       /* Set up a temporary buffer for the return value; Perl will
1179        * clean it up at the next statement transition */
1180       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1181       if (!tmpsv) return NULL;
1182       buf = SvPVX(tmpsv);
1183     }
1184     else {
1185       /* Assume no interpreter ==> single thread */
1186       if (__my_getenv_len_eqv != NULL) {
1187         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1188       }
1189       else {
1190         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1191       }
1192       buf = __my_getenv_len_eqv;
1193     }
1194
1195     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = toUPPER_A(*cp1);
1196     if (memEQs(buf, cp1 - lnm, "DEFAULT")) {
1197     char * zeros;
1198
1199       getcwd(buf,LNM$C_NAMLENGTH);
1200       *len = strlen(buf);
1201
1202       /* Get rid of "000000/ in rooted filespecs */
1203       if (*len > 7) {
1204       zeros = strstr(buf, "/000000/");
1205       if (zeros != NULL) {
1206         int mlen;
1207         mlen = *len - (zeros - buf) - 7;
1208         memmove(zeros, &zeros[7], mlen);
1209         *len = *len - 7;
1210         buf[*len] = '\0';
1211         }
1212       }
1213       return buf;
1214     }
1215     else {
1216       if (sys) {
1217         /* Impose security constraints only if tainting */
1218         secure = PL_curinterp ? TAINTING_get : will_taint;
1219       }
1220       else {
1221         secure = 0;
1222       }
1223
1224       flags =
1225 #ifdef SECURE_INTERNAL_GETENV
1226               secure ? PERL__TRNENV_SECURE : 0
1227 #else
1228               0
1229 #endif
1230       ;
1231
1232       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1233
1234       if ((cp2 = strchr(lnm,';')) != NULL) {
1235         my_strlcpy(buf, lnm, cp2 - lnm + 1);
1236         idx = strtoul(cp2+1,NULL,0);
1237         lnm = buf;
1238         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1239       }
1240
1241       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1242
1243       /* Get rid of "000000/ in rooted filespecs */
1244       if (*len > 7) {
1245         char * zeros;
1246         zeros = strstr(buf, "/000000/");
1247         if (zeros != NULL) {
1248           int mlen;
1249           mlen = *len - (zeros - buf) - 7;
1250           memmove(zeros, &zeros[7], mlen);
1251           *len = *len - 7;
1252           buf[*len] = '\0';
1253         }
1254       }
1255
1256       return *len ? buf : NULL;
1257     }
1258
1259 }  /* end of my_getenv_len() */
1260 /*}}}*/
1261
1262 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1263
1264 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1265
1266 /*{{{ void prime_env_iter() */
1267 void
1268 prime_env_iter(void)
1269 /* Fill the %ENV associative array with all logical names we can
1270  * find, in preparation for iterating over it.
1271  */
1272 {
1273   static int primed = 0;
1274   HV *seenhv = NULL, *envhv;
1275   SV *sv = NULL;
1276   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1277   unsigned short int chan;
1278 #ifndef CLI$M_TRUSTED
1279 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1280 #endif
1281   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1282   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1283   long int i;
1284   bool have_sym = FALSE, have_lnm = FALSE;
1285   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1286   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1287   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1288   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1289   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1290 #if defined(PERL_IMPLICIT_CONTEXT)
1291   pTHX;
1292 #endif
1293 #if defined(USE_ITHREADS)
1294   static perl_mutex primenv_mutex;
1295   MUTEX_INIT(&primenv_mutex);
1296 #endif
1297
1298 #if defined(PERL_IMPLICIT_CONTEXT)
1299     /* We jump through these hoops because we can be called at */
1300     /* platform-specific initialization time, which is before anything is */
1301     /* set up--we can't even do a plain dTHX since that relies on the */
1302     /* interpreter structure to be initialized */
1303     if (PL_curinterp) {
1304       aTHX = PERL_GET_INTERP;
1305     } else {
1306       /* we never get here because the NULL pointer will cause the */
1307       /* several of the routines called by this routine to access violate */
1308
1309       /* This routine is only called by hv.c/hv_iterinit which has a */
1310       /* context, so the real fix may be to pass it through instead of */
1311       /* the hoops above */
1312       aTHX = NULL;
1313     }
1314 #endif
1315
1316   if (primed || !PL_envgv) return;
1317   MUTEX_LOCK(&primenv_mutex);
1318   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1319   envhv = GvHVn(PL_envgv);
1320   /* Perform a dummy fetch as an lval to insure that the hash table is
1321    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1322   (void) hv_fetchs(envhv,"DEFAULT",TRUE);
1323
1324   for (i = 0; env_tables[i]; i++) {
1325      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1326          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1327      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1328   }
1329   if (have_sym || have_lnm) {
1330     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1331     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1332     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1333     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1334   }
1335
1336   for (i--; i >= 0; i--) {
1337     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1338       char *start;
1339       int j;
1340       /* Start at the end, so if there is a duplicate we keep the first one. */
1341       for (j = 0; environ[j]; j++);
1342       for (j--; j >= 0; j--) {
1343         if (!(start = strchr(environ[j],'='))) {
1344           if (ckWARN(WARN_INTERNAL))
1345             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1346         }
1347         else {
1348           start++;
1349           sv = newSVpv(start,0);
1350           SvTAINTED_on(sv);
1351           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1352         }
1353       }
1354       continue;
1355     }
1356     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1357              !str$case_blind_compare(&tmpdsc,&clisym)) {
1358       my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
1359       cmddsc.dsc$w_length = 20;
1360       if (env_tables[i]->dsc$w_length == 12 &&
1361           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1362           !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local  *", sizeof(cmd)-12);
1363       flags = defflags | CLI$M_NOLOGNAM;
1364     }
1365     else {
1366       my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
1367       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1368         my_strlcat(cmd," /Table=", sizeof(cmd));
1369         cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, sizeof(cmd));
1370       }
1371       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1372       flags = defflags | CLI$M_NOCLISYM;
1373     }
1374
1375     /* Create a new subprocess to execute each command, to exclude the
1376      * remote possibility that someone could subvert a mbx or file used
1377      * to write multiple commands to a single subprocess.
1378      */
1379     do {
1380       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1381                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1382       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1383       defflags &= ~CLI$M_TRUSTED;
1384     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1385     _ckvmssts(retsts);
1386     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1387     if (seenhv) SvREFCNT_dec(seenhv);
1388     seenhv = newHV();
1389     while (1) {
1390       char *cp1, *cp2, *key;
1391       unsigned long int sts, iosb[2], retlen, keylen;
1392       U32 hash;
1393
1394       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1395       if (sts & 1) sts = iosb[0] & 0xffff;
1396       if (sts == SS$_ENDOFFILE) {
1397         int wakect = 0;
1398         while (substs == 0) { sys$hiber(); wakect++;}
1399         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1400         _ckvmssts(substs);
1401         break;
1402       }
1403       _ckvmssts(sts);
1404       retlen = iosb[0] >> 16;
1405       if (!retlen) continue;  /* blank line */
1406       buf[retlen] = '\0';
1407       if (iosb[1] != subpid) {
1408         if (iosb[1]) {
1409           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1410         }
1411         continue;
1412       }
1413       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1414         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1415
1416       for (cp1 = buf; *cp1 && isSPACE_L1(*cp1); cp1++) ;
1417       if (*cp1 == '(' || /* Logical name table name */
1418           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1419       if (*cp1 == '"') cp1++;
1420       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1421       key = cp1;  keylen = cp2 - cp1;
1422       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1423       while (*cp2 && *cp2 != '=') cp2++;
1424       while (*cp2 && *cp2 == '=') cp2++;
1425       while (*cp2 && *cp2 == ' ') cp2++;
1426       if (*cp2 == '"') {  /* String translation; may embed "" */
1427         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1428         cp2++;  cp1--; /* Skip "" surrounding translation */
1429       }
1430       else {  /* Numeric translation */
1431         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1432         cp1--;  /* stop on last non-space char */
1433       }
1434       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1435         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1436         continue;
1437       }
1438       PERL_HASH(hash,key,keylen);
1439
1440       if (cp1 == cp2 && *cp2 == '.') {
1441         /* A single dot usually means an unprintable character, such as a null
1442          * to indicate a zero-length value.  Get the actual value to make sure.
1443          */
1444         char lnm[LNM$C_NAMLENGTH+1];
1445         char eqv[MAX_DCL_SYMBOL+1];
1446         int trnlen;
1447         strncpy(lnm, key, keylen);
1448         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1449         sv = newSVpvn(eqv, strlen(eqv));
1450       }
1451       else {
1452         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1453       }
1454
1455       SvTAINTED_on(sv);
1456       hv_store(envhv,key,keylen,sv,hash);
1457       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1458     }
1459     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1460       /* get the PPFs for this process, not the subprocess */
1461       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1462       char eqv[LNM$C_NAMLENGTH+1];
1463       int trnlen, i;
1464       for (i = 0; ppfs[i]; i++) {
1465         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1466         sv = newSVpv(eqv,trnlen);
1467         SvTAINTED_on(sv);
1468         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1469       }
1470     }
1471   }
1472   primed = 1;
1473   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1474   if (buf) Safefree(buf);
1475   if (seenhv) SvREFCNT_dec(seenhv);
1476   MUTEX_UNLOCK(&primenv_mutex);
1477   return;
1478
1479 }  /* end of prime_env_iter */
1480 /*}}}*/
1481
1482
1483 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1484 /* Define or delete an element in the same "environment" as
1485  * vmstrnenv().  If an element is to be deleted, it's removed from
1486  * the first place it's found.  If it's to be set, it's set in the
1487  * place designated by the first element of the table vector.
1488  * Like setenv() returns 0 for success, non-zero on error.
1489  */
1490 int
1491 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1492 {
1493     const char *cp1;
1494     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1495     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1496     int nseg = 0, j;
1497     unsigned long int retsts, usermode = PSL$C_USER;
1498     struct itmlst_3 *ile, *ilist;
1499     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1500                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1501                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1502     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1503     $DESCRIPTOR(local,"_LOCAL");
1504
1505     if (!lnm) {
1506         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1507         return SS$_IVLOGNAM;
1508     }
1509
1510     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1511       *cp2 = toUPPER_A(*cp1);
1512       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1513         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1514         return SS$_IVLOGNAM;
1515       }
1516     }
1517     lnmdsc.dsc$w_length = cp1 - lnm;
1518     if (!tabvec || !*tabvec) tabvec = env_tables;
1519
1520     if (!eqv) {  /* we're deleting n element */
1521       for (curtab = 0; tabvec[curtab]; curtab++) {
1522         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1523         int i;
1524           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1525             if ((cp1 = strchr(environ[i],'=')) &&
1526                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1527                 strnEQ(environ[i],lnm,cp1 - environ[i])) {
1528               unsetenv(lnm);
1529               return 0;
1530             }
1531           }
1532           ivenv = 1; retsts = SS$_NOLOGNAM;
1533         }
1534         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1535                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1536           unsigned int symtype;
1537           if (tabvec[curtab]->dsc$w_length == 12 &&
1538               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1539               !str$case_blind_compare(&tmpdsc,&local))
1540             symtype = LIB$K_CLI_LOCAL_SYM;
1541           else symtype = LIB$K_CLI_GLOBAL_SYM;
1542           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1543           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1544           if (retsts == LIB$_NOSUCHSYM) continue;
1545           break;
1546         }
1547         else if (!ivlnm) {
1548           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1549           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1550           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1551           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1552           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1553         }
1554       }
1555     }
1556     else {  /* we're defining a value */
1557       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1558         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1559       }
1560       else {
1561         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1562         eqvdsc.dsc$w_length  = strlen(eqv);
1563         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1564             !str$case_blind_compare(&tmpdsc,&clisym)) {
1565           unsigned int symtype;
1566           if (tabvec[0]->dsc$w_length == 12 &&
1567               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1568                !str$case_blind_compare(&tmpdsc,&local))
1569             symtype = LIB$K_CLI_LOCAL_SYM;
1570           else symtype = LIB$K_CLI_GLOBAL_SYM;
1571           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1572         }
1573         else {
1574           if (!*eqv) eqvdsc.dsc$w_length = 1;
1575           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1576
1577             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1578             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1579               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1580                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1581               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1582               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1583             }
1584
1585             Newx(ilist,nseg+1,struct itmlst_3);
1586             ile = ilist;
1587             if (!ile) {
1588               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1589               return SS$_INSFMEM;
1590             }
1591             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1592
1593             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1594               ile->itmcode = LNM$_STRING;
1595               ile->bufadr = c;
1596               if ((j+1) == nseg) {
1597                 ile->buflen = strlen(c);
1598                 /* in case we are truncating one that's too long */
1599                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1600               }
1601               else {
1602                 ile->buflen = LNM$C_NAMLENGTH;
1603               }
1604             }
1605
1606             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1607             Safefree (ilist);
1608           }
1609           else {
1610             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1611           }
1612         }
1613       }
1614     }
1615     if (!(retsts & 1)) {
1616       switch (retsts) {
1617         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1618         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1619           set_errno(EVMSERR); break;
1620         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1621         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1622           set_errno(EINVAL); break;
1623         case SS$_NOPRIV:
1624           set_errno(EACCES); break;
1625         default:
1626           _ckvmssts(retsts);
1627           set_errno(EVMSERR);
1628        }
1629        set_vaxc_errno(retsts);
1630        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1631     }
1632     else {
1633       /* We reset error values on success because Perl does an hv_fetch()
1634        * before each hv_store(), and if the thing we're setting didn't
1635        * previously exist, we've got a leftover error message.  (Of course,
1636        * this fails in the face of
1637        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1638        * in that the error reported in $! isn't spurious,
1639        * but it's right more often than not.)
1640        */
1641       set_errno(0); set_vaxc_errno(retsts);
1642       return 0;
1643     }
1644
1645 }  /* end of vmssetenv() */
1646 /*}}}*/
1647
1648 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1649 /* This has to be a function since there's a prototype for it in proto.h */
1650 void
1651 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1652 {
1653     if (lnm && *lnm) {
1654       int len = strlen(lnm);
1655       if  (len == 7) {
1656         char uplnm[8];
1657         int i;
1658         for (i = 0; lnm[i]; i++) uplnm[i] = toUPPER_A(lnm[i]);
1659         if (strEQ(uplnm,"DEFAULT")) {
1660           if (eqv && *eqv) my_chdir(eqv);
1661           return;
1662         }
1663     }
1664   }
1665   (void) vmssetenv(lnm,eqv,NULL);
1666 }
1667 /*}}}*/
1668
1669 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1670 /*  vmssetuserlnm
1671  *  sets a user-mode logical in the process logical name table
1672  *  used for redirection of sys$error
1673  */
1674 void
1675 Perl_vmssetuserlnm(const char *name, const char *eqv)
1676 {
1677     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1678     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1679     unsigned long int iss, attr = LNM$M_CONFINE;
1680     unsigned char acmode = PSL$C_USER;
1681     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1682                                  {0, 0, 0, 0}};
1683     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1684     d_name.dsc$w_length = strlen(name);
1685
1686     lnmlst[0].buflen = strlen(eqv);
1687     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1688
1689     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1690     if (!(iss&1)) lib$signal(iss);
1691 }
1692 /*}}}*/
1693
1694
1695 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1696 /* my_crypt - VMS password hashing
1697  * my_crypt() provides an interface compatible with the Unix crypt()
1698  * C library function, and uses sys$hash_password() to perform VMS
1699  * password hashing.  The quadword hashed password value is returned
1700  * as a NUL-terminated 8 character string.  my_crypt() does not change
1701  * the case of its string arguments; in order to match the behavior
1702  * of LOGINOUT et al., alphabetic characters in both arguments must
1703  *  be upcased by the caller.
1704  *
1705  * - fix me to call ACM services when available
1706  */
1707 char *
1708 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1709 {
1710 #   ifndef UAI$C_PREFERRED_ALGORITHM
1711 #     define UAI$C_PREFERRED_ALGORITHM 127
1712 #   endif
1713     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1714     unsigned short int salt = 0;
1715     unsigned long int sts;
1716     struct const_dsc {
1717         unsigned short int dsc$w_length;
1718         unsigned char      dsc$b_type;
1719         unsigned char      dsc$b_class;
1720         const char *       dsc$a_pointer;
1721     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1722        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1723     struct itmlst_3 uailst[3] = {
1724         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1725         { sizeof salt, UAI$_SALT,    &salt, 0},
1726         { 0,           0,            NULL,  NULL}};
1727     static char hash[9];
1728
1729     usrdsc.dsc$w_length = strlen(usrname);
1730     usrdsc.dsc$a_pointer = usrname;
1731     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1732       switch (sts) {
1733         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1734           set_errno(EACCES);
1735           break;
1736         case RMS$_RNF:
1737           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1738           break;
1739         default:
1740           set_errno(EVMSERR);
1741       }
1742       set_vaxc_errno(sts);
1743       if (sts != RMS$_RNF) return NULL;
1744     }
1745
1746     txtdsc.dsc$w_length = strlen(textpasswd);
1747     txtdsc.dsc$a_pointer = textpasswd;
1748     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1749       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1750     }
1751
1752     return (char *) hash;
1753
1754 }  /* end of my_crypt() */
1755 /*}}}*/
1756
1757
1758 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1759 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1760 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1761
1762 /* 8.3, remove() is now broken on symbolic links */
1763 static int rms_erase(const char * vmsname);
1764
1765
1766 /* mp_do_kill_file
1767  * A little hack to get around a bug in some implementation of remove()
1768  * that do not know how to delete a directory
1769  *
1770  * Delete any file to which user has control access, regardless of whether
1771  * delete access is explicitly allowed.
1772  * Limitations: User must have write access to parent directory.
1773  *              Does not block signals or ASTs; if interrupted in midstream
1774  *              may leave file with an altered ACL.
1775  * HANDLE WITH CARE!
1776  */
1777 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1778 static int
1779 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1780 {
1781     char *vmsname;
1782     char *rslt;
1783     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1784     unsigned long int cxt = 0, aclsts, fndsts;
1785     int rmsts = -1;
1786     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1787     struct myacedef {
1788       unsigned char myace$b_length;
1789       unsigned char myace$b_type;
1790       unsigned short int myace$w_flags;
1791       unsigned long int myace$l_access;
1792       unsigned long int myace$l_ident;
1793     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1794                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1795       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1796      struct itmlst_3
1797        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1798                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1799        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1800        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1801        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1802        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1803
1804     /* Expand the input spec using RMS, since the CRTL remove() and
1805      * system services won't do this by themselves, so we may miss
1806      * a file "hiding" behind a logical name or search list. */
1807     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
1808     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1809
1810     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1811     if (rslt == NULL) {
1812         PerlMem_free(vmsname);
1813         return -1;
1814       }
1815
1816     /* Erase the file */
1817     rmsts = rms_erase(vmsname);
1818
1819     /* Did it succeed */
1820     if ($VMS_STATUS_SUCCESS(rmsts)) {
1821         PerlMem_free(vmsname);
1822         return 0;
1823       }
1824
1825     /* If not, can changing protections help? */
1826     if (rmsts != RMS$_PRV) {
1827       set_vaxc_errno(rmsts);
1828       PerlMem_free(vmsname);
1829       return -1;
1830     }
1831
1832     /* No, so we get our own UIC to use as a rights identifier,
1833      * and the insert an ACE at the head of the ACL which allows us
1834      * to delete the file.
1835      */
1836     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1837     fildsc.dsc$w_length = strlen(vmsname);
1838     fildsc.dsc$a_pointer = vmsname;
1839     cxt = 0;
1840     newace.myace$l_ident = oldace.myace$l_ident;
1841     rmsts = -1;
1842     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1843       switch (aclsts) {
1844         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1845           set_errno(ENOENT); break;
1846         case RMS$_DIR:
1847           set_errno(ENOTDIR); break;
1848         case RMS$_DEV:
1849           set_errno(ENODEV); break;
1850         case RMS$_SYN: case SS$_INVFILFOROP:
1851           set_errno(EINVAL); break;
1852         case RMS$_PRV:
1853           set_errno(EACCES); break;
1854         default:
1855           _ckvmssts_noperl(aclsts);
1856       }
1857       set_vaxc_errno(aclsts);
1858       PerlMem_free(vmsname);
1859       return -1;
1860     }
1861     /* Grab any existing ACEs with this identifier in case we fail */
1862     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1863     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1864                     || fndsts == SS$_NOMOREACE ) {
1865       /* Add the new ACE . . . */
1866       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1867         goto yourroom;
1868
1869       rmsts = rms_erase(vmsname);
1870       if ($VMS_STATUS_SUCCESS(rmsts)) {
1871         rmsts = 0;
1872         }
1873         else {
1874         rmsts = -1;
1875         /* We blew it - dir with files in it, no write priv for
1876          * parent directory, etc.  Put things back the way they were. */
1877         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1878           goto yourroom;
1879         if (fndsts & 1) {
1880           addlst[0].bufadr = &oldace;
1881           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1882             goto yourroom;
1883         }
1884       }
1885     }
1886
1887     yourroom:
1888     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1889     /* We just deleted it, so of course it's not there.  Some versions of
1890      * VMS seem to return success on the unlock operation anyhow (after all
1891      * the unlock is successful), but others don't.
1892      */
1893     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1894     if (aclsts & 1) aclsts = fndsts;
1895     if (!(aclsts & 1)) {
1896       set_errno(EVMSERR);
1897       set_vaxc_errno(aclsts);
1898     }
1899
1900     PerlMem_free(vmsname);
1901     return rmsts;
1902
1903 }  /* end of kill_file() */
1904 /*}}}*/
1905
1906
1907 /*{{{int do_rmdir(char *name)*/
1908 int
1909 Perl_do_rmdir(pTHX_ const char *name)
1910 {
1911     char * dirfile;
1912     int retval;
1913     Stat_t st;
1914
1915     /* lstat returns a VMS fileified specification of the name */
1916     /* that is looked up, and also lets verifies that this is a directory */
1917
1918     retval = flex_lstat(name, &st);
1919     if (retval != 0) {
1920         char * ret_spec;
1921
1922         /* Due to a historical feature, flex_stat/lstat can not see some */
1923         /* Unix format file names that the rest of the CRTL can see */
1924         /* Fixing that feature will cause some perl tests to fail */
1925         /* So try this one more time. */
1926
1927         retval = lstat(name, &st.crtl_stat);
1928         if (retval != 0)
1929             return -1;
1930
1931         /* force it to a file spec for the kill file to work. */
1932         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1933         if (ret_spec == NULL) {
1934             errno = EIO;
1935             return -1;
1936         }
1937     }
1938
1939     if (!S_ISDIR(st.st_mode)) {
1940         errno = ENOTDIR;
1941         retval = -1;
1942     }
1943     else {
1944         dirfile = st.st_devnam;
1945
1946         /* It may be possible for flex_stat to find a file and vmsify() to */
1947         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
1948         /* with that case, so fail it */
1949         if (dirfile[0] == 0) {
1950             errno = EIO;
1951             return -1;
1952         }
1953
1954         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1955     }
1956
1957     return retval;
1958
1959 }  /* end of do_rmdir */
1960 /*}}}*/
1961
1962 /* kill_file
1963  * Delete any file to which user has control access, regardless of whether
1964  * delete access is explicitly allowed.
1965  * Limitations: User must have write access to parent directory.
1966  *              Does not block signals or ASTs; if interrupted in midstream
1967  *              may leave file with an altered ACL.
1968  * HANDLE WITH CARE!
1969  */
1970 /*{{{int kill_file(char *name)*/
1971 int
1972 Perl_kill_file(pTHX_ const char *name)
1973 {
1974     char * vmsfile;
1975     Stat_t st;
1976     int rmsts;
1977
1978     /* Convert the filename to VMS format and see if it is a directory */
1979     /* flex_lstat returns a vmsified file specification */
1980     rmsts = flex_lstat(name, &st);
1981     if (rmsts != 0) {
1982
1983         /* Due to a historical feature, flex_stat/lstat can not see some */
1984         /* Unix format file names that the rest of the CRTL can see when */
1985         /* ODS-2 file specifications are in use. */
1986         /* Fixing that feature will cause some perl tests to fail */
1987         /* [.lib.ExtUtils.t]Manifest.t is one of them */
1988         st.st_mode = 0;
1989         vmsfile = (char *) name; /* cast ok */
1990
1991     } else {
1992         vmsfile = st.st_devnam;
1993         if (vmsfile[0] == 0) {
1994             /* It may be possible for flex_stat to find a file and vmsify() */
1995             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
1996             /* deal with that case, so fail it */
1997             errno = EIO;
1998             return -1;
1999         }
2000     }
2001
2002     /* Remove() is allowed to delete directories, according to the X/Open
2003      * specifications.
2004      * This may need special handling to work with the ACL hacks.
2005      */
2006     if (S_ISDIR(st.st_mode)) {
2007         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2008         return rmsts;
2009     }
2010
2011     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2012
2013     /* Need to delete all versions ? */
2014     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2015         int i = 0;
2016
2017         /* Just use lstat() here as do not need st_dev */
2018         /* and we know that the file is in VMS format or that */
2019         /* because of a historical bug, flex_stat can not see the file */
2020         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2021             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2022             if (rmsts != 0)
2023                 break;
2024             i++;
2025
2026             /* Make sure that we do not loop forever */
2027             if (i > 32767) {
2028                 errno = EIO;
2029                 rmsts = -1;
2030                 break;
2031             }
2032         }
2033     }
2034
2035     return rmsts;
2036
2037 }  /* end of kill_file() */
2038 /*}}}*/
2039
2040
2041 /*{{{int my_mkdir(char *,Mode_t)*/
2042 int
2043 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2044 {
2045   STRLEN dirlen = strlen(dir);
2046
2047   /* zero length string sometimes gives ACCVIO */
2048   if (dirlen == 0) return -1;
2049
2050   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2051    * null file name/type.  However, it's commonplace under Unix,
2052    * so we'll allow it for a gain in portability.
2053    */
2054   if (dir[dirlen-1] == '/') {
2055     char *newdir = savepvn(dir,dirlen-1);
2056     int ret = mkdir(newdir,mode);
2057     Safefree(newdir);
2058     return ret;
2059   }
2060   else return mkdir(dir,mode);
2061 }  /* end of my_mkdir */
2062 /*}}}*/
2063
2064 /*{{{int my_chdir(char *)*/
2065 int
2066 Perl_my_chdir(pTHX_ const char *dir)
2067 {
2068   STRLEN dirlen = strlen(dir);
2069   const char *dir1 = dir;
2070
2071   /* POSIX says we should set ENOENT for zero length string. */
2072   if (dirlen == 0) {
2073     SETERRNO(ENOENT, RMS$_DNF);
2074     return -1;
2075   }
2076
2077   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2078    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2079    * so that existing scripts do not need to be changed.
2080    */
2081   while ((dirlen > 0) && (*dir1 == ' ')) {
2082     dir1++;
2083     dirlen--;
2084   }
2085
2086   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2087    * that implies
2088    * null file name/type.  However, it's commonplace under Unix,
2089    * so we'll allow it for a gain in portability.
2090    *
2091    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2092    */
2093   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2094       char *newdir;
2095       int ret;
2096       newdir = (char *)PerlMem_malloc(dirlen);
2097       if (newdir ==NULL)
2098           _ckvmssts_noperl(SS$_INSFMEM);
2099       memcpy(newdir, dir1, dirlen-1);
2100       newdir[dirlen-1] = '\0';
2101       ret = chdir(newdir);
2102       PerlMem_free(newdir);
2103       return ret;
2104   }
2105   else return chdir(dir1);
2106 }  /* end of my_chdir */
2107 /*}}}*/
2108
2109
2110 /*{{{int my_chmod(char *, mode_t)*/
2111 int
2112 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2113 {
2114   Stat_t st;
2115   int ret = -1;
2116   char * changefile;
2117   STRLEN speclen = strlen(file_spec);
2118
2119   /* zero length string sometimes gives ACCVIO */
2120   if (speclen == 0) return -1;
2121
2122   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2123    * that implies null file name/type.  However, it's commonplace under Unix,
2124    * so we'll allow it for a gain in portability.
2125    *
2126    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2127    * in VMS file.dir notation.
2128    */
2129   changefile = (char *) file_spec; /* cast ok */
2130   ret = flex_lstat(file_spec, &st);
2131   if (ret != 0) {
2132
2133         /* Due to a historical feature, flex_stat/lstat can not see some */
2134         /* Unix format file names that the rest of the CRTL can see when */
2135         /* ODS-2 file specifications are in use. */
2136         /* Fixing that feature will cause some perl tests to fail */
2137         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2138         st.st_mode = 0;
2139
2140   } else {
2141       /* It may be possible to get here with nothing in st_devname */
2142       /* chmod still may work though */
2143       if (st.st_devnam[0] != 0) {
2144           changefile = st.st_devnam;
2145       }
2146   }
2147   ret = chmod(changefile, mode);
2148   return ret;
2149 }  /* end of my_chmod */
2150 /*}}}*/
2151
2152
2153 /*{{{FILE *my_tmpfile()*/
2154 FILE *
2155 my_tmpfile(void)
2156 {
2157   FILE *fp;
2158   char *cp;
2159
2160   if ((fp = tmpfile())) return fp;
2161
2162   cp = (char *)PerlMem_malloc(L_tmpnam+24);
2163   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2164
2165   if (DECC_FILENAME_UNIX_ONLY == 0)
2166     strcpy(cp,"Sys$Scratch:");
2167   else
2168     strcpy(cp,"/tmp/");
2169   tmpnam(cp+strlen(cp));
2170   strcat(cp,".Perltmp");
2171   fp = fopen(cp,"w+","fop=dlt");
2172   PerlMem_free(cp);
2173   return fp;
2174 }
2175 /*}}}*/
2176
2177
2178 /*
2179  * The C RTL's sigaction fails to check for invalid signal numbers so we
2180  * help it out a bit.  The docs are correct, but the actual routine doesn't
2181  * do what the docs say it will.
2182  */
2183 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2184 int
2185 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2186                    struct sigaction* oact)
2187 {
2188   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2189         SETERRNO(EINVAL, SS$_INVARG);
2190         return -1;
2191   }
2192   return sigaction(sig, act, oact);
2193 }
2194 /*}}}*/
2195
2196 #include <errnodef.h>
2197
2198 /* We implement our own kill() using the undocumented system service
2199    sys$sigprc for one of two reasons:
2200
2201    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2202    target process to do a sys$exit, which usually can't be handled
2203    gracefully...certainly not by Perl and the %SIG{} mechanism.
2204
2205    2.) If the kill() in the CRTL can't be called from a signal
2206    handler without disappearing into the ether, i.e., the signal
2207    it purportedly sends is never trapped. Still true as of VMS 7.3.
2208
2209    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2210    in the target process rather than calling sys$exit.
2211
2212    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2213    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2214    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2215    with condition codes C$_SIG0+nsig*8, catching the exception on the
2216    target process and resignaling with appropriate arguments.
2217
2218    But we don't have that VMS 7.0+ exception handler, so if you
2219    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2220
2221    Also note that SIGTERM is listed in the docs as being "unimplemented",
2222    yet always seems to be signaled with a VMS condition code of 4 (and
2223    correctly handled for that code).  So we hardwire it in.
2224
2225    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2226    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2227    than signalling with an unrecognized (and unhandled by CRTL) code.
2228 */
2229
2230 #define _MY_SIG_MAX 28
2231
2232 static unsigned int
2233 Perl_sig_to_vmscondition_int(int sig)
2234 {
2235     static unsigned int sig_code[_MY_SIG_MAX+1] =
2236     {
2237         0,                  /*  0 ZERO     */
2238         SS$_HANGUP,         /*  1 SIGHUP   */
2239         SS$_CONTROLC,       /*  2 SIGINT   */
2240         SS$_CONTROLY,       /*  3 SIGQUIT  */
2241         SS$_RADRMOD,        /*  4 SIGILL   */
2242         SS$_BREAK,          /*  5 SIGTRAP  */
2243         SS$_OPCCUS,         /*  6 SIGABRT  */
2244         SS$_COMPAT,         /*  7 SIGEMT   */
2245         SS$_HPARITH,        /*  8 SIGFPE AXP */
2246         SS$_ABORT,          /*  9 SIGKILL  */
2247         SS$_ACCVIO,         /* 10 SIGBUS   */
2248         SS$_ACCVIO,         /* 11 SIGSEGV  */
2249         SS$_BADPARAM,       /* 12 SIGSYS   */
2250         SS$_NOMBX,          /* 13 SIGPIPE  */
2251         SS$_ASTFLT,         /* 14 SIGALRM  */
2252         4,                  /* 15 SIGTERM  */
2253         0,                  /* 16 SIGUSR1  */
2254         0,                  /* 17 SIGUSR2  */
2255         0,                  /* 18 */
2256         0,                  /* 19 */
2257         0,                  /* 20 SIGCHLD  */
2258         0,                  /* 21 SIGCONT  */
2259         0,                  /* 22 SIGSTOP  */
2260         0,                  /* 23 SIGTSTP  */
2261         0,                  /* 24 SIGTTIN  */
2262         0,                  /* 25 SIGTTOU  */
2263         0,                  /* 26 */
2264         0,                  /* 27 */
2265         0                   /* 28 SIGWINCH  */
2266     };
2267
2268     static int initted = 0;
2269     if (!initted) {
2270         initted = 1;
2271         sig_code[16] = C$_SIGUSR1;
2272         sig_code[17] = C$_SIGUSR2;
2273         sig_code[20] = C$_SIGCHLD;
2274         sig_code[28] = C$_SIGWINCH;
2275     }
2276
2277     if (sig < _SIG_MIN) return 0;
2278     if (sig > _MY_SIG_MAX) return 0;
2279     return sig_code[sig];
2280 }
2281
2282 unsigned int
2283 Perl_sig_to_vmscondition(int sig)
2284 {
2285 #ifdef SS$_DEBUG
2286     if (vms_debug_on_exception != 0)
2287         lib$signal(SS$_DEBUG);
2288 #endif
2289     return Perl_sig_to_vmscondition_int(sig);
2290 }
2291
2292
2293 #ifdef KILL_BY_SIGPRC
2294 #define sys$sigprc SYS$SIGPRC
2295 #ifdef __cplusplus
2296 extern "C" {
2297 #endif
2298 int sys$sigprc(unsigned int *pidadr,
2299                struct dsc$descriptor_s *prcname,
2300                unsigned int code);
2301 #ifdef __cplusplus
2302 }
2303 #endif
2304
2305 int
2306 Perl_my_kill(int pid, int sig)
2307 {
2308     int iss;
2309     unsigned int code;
2310
2311      /* sig 0 means validate the PID */
2312     /*------------------------------*/
2313     if (sig == 0) {
2314         const unsigned long int jpicode = JPI$_PID;
2315         pid_t ret_pid;
2316         int status;
2317         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2318         if ($VMS_STATUS_SUCCESS(status))
2319            return 0;
2320         switch (status) {
2321         case SS$_NOSUCHNODE:
2322         case SS$_UNREACHABLE:
2323         case SS$_NONEXPR:
2324            errno = ESRCH;
2325            break;
2326         case SS$_NOPRIV:
2327            errno = EPERM;
2328            break;
2329         default:
2330            errno = EVMSERR;
2331         }
2332         vaxc$errno=status;
2333         return -1;
2334     }
2335
2336     code = Perl_sig_to_vmscondition_int(sig);
2337
2338     if (!code) {
2339         SETERRNO(EINVAL, SS$_BADPARAM);
2340         return -1;
2341     }
2342
2343     /* Per official UNIX specification: If pid = 0, or negative then
2344      * signals are to be sent to multiple processes.
2345      *  pid = 0 - all processes in group except ones that the system exempts
2346      *  pid = -1 - all processes except ones that the system exempts
2347      *  pid = -n - all processes in group (abs(n)) except ...
2348      *
2349      * Handle these via killpg, which is redundant for the -n case, since OP_KILL
2350      * in doio.c already does that. killpg currently does not support the -1 case.
2351      */
2352
2353     if (pid <= 0) {
2354         return killpg(-pid, sig);
2355     }
2356
2357     iss = sys$sigprc((unsigned int *)&pid,0,code);
2358     if (iss&1) return 0;
2359
2360     switch (iss) {
2361       case SS$_NOPRIV:
2362         set_errno(EPERM);  break;
2363       case SS$_NONEXPR:
2364       case SS$_NOSUCHNODE:
2365       case SS$_UNREACHABLE:
2366         set_errno(ESRCH);  break;
2367       case SS$_INSFMEM:
2368         set_errno(ENOMEM); break;
2369       default:
2370         _ckvmssts_noperl(iss);
2371         set_errno(EVMSERR);
2372     }
2373     set_vaxc_errno(iss);
2374
2375     return -1;
2376 }
2377 #endif
2378
2379 int
2380 Perl_my_killpg(pid_t master_pid, int signum)
2381 {
2382     int pid, status, i;
2383     unsigned long int jpi_context;
2384     unsigned short int iosb[4];
2385     struct itmlst_3  il3[3];
2386
2387     /* All processes on the system?  Seems dangerous, but it looks
2388      * like we could implement this pretty easily with a wildcard
2389      * input to sys$process_scan.
2390      */
2391     if (master_pid == -1) {
2392         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2393         return -1;
2394     }
2395
2396     /* All processes in the current process group; find the master
2397      * pid for the current process.
2398      */
2399     if (master_pid == 0) {
2400         i = 0;
2401         il3[i].buflen   = sizeof( int );
2402         il3[i].itmcode   = JPI$_MASTER_PID;
2403         il3[i].bufadr   = &master_pid;
2404         il3[i++].retlen = NULL;
2405
2406         il3[i].buflen   = 0;
2407         il3[i].itmcode   = 0;
2408         il3[i].bufadr   = NULL;
2409         il3[i++].retlen = NULL;
2410
2411         status = sys$getjpiw(EFN$C_ENF, NULL, NULL, il3, iosb, NULL, 0);
2412         if ($VMS_STATUS_SUCCESS(status))
2413             status = iosb[0];
2414
2415         switch (status) {
2416             case SS$_NORMAL:
2417                 break;
2418             case SS$_NOPRIV:
2419             case SS$_SUSPENDED:
2420                 SETERRNO(EPERM, status);
2421                 break;
2422             case SS$_NOMOREPROC:
2423             case SS$_NONEXPR:
2424             case SS$_NOSUCHNODE:
2425             case SS$_UNREACHABLE:
2426                 SETERRNO(ESRCH, status);
2427                 break;
2428             case SS$_ACCVIO:
2429             case SS$_BADPARAM:
2430                 SETERRNO(EINVAL, status);
2431                 break;
2432             default:
2433                 SETERRNO(EVMSERR, status);
2434         }
2435         if (!$VMS_STATUS_SUCCESS(status))
2436             return -1;
2437     }
2438
2439     /* Set up a process context for those processes we will scan
2440      * with sys$getjpiw.  Ask for all processes belonging to the
2441      * master pid.
2442      */
2443
2444     i = 0;
2445     il3[i].buflen   = 0;
2446     il3[i].itmcode   = PSCAN$_MASTER_PID;
2447     il3[i].bufadr   = (void *)master_pid;
2448     il3[i++].retlen = NULL;
2449
2450     il3[i].buflen   = 0;
2451     il3[i].itmcode   = 0;
2452     il3[i].bufadr   = NULL;
2453     il3[i++].retlen = NULL;
2454
2455     status = sys$process_scan(&jpi_context, il3);
2456     switch (status) {
2457         case SS$_NORMAL:
2458             break;
2459         case SS$_ACCVIO:
2460         case SS$_BADPARAM:
2461         case SS$_IVBUFLEN:
2462         case SS$_IVSSRQ:
2463             SETERRNO(EINVAL, status);
2464             break;
2465         default:
2466             SETERRNO(EVMSERR, status);
2467     }
2468     if (!$VMS_STATUS_SUCCESS(status))
2469         return -1;
2470
2471     i = 0;
2472     il3[i].buflen   = sizeof(int);
2473     il3[i].itmcode  = JPI$_PID;
2474     il3[i].bufadr   = &pid;
2475     il3[i++].retlen = NULL;
2476
2477     il3[i].buflen   = 0;
2478     il3[i].itmcode  = 0;
2479     il3[i].bufadr   = NULL;
2480     il3[i++].retlen = NULL;
2481
2482     /* Loop through the processes matching our specified criteria
2483      */
2484
2485     while (1) {
2486         /* Find the next process...
2487          */
2488         status = sys$getjpiw( EFN$C_ENF, &jpi_context, NULL, il3, iosb, NULL, 0);
2489         if ($VMS_STATUS_SUCCESS(status)) status = iosb[0];
2490
2491         switch (status) {
2492             case SS$_NORMAL:
2493                 if (kill(pid, signum) == -1)
2494                     break;
2495
2496                 continue;     /* next process */
2497             case SS$_NOPRIV:
2498             case SS$_SUSPENDED:
2499                 SETERRNO(EPERM, status);
2500                 break;
2501             case SS$_NOMOREPROC:
2502                 break;
2503             case SS$_NONEXPR:
2504             case SS$_NOSUCHNODE:
2505             case SS$_UNREACHABLE:
2506                 SETERRNO(ESRCH, status);
2507                 break;
2508             case SS$_ACCVIO:
2509             case SS$_BADPARAM:
2510                 SETERRNO(EINVAL, status);
2511                 break;
2512             default:
2513                SETERRNO(EVMSERR, status);
2514         }
2515
2516         if (!$VMS_STATUS_SUCCESS(status))
2517             break;
2518     }
2519
2520     /* Release context-related resources.
2521      */
2522     (void) sys$process_scan(&jpi_context);
2523
2524     if (status != SS$_NOMOREPROC)
2525         return -1;
2526
2527     return 0;
2528 }
2529
2530 /* Routine to convert a VMS status code to a UNIX status code.
2531 ** More tricky than it appears because of conflicting conventions with
2532 ** existing code.
2533 **
2534 ** VMS status codes are a bit mask, with the least significant bit set for
2535 ** success.
2536 **
2537 ** Special UNIX status of EVMSERR indicates that no translation is currently
2538 ** available, and programs should check the VMS status code.
2539 **
2540 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2541 ** decoding.
2542 */
2543
2544 #ifndef C_FACILITY_NO
2545 #define C_FACILITY_NO 0x350000
2546 #endif
2547 #ifndef DCL_IVVERB
2548 #define DCL_IVVERB 0x38090
2549 #endif
2550
2551 int
2552 Perl_vms_status_to_unix(int vms_status, int child_flag)
2553 {
2554   int facility;
2555   int fac_sp;
2556   int msg_no;
2557   int msg_status;
2558   int unix_status;
2559
2560   /* Assume the best or the worst */
2561   if (vms_status & STS$M_SUCCESS)
2562     unix_status = 0;
2563   else
2564     unix_status = EVMSERR;
2565
2566   msg_status = vms_status & ~STS$M_CONTROL;
2567
2568   facility = vms_status & STS$M_FAC_NO;
2569   fac_sp = vms_status & STS$M_FAC_SP;
2570   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2571
2572   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2573     switch(msg_no) {
2574     case SS$_NORMAL:
2575         unix_status = 0;
2576         break;
2577     case SS$_ACCVIO:
2578         unix_status = EFAULT;
2579         break;
2580     case SS$_DEVOFFLINE:
2581         unix_status = EBUSY;
2582         break;
2583     case SS$_CLEARED:
2584         unix_status = ENOTCONN;
2585         break;
2586     case SS$_IVCHAN:
2587     case SS$_IVLOGNAM:
2588     case SS$_BADPARAM:
2589     case SS$_IVLOGTAB:
2590     case SS$_NOLOGNAM:
2591     case SS$_NOLOGTAB:
2592     case SS$_INVFILFOROP:
2593     case SS$_INVARG:
2594     case SS$_NOSUCHID:
2595     case SS$_IVIDENT:
2596         unix_status = EINVAL;
2597         break;
2598     case SS$_UNSUPPORTED:
2599         unix_status = ENOTSUP;
2600         break;
2601     case SS$_FILACCERR:
2602     case SS$_NOGRPPRV:
2603     case SS$_NOSYSPRV:
2604         unix_status = EACCES;
2605         break;
2606     case SS$_DEVICEFULL:
2607         unix_status = ENOSPC;
2608         break;
2609     case SS$_NOSUCHDEV:
2610         unix_status = ENODEV;
2611         break;
2612     case SS$_NOSUCHFILE:
2613     case SS$_NOSUCHOBJECT:
2614         unix_status = ENOENT;
2615         break;
2616     case SS$_ABORT:                                 /* Fatal case */
2617     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2618     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2619         unix_status = EINTR;
2620         break;
2621     case SS$_BUFFEROVF:
2622         unix_status = E2BIG;
2623         break;
2624     case SS$_INSFMEM:
2625         unix_status = ENOMEM;
2626         break;
2627     case SS$_NOPRIV:
2628         unix_status = EPERM;
2629         break;
2630     case SS$_NOSUCHNODE:
2631     case SS$_UNREACHABLE:
2632         unix_status = ESRCH;
2633         break;
2634     case SS$_NONEXPR:
2635         unix_status = ECHILD;
2636         break;
2637     default:
2638         if ((facility == 0) && (msg_no < 8)) {
2639           /* These are not real VMS status codes so assume that they are
2640           ** already UNIX status codes
2641           */
2642           unix_status = msg_no;
2643           break;
2644         }
2645     }
2646   }
2647   else {
2648     /* Translate a POSIX exit code to a UNIX exit code */
2649     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2650         unix_status = (msg_no & 0x07F8) >> 3;
2651     }
2652     else {
2653
2654          /* Documented traditional behavior for handling VMS child exits */
2655         /*--------------------------------------------------------------*/
2656         if (child_flag != 0) {
2657
2658              /* Success / Informational return 0 */
2659             /*----------------------------------*/
2660             if (msg_no & STS$K_SUCCESS)
2661                 return 0;
2662
2663              /* Warning returns 1 */
2664             /*-------------------*/
2665             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2666                 return 1;
2667
2668              /* Everything else pass through the severity bits */
2669             /*------------------------------------------------*/
2670             return (msg_no & STS$M_SEVERITY);
2671         }
2672
2673          /* Normal VMS status to ERRNO mapping attempt */
2674         /*--------------------------------------------*/
2675         switch(msg_status) {
2676         /* case RMS$_EOF: */ /* End of File */
2677         case RMS$_FNF:  /* File Not Found */
2678         case RMS$_DNF:  /* Dir Not Found */
2679                 unix_status = ENOENT;
2680                 break;
2681         case RMS$_RNF:  /* Record Not Found */
2682                 unix_status = ESRCH;
2683                 break;
2684         case RMS$_DIR:
2685                 unix_status = ENOTDIR;
2686                 break;
2687         case RMS$_DEV:
2688                 unix_status = ENODEV;
2689                 break;
2690         case RMS$_IFI:
2691         case RMS$_FAC:
2692         case RMS$_ISI:
2693                 unix_status = EBADF;
2694                 break;
2695         case RMS$_FEX:
2696                 unix_status = EEXIST;
2697                 break;
2698         case RMS$_SYN:
2699         case RMS$_FNM:
2700         case LIB$_INVSTRDES:
2701         case LIB$_INVARG:
2702         case LIB$_NOSUCHSYM:
2703         case LIB$_INVSYMNAM:
2704         case DCL_IVVERB:
2705                 unix_status = EINVAL;
2706                 break;
2707         case CLI$_BUFOVF:
2708         case RMS$_RTB:
2709         case CLI$_TKNOVF:
2710         case CLI$_RSLOVF:
2711                 unix_status = E2BIG;
2712                 break;
2713         case RMS$_PRV:  /* No privilege */
2714         case RMS$_ACC:  /* ACP file access failed */
2715         case RMS$_WLK:  /* Device write locked */
2716                 unix_status = EACCES;
2717                 break;
2718         case RMS$_MKD:  /* Failed to mark for delete */
2719                 unix_status = EPERM;
2720                 break;
2721         /* case RMS$_NMF: */  /* No more files */
2722         }
2723     }
2724   }
2725
2726   return unix_status;
2727 }
2728
2729 /* Try to guess at what VMS error status should go with a UNIX errno
2730  * value.  This is hard to do as there could be many possible VMS
2731  * error statuses that caused the errno value to be set.
2732  */
2733
2734 int
2735 Perl_unix_status_to_vms(int unix_status)
2736 {
2737     int test_unix_status;
2738
2739      /* Trivial cases first */
2740     /*---------------------*/
2741     if (unix_status == EVMSERR)
2742         return vaxc$errno;
2743
2744      /* Is vaxc$errno sane? */
2745     /*---------------------*/
2746     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2747     if (test_unix_status == unix_status)
2748         return vaxc$errno;
2749
2750      /* If way out of range, must be VMS code already */
2751     /*-----------------------------------------------*/
2752     if (unix_status > EVMSERR)
2753         return unix_status;
2754
2755      /* If out of range, punt */
2756     /*-----------------------*/
2757     if (unix_status > __ERRNO_MAX)
2758         return SS$_ABORT;
2759
2760
2761      /* Ok, now we have to do it the hard way. */
2762     /*----------------------------------------*/
2763     switch(unix_status) {
2764     case 0:     return SS$_NORMAL;
2765     case EPERM: return SS$_NOPRIV;
2766     case ENOENT: return SS$_NOSUCHOBJECT;
2767     case ESRCH: return SS$_UNREACHABLE;
2768     case EINTR: return SS$_ABORT;
2769     /* case EIO: */
2770     /* case ENXIO:  */
2771     case E2BIG: return SS$_BUFFEROVF;
2772     /* case ENOEXEC */
2773     case EBADF: return RMS$_IFI;
2774     case ECHILD: return SS$_NONEXPR;
2775     /* case EAGAIN */
2776     case ENOMEM: return SS$_INSFMEM;
2777     case EACCES: return SS$_FILACCERR;
2778     case EFAULT: return SS$_ACCVIO;
2779     /* case ENOTBLK */
2780     case EBUSY: return SS$_DEVOFFLINE;
2781     case EEXIST: return RMS$_FEX;
2782     /* case EXDEV */
2783     case ENODEV: return SS$_NOSUCHDEV;
2784     case ENOTDIR: return RMS$_DIR;
2785     /* case EISDIR */
2786     case EINVAL: return SS$_INVARG;
2787     /* case ENFILE */
2788     /* case EMFILE */
2789     /* case ENOTTY */
2790     /* case ETXTBSY */
2791     /* case EFBIG */
2792     case ENOSPC: return SS$_DEVICEFULL;
2793     case ESPIPE: return LIB$_INVARG;
2794     /* case EROFS: */
2795     /* case EMLINK: */
2796     /* case EPIPE: */
2797     /* case EDOM */
2798     case ERANGE: return LIB$_INVARG;
2799     /* case EWOULDBLOCK */
2800     /* case EINPROGRESS */
2801     /* case EALREADY */
2802     /* case ENOTSOCK */
2803     /* case EDESTADDRREQ */
2804     /* case EMSGSIZE */
2805     /* case EPROTOTYPE */
2806     /* case ENOPROTOOPT */
2807     /* case EPROTONOSUPPORT */
2808     /* case ESOCKTNOSUPPORT */
2809     /* case EOPNOTSUPP */
2810     /* case EPFNOSUPPORT */
2811     /* case EAFNOSUPPORT */
2812     /* case EADDRINUSE */
2813     /* case EADDRNOTAVAIL */
2814     /* case ENETDOWN */
2815     /* case ENETUNREACH */
2816     /* case ENETRESET */
2817     /* case ECONNABORTED */
2818     /* case ECONNRESET */
2819     /* case ENOBUFS */
2820     /* case EISCONN */
2821     case ENOTCONN: return SS$_CLEARED;
2822     /* case ESHUTDOWN */
2823     /* case ETOOMANYREFS */
2824     /* case ETIMEDOUT */
2825     /* case ECONNREFUSED */
2826     /* case ELOOP */
2827     /* case ENAMETOOLONG */
2828     /* case EHOSTDOWN */
2829     /* case EHOSTUNREACH */
2830     /* case ENOTEMPTY */
2831     /* case EPROCLIM */
2832     /* case EUSERS  */
2833     /* case EDQUOT  */
2834     /* case ENOMSG  */
2835     /* case EIDRM */
2836     /* case EALIGN */
2837     /* case ESTALE */
2838     /* case EREMOTE */
2839     /* case ENOLCK */
2840     /* case ENOSYS */
2841     /* case EFTYPE */
2842     /* case ECANCELED */
2843     /* case EFAIL */
2844     /* case EINPROG */
2845     case ENOTSUP:
2846         return SS$_UNSUPPORTED;
2847     /* case EDEADLK */
2848     /* case ENWAIT */
2849     /* case EILSEQ */
2850     /* case EBADCAT */
2851     /* case EBADMSG */
2852     /* case EABANDONED */
2853     default:
2854         return SS$_ABORT; /* punt */
2855     }
2856 }
2857
2858
2859 /* default piping mailbox size */
2860 #define PERL_BUFSIZ        8192
2861
2862
2863 static void
2864 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2865 {
2866   unsigned long int mbxbufsiz;
2867   static unsigned long int syssize = 0;
2868   unsigned long int dviitm = DVI$_DEVNAM;
2869   char csize[LNM$C_NAMLENGTH+1];
2870   int sts;
2871
2872   if (!syssize) {
2873     unsigned long syiitm = SYI$_MAXBUF;
2874     /*
2875      * Get the SYSGEN parameter MAXBUF
2876      *
2877      * If the logical 'PERL_MBX_SIZE' is defined
2878      * use the value of the logical instead of PERL_BUFSIZ, but
2879      * keep the size between 128 and MAXBUF.
2880      *
2881      */
2882     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2883   }
2884
2885   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2886       mbxbufsiz = atoi(csize);
2887   } else {
2888       mbxbufsiz = PERL_BUFSIZ;
2889   }
2890   if (mbxbufsiz < 128) mbxbufsiz = 128;
2891   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2892
2893   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2894
2895   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2896   _ckvmssts_noperl(sts);
2897   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2898
2899 }  /* end of create_mbx() */
2900
2901
2902 /*{{{  my_popen and my_pclose*/
2903
2904 typedef struct _iosb           IOSB;
2905 typedef struct _iosb*         pIOSB;
2906 typedef struct _pipe           Pipe;
2907 typedef struct _pipe*         pPipe;
2908 typedef struct pipe_details    Info;
2909 typedef struct pipe_details*  pInfo;
2910 typedef struct _srqp            RQE;
2911 typedef struct _srqp*          pRQE;
2912 typedef struct _tochildbuf      CBuf;
2913 typedef struct _tochildbuf*    pCBuf;
2914
2915 struct _iosb {
2916     unsigned short status;
2917     unsigned short count;
2918     unsigned long  dvispec;
2919 };
2920
2921 #pragma member_alignment save
2922 #pragma nomember_alignment quadword
2923 struct _srqp {          /* VMS self-relative queue entry */
2924     unsigned long qptr[2];
2925 };
2926 #pragma member_alignment restore
2927 static RQE  RQE_ZERO = {0,0};
2928
2929 struct _tochildbuf {
2930     RQE             q;
2931     int             eof;
2932     unsigned short  size;
2933     char            *buf;
2934 };
2935
2936 struct _pipe {
2937     RQE            free;
2938     RQE            wait;
2939     int            fd_out;
2940     unsigned short chan_in;
2941     unsigned short chan_out;
2942     char          *buf;
2943     unsigned int   bufsize;
2944     IOSB           iosb;
2945     IOSB           iosb2;
2946     int           *pipe_done;
2947     int            retry;
2948     int            type;
2949     int            shut_on_empty;
2950     int            need_wake;
2951     pPipe         *home;
2952     pInfo          info;
2953     pCBuf          curr;
2954     pCBuf          curr2;
2955 #if defined(PERL_IMPLICIT_CONTEXT)
2956     void            *thx;           /* Either a thread or an interpreter */
2957                                     /* pointer, depending on how we're built */
2958 #endif
2959 };
2960
2961
2962 struct pipe_details
2963 {
2964     pInfo           next;
2965     PerlIO *fp;  /* file pointer to pipe mailbox */
2966     int useFILE; /* using stdio, not perlio */
2967     int pid;   /* PID of subprocess */
2968     int mode;  /* == 'r' if pipe open for reading */
2969     int done;  /* subprocess has completed */
2970     int waiting; /* waiting for completion/closure */
2971     int             closing;        /* my_pclose is closing this pipe */
2972     unsigned long   completion;     /* termination status of subprocess */
2973     pPipe           in;             /* pipe in to sub */
2974     pPipe           out;            /* pipe out of sub */
2975     pPipe           err;            /* pipe of sub's sys$error */
2976     int             in_done;        /* true when in pipe finished */
2977     int             out_done;
2978     int             err_done;
2979     unsigned short  xchan;          /* channel to debug xterm */
2980     unsigned short  xchan_valid;    /* channel is assigned */
2981 };
2982
2983 struct exit_control_block
2984 {
2985     struct exit_control_block *flink;
2986     unsigned long int (*exit_routine)(void);
2987     unsigned long int arg_count;
2988     unsigned long int *status_address;
2989     unsigned long int exit_status;
2990 };
2991
2992 typedef struct _closed_pipes    Xpipe;
2993 typedef struct _closed_pipes*  pXpipe;
2994
2995 struct _closed_pipes {
2996     int             pid;            /* PID of subprocess */
2997     unsigned long   completion;     /* termination status of subprocess */
2998 };
2999 #define NKEEPCLOSED 50
3000 static Xpipe closed_list[NKEEPCLOSED];
3001 static int   closed_index = 0;
3002 static int   closed_num = 0;
3003
3004 #define RETRY_DELAY     "0 ::0.20"
3005 #define MAX_RETRY              50
3006
3007 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
3008 static unsigned long mypid;
3009 static unsigned long delaytime[2];
3010
3011 static pInfo open_pipes = NULL;
3012 static $DESCRIPTOR(nl_desc, "NL:");
3013
3014 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
3015
3016
3017
3018 static unsigned long int
3019 pipe_exit_routine(void)
3020 {
3021     pInfo info;
3022     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
3023     int sts, did_stuff, j;
3024
3025    /*
3026     * Flush any pending i/o, but since we are in process run-down, be
3027     * careful about referencing PerlIO structures that may already have
3028     * been deallocated.  We may not even have an interpreter anymore.
3029     */
3030     info = open_pipes;
3031     while (info) {
3032         if (info->fp) {
3033 #if defined(PERL_IMPLICIT_CONTEXT)
3034            /* We need to use the Perl context of the thread that created */
3035            /* the pipe. */
3036            pTHX;
3037            if (info->err)
3038                aTHX = info->err->thx;
3039            else if (info->out)
3040                aTHX = info->out->thx;
3041            else if (info->in)
3042                aTHX = info->in->thx;
3043 #endif
3044            if (!info->useFILE
3045 #if defined(USE_ITHREADS)
3046              && my_perl
3047 #endif
3048 #ifdef USE_PERLIO
3049              && PL_perlio_fd_refcnt
3050 #endif
3051               )
3052                PerlIO_flush(info->fp);
3053            else
3054                fflush((FILE *)info->fp);
3055         }
3056         info = info->next;
3057     }
3058
3059     /*
3060      next we try sending an EOF...ignore if doesn't work, make sure we
3061      don't hang
3062     */
3063     did_stuff = 0;
3064     info = open_pipes;
3065
3066     while (info) {
3067       _ckvmssts_noperl(sys$setast(0));
3068       if (info->in && !info->in->shut_on_empty) {
3069         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3070                                  0, 0, 0, 0, 0, 0));
3071         info->waiting = 1;
3072         did_stuff = 1;
3073       }
3074       _ckvmssts_noperl(sys$setast(1));
3075       info = info->next;
3076     }
3077
3078     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3079
3080     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3081         int nwait = 0;
3082
3083         info = open_pipes;
3084         while (info) {
3085           _ckvmssts_noperl(sys$setast(0));
3086           if (info->waiting && info->done)
3087                 info->waiting = 0;
3088           nwait += info->waiting;
3089           _ckvmssts_noperl(sys$setast(1));
3090           info = info->next;
3091         }
3092         if (!nwait) break;
3093         sleep(1);
3094     }
3095
3096     did_stuff = 0;
3097     info = open_pipes;
3098     while (info) {
3099       _ckvmssts_noperl(sys$setast(0));
3100       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3101         sts = sys$forcex(&info->pid,0,&abort);
3102         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3103         did_stuff = 1;
3104       }
3105       _ckvmssts_noperl(sys$setast(1));
3106       info = info->next;
3107     }
3108
3109     /* again, wait for effect */
3110
3111     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3112         int nwait = 0;
3113
3114         info = open_pipes;
3115         while (info) {
3116           _ckvmssts_noperl(sys$setast(0));
3117           if (info->waiting && info->done)
3118                 info->waiting = 0;
3119           nwait += info->waiting;
3120           _ckvmssts_noperl(sys$setast(1));
3121           info = info->next;
3122         }
3123         if (!nwait) break;
3124         sleep(1);
3125     }
3126
3127     info = open_pipes;
3128     while (info) {
3129       _ckvmssts_noperl(sys$setast(0));
3130       if (!info->done) {  /* We tried to be nice . . . */
3131         sts = sys$delprc(&info->pid,0);
3132         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3133         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3134       }
3135       _ckvmssts_noperl(sys$setast(1));
3136       info = info->next;
3137     }
3138
3139     while(open_pipes) {
3140
3141 #if defined(PERL_IMPLICIT_CONTEXT)
3142       /* We need to use the Perl context of the thread that created */
3143       /* the pipe. */
3144       pTHX;
3145       if (open_pipes->err)
3146           aTHX = open_pipes->err->thx;
3147       else if (open_pipes->out)
3148           aTHX = open_pipes->out->thx;
3149       else if (open_pipes->in)
3150           aTHX = open_pipes->in->thx;
3151 #endif
3152       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3153       else if (!(sts & 1)) retsts = sts;
3154     }
3155     return retsts;
3156 }
3157
3158 static struct exit_control_block pipe_exitblock =
3159        {(struct exit_control_block *) 0,
3160         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3161
3162 static void pipe_mbxtofd_ast(pPipe p);
3163 static void pipe_tochild1_ast(pPipe p);
3164 static void pipe_tochild2_ast(pPipe p);
3165
3166 static void
3167 popen_completion_ast(pInfo info)
3168 {
3169   pInfo i = open_pipes;
3170   int iss;
3171
3172   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3173   closed_list[closed_index].pid = info->pid;
3174   closed_list[closed_index].completion = info->completion;
3175   closed_index++;
3176   if (closed_index == NKEEPCLOSED)
3177     closed_index = 0;
3178   closed_num++;
3179
3180   while (i) {
3181     if (i == info) break;
3182     i = i->next;
3183   }
3184   if (!i) return;       /* unlinked, probably freed too */
3185
3186   info->done = TRUE;
3187
3188 /*
3189     Writing to subprocess ...
3190             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3191
3192             chan_out may be waiting for "done" flag, or hung waiting
3193             for i/o completion to child...cancel the i/o.  This will
3194             put it into "snarf mode" (done but no EOF yet) that discards
3195             input.
3196
3197     Output from subprocess (stdout, stderr) needs to be flushed and
3198     shut down.   We try sending an EOF, but if the mbx is full the pipe
3199     routine should still catch the "shut_on_empty" flag, telling it to
3200     use immediate-style reads so that "mbx empty" -> EOF.
3201
3202
3203 */
3204   if (info->in && !info->in_done) {               /* only for mode=w */
3205         if (info->in->shut_on_empty && info->in->need_wake) {
3206             info->in->need_wake = FALSE;
3207             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3208         } else {
3209             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3210         }
3211   }
3212
3213   if (info->out && !info->out_done) {             /* were we also piping output? */
3214       info->out->shut_on_empty = TRUE;
3215       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3216       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3217       _ckvmssts_noperl(iss);
3218   }
3219
3220   if (info->err && !info->err_done) {        /* we were piping stderr */
3221         info->err->shut_on_empty = TRUE;
3222         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3223         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3224         _ckvmssts_noperl(iss);
3225   }
3226   _ckvmssts_noperl(sys$setef(pipe_ef));
3227
3228 }
3229
3230 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3231 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3232 static void pipe_infromchild_ast(pPipe p);
3233
3234 /*
3235     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3236     inside an AST routine without worrying about reentrancy and which Perl
3237     memory allocator is being used.
3238
3239     We read data and queue up the buffers, then spit them out one at a
3240     time to the output mailbox when the output mailbox is ready for one.
3241
3242 */
3243 #define INITIAL_TOCHILDQUEUE  2
3244
3245 static pPipe
3246 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3247 {
3248     pPipe p;
3249     pCBuf b;
3250     char mbx1[64], mbx2[64];
3251     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3252                                       DSC$K_CLASS_S, mbx1},
3253                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3254                                       DSC$K_CLASS_S, mbx2};
3255     unsigned int dviitm = DVI$_DEVBUFSIZ;
3256     int j, n;
3257
3258     n = sizeof(Pipe);
3259     _ckvmssts_noperl(lib$get_vm(&n, &p));
3260
3261     create_mbx(&p->chan_in , &d_mbx1);
3262     create_mbx(&p->chan_out, &d_mbx2);
3263     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3264
3265     p->buf           = 0;
3266     p->shut_on_empty = FALSE;
3267     p->need_wake     = FALSE;
3268     p->type          = 0;
3269     p->retry         = 0;
3270     p->iosb.status   = SS$_NORMAL;
3271     p->iosb2.status  = SS$_NORMAL;
3272     p->free          = RQE_ZERO;
3273     p->wait          = RQE_ZERO;
3274     p->curr          = 0;
3275     p->curr2         = 0;
3276     p->info          = 0;
3277 #ifdef PERL_IMPLICIT_CONTEXT
3278     p->thx           = aTHX;
3279 #endif
3280
3281     n = sizeof(CBuf) + p->bufsize;
3282
3283     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3284         _ckvmssts_noperl(lib$get_vm(&n, &b));
3285         b->buf = (char *) b + sizeof(CBuf);
3286         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3287     }
3288
3289     pipe_tochild2_ast(p);
3290     pipe_tochild1_ast(p);
3291     strcpy(wmbx, mbx1);
3292     strcpy(rmbx, mbx2);
3293     return p;
3294 }
3295
3296 /*  reads the MBX Perl is writing, and queues */
3297
3298 static void
3299 pipe_tochild1_ast(pPipe p)
3300 {
3301     pCBuf b = p->curr;
3302     int iss = p->iosb.status;
3303     int eof = (iss == SS$_ENDOFFILE);
3304     int sts;
3305 #ifdef PERL_IMPLICIT_CONTEXT
3306     pTHX = p->thx;
3307 #endif
3308
3309     if (p->retry) {
3310         if (eof) {
3311             p->shut_on_empty = TRUE;
3312             b->eof     = TRUE;
3313             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3314         } else  {
3315             _ckvmssts_noperl(iss);
3316         }
3317
3318         b->eof  = eof;
3319         b->size = p->iosb.count;
3320         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3321         if (p->need_wake) {
3322             p->need_wake = FALSE;
3323             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3324         }
3325     } else {
3326         p->retry = 1;   /* initial call */
3327     }
3328
3329     if (eof) {                  /* flush the free queue, return when done */
3330         int n = sizeof(CBuf) + p->bufsize;
3331         while (1) {
3332             iss = lib$remqti(&p->free, &b);
3333             if (iss == LIB$_QUEWASEMP) return;
3334             _ckvmssts_noperl(iss);
3335             _ckvmssts_noperl(lib$free_vm(&n, &b));
3336         }
3337     }
3338
3339     iss = lib$remqti(&p->free, &b);
3340     if (iss == LIB$_QUEWASEMP) {
3341         int n = sizeof(CBuf) + p->bufsize;
3342         _ckvmssts_noperl(lib$get_vm(&n, &b));
3343         b->buf = (char *) b + sizeof(CBuf);
3344     } else {
3345        _ckvmssts_noperl(iss);
3346     }
3347
3348     p->curr = b;
3349     iss = sys$qio(0,p->chan_in,
3350              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3351              &p->iosb,
3352              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3353     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3354     _ckvmssts_noperl(iss);
3355 }
3356
3357
3358 /* writes queued buffers to output, waits for each to complete before
3359    doing the next */
3360
3361 static void
3362 pipe_tochild2_ast(pPipe p)
3363 {
3364     pCBuf b = p->curr2;
3365     int iss = p->iosb2.status;
3366     int n = sizeof(CBuf) + p->bufsize;
3367     int done = (p->info && p->info->done) ||
3368               iss == SS$_CANCEL || iss == SS$_ABORT;
3369 #if defined(PERL_IMPLICIT_CONTEXT)
3370     pTHX = p->thx;
3371 #endif
3372
3373     do {
3374         if (p->type) {         /* type=1 has old buffer, dispose */
3375             if (p->shut_on_empty) {
3376                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3377             } else {
3378                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3379             }
3380             p->type = 0;
3381         }
3382
3383         iss = lib$remqti(&p->wait, &b);
3384         if (iss == LIB$_QUEWASEMP) {
3385             if (p->shut_on_empty) {
3386                 if (done) {
3387                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3388                     *p->pipe_done = TRUE;
3389                     _ckvmssts_noperl(sys$setef(pipe_ef));
3390                 } else {
3391                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3392                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3393                 }
3394                 return;
3395             }
3396             p->need_wake = TRUE;
3397             return;
3398         }
3399         _ckvmssts_noperl(iss);
3400         p->type = 1;
3401     } while (done);
3402
3403
3404     p->curr2 = b;
3405     if (b->eof) {
3406         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3407             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3408     } else {
3409         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3410             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3411     }
3412
3413     return;
3414
3415 }
3416
3417
3418 static pPipe
3419 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3420 {
3421     pPipe p;
3422     char mbx1[64], mbx2[64];
3423     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3424                                       DSC$K_CLASS_S, mbx1},
3425                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3426                                       DSC$K_CLASS_S, mbx2};
3427     unsigned int dviitm = DVI$_DEVBUFSIZ;
3428
3429     int n = sizeof(Pipe);
3430     _ckvmssts_noperl(lib$get_vm(&n, &p));
3431     create_mbx(&p->chan_in , &d_mbx1);
3432     create_mbx(&p->chan_out, &d_mbx2);
3433
3434     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3435     n = p->bufsize * sizeof(char);
3436     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3437     p->shut_on_empty = FALSE;
3438     p->info   = 0;
3439     p->type   = 0;
3440     p->iosb.status = SS$_NORMAL;
3441 #if defined(PERL_IMPLICIT_CONTEXT)
3442     p->thx = aTHX;
3443 #endif
3444     pipe_infromchild_ast(p);
3445
3446     strcpy(wmbx, mbx1);
3447     strcpy(rmbx, mbx2);
3448     return p;
3449 }
3450
3451 static void
3452 pipe_infromchild_ast(pPipe p)
3453 {
3454     int iss = p->iosb.status;
3455     int eof = (iss == SS$_ENDOFFILE);
3456     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3457     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3458 #if defined(PERL_IMPLICIT_CONTEXT)
3459     pTHX = p->thx;
3460 #endif
3461
3462     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3463         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3464         p->chan_out = 0;
3465     }
3466
3467     /* read completed:
3468             input shutdown if EOF from self (done or shut_on_empty)
3469             output shutdown if closing flag set (my_pclose)
3470             send data/eof from child or eof from self
3471             otherwise, re-read (snarf of data from child)
3472     */
3473
3474     if (p->type == 1) {
3475         p->type = 0;
3476         if (myeof && p->chan_in) {                  /* input shutdown */
3477             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3478             p->chan_in = 0;
3479         }
3480
3481         if (p->chan_out) {
3482             if (myeof || kideof) {      /* pass EOF to parent */
3483                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3484                                          pipe_infromchild_ast, p,
3485                                          0, 0, 0, 0, 0, 0));
3486                 return;
3487             } else if (eof) {       /* eat EOF --- fall through to read*/
3488
3489             } else {                /* transmit data */
3490                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3491                                          pipe_infromchild_ast,p,
3492                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3493                 return;
3494             }
3495         }
3496     }
3497
3498     /*  everything shut? flag as done */
3499
3500     if (!p->chan_in && !p->chan_out) {
3501         *p->pipe_done = TRUE;
3502         _ckvmssts_noperl(sys$setef(pipe_ef));
3503         return;
3504     }
3505
3506     /* write completed (or read, if snarfing from child)
3507             if still have input active,
3508                queue read...immediate mode if shut_on_empty so we get EOF if empty
3509             otherwise,
3510                check if Perl reading, generate EOFs as needed
3511     */
3512
3513     if (p->type == 0) {
3514         p->type = 1;
3515         if (p->chan_in) {
3516             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3517                           pipe_infromchild_ast,p,
3518                           p->buf, p->bufsize, 0, 0, 0, 0);
3519             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3520             _ckvmssts_noperl(iss);
3521         } else {           /* send EOFs for extra reads */
3522             p->iosb.status = SS$_ENDOFFILE;
3523             p->iosb.dvispec = 0;
3524             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3525                                      0, 0, 0,
3526                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3527         }
3528     }
3529 }
3530
3531 static pPipe
3532 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3533 {
3534     pPipe p;
3535     char mbx[64];
3536     unsigned long dviitm = DVI$_DEVBUFSIZ;
3537     struct stat s;
3538     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3539                                       DSC$K_CLASS_S, mbx};
3540     int n = sizeof(Pipe);
3541
3542     /* things like terminals and mbx's don't need this filter */
3543     if (fd && fstat(fd,&s) == 0) {
3544         unsigned long devchar;
3545         char device[65];
3546         unsigned short dev_len;
3547         struct dsc$descriptor_s d_dev;
3548         char * cptr;
3549         struct item_list_3 items[3];
3550         int status;
3551         unsigned short dvi_iosb[4];
3552
3553         cptr = getname(fd, out, 1);
3554         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3555         d_dev.dsc$a_pointer = out;
3556         d_dev.dsc$w_length = strlen(out);
3557         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3558         d_dev.dsc$b_class = DSC$K_CLASS_S;
3559
3560         items[0].len = 4;
3561         items[0].code = DVI$_DEVCHAR;
3562         items[0].bufadr = &devchar;
3563         items[0].retadr = NULL;
3564         items[1].len = 64;
3565         items[1].code = DVI$_FULLDEVNAM;
3566         items[1].bufadr = device;
3567         items[1].retadr = &dev_len;
3568         items[2].len = 0;
3569         items[2].code = 0;
3570
3571         status = sys$getdviw
3572                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3573         _ckvmssts_noperl(status);
3574         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3575             device[dev_len] = 0;
3576
3577             if (!(devchar & DEV$M_DIR)) {
3578                 strcpy(out, device);
3579                 return 0;
3580             }
3581         }
3582     }
3583
3584     _ckvmssts_noperl(lib$get_vm(&n, &p));
3585     p->fd_out = dup(fd);
3586     create_mbx(&p->chan_in, &d_mbx);
3587     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3588     n = (p->bufsize+1) * sizeof(char);
3589     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3590     p->shut_on_empty = FALSE;
3591     p->retry = 0;
3592     p->info  = 0;
3593     strcpy(out, mbx);
3594
3595     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3596                              pipe_mbxtofd_ast, p,
3597                              p->buf, p->bufsize, 0, 0, 0, 0));
3598
3599     return p;
3600 }
3601
3602 static void
3603 pipe_mbxtofd_ast(pPipe p)
3604 {
3605     int iss = p->iosb.status;
3606     int done = p->info->done;
3607     int iss2;
3608     int eof = (iss == SS$_ENDOFFILE);
3609     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3610     int err = !(iss&1) && !eof;
3611 #if defined(PERL_IMPLICIT_CONTEXT)
3612     pTHX = p->thx;
3613 #endif
3614
3615     if (done && myeof) {               /* end piping */
3616         close(p->fd_out);
3617         sys$dassgn(p->chan_in);
3618         *p->pipe_done = TRUE;
3619         _ckvmssts_noperl(sys$setef(pipe_ef));
3620         return;
3621     }
3622
3623     if (!err && !eof) {             /* good data to send to file */
3624         p->buf[p->iosb.count] = '\n';
3625         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3626         if (iss2 < 0) {
3627             p->retry++;
3628             if (p->retry < MAX_RETRY) {
3629                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3630                 return;
3631             }
3632         }
3633         p->retry = 0;
3634     } else if (err) {
3635         _ckvmssts_noperl(iss);
3636     }
3637
3638
3639     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3640           pipe_mbxtofd_ast, p,
3641           p->buf, p->bufsize, 0, 0, 0, 0);
3642     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3643     _ckvmssts_noperl(iss);
3644 }
3645
3646
3647 typedef struct _pipeloc     PLOC;
3648 typedef struct _pipeloc*   pPLOC;
3649
3650 struct _pipeloc {
3651     pPLOC   next;
3652     char    dir[NAM$C_MAXRSS+1];
3653 };
3654 static pPLOC  head_PLOC = 0;
3655
3656 void
3657 free_pipelocs(pTHX_ void *head)
3658 {
3659     pPLOC p, pnext;
3660     pPLOC *pHead = (pPLOC *)head;
3661
3662     p = *pHead;
3663     while (p) {
3664         pnext = p->next;
3665         PerlMem_free(p);
3666         p = pnext;
3667     }
3668     *pHead = 0;
3669 }
3670
3671 static void
3672 store_pipelocs(pTHX)
3673 {
3674     int    i;
3675     pPLOC  p;
3676     AV    *av = 0;
3677     SV    *dirsv;
3678     char  *dir, *x;
3679     char  *unixdir;
3680     char  temp[NAM$C_MAXRSS+1];
3681     STRLEN n_a;
3682
3683     if (head_PLOC)
3684         free_pipelocs(aTHX_ &head_PLOC);
3685
3686 /*  the . directory from @INC comes last */
3687
3688     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3689     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3690     p->next = head_PLOC;
3691     head_PLOC = p;
3692     strcpy(p->dir,"./");
3693
3694 /*  get the directory from $^X */
3695
3696     unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
3697     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3698
3699 #ifdef PERL_IMPLICIT_CONTEXT
3700     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3701 #else
3702     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3703 #endif
3704         my_strlcpy(temp, PL_origargv[0], sizeof(temp));
3705         x = strrchr(temp,']');
3706         if (x == NULL) {
3707         x = strrchr(temp,'>');
3708           if (x == NULL) {
3709             /* It could be a UNIX path */
3710             x = strrchr(temp,'/');
3711           }
3712         }
3713         if (x)
3714           x[1] = '\0';
3715         else {
3716           /* Got a bare name, so use default directory */
3717           temp[0] = '.';
3718           temp[1] = '\0';
3719         }
3720
3721         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3722             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3723             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3724             p->next = head_PLOC;
3725             head_PLOC = p;
3726             my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3727         }
3728     }
3729
3730 /*  reverse order of @INC entries, skip "." since entered above */
3731
3732 #ifdef PERL_IMPLICIT_CONTEXT
3733     if (aTHX)
3734 #endif
3735     if (PL_incgv) av = GvAVn(PL_incgv);
3736
3737     for (i = 0; av && i <= AvFILL(av); i++) {
3738         dirsv = *av_fetch(av,i,TRUE);
3739
3740         if (SvROK(dirsv)) continue;
3741         dir = SvPVx(dirsv,n_a);
3742         if (strEQ(dir,".")) continue;
3743         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3744             continue;
3745
3746         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3747         p->next = head_PLOC;
3748         head_PLOC = p;
3749         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3750     }
3751
3752 /* most likely spot (ARCHLIB) put first in the list */
3753
3754 #ifdef ARCHLIB_EXP
3755     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3756         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3757         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3758         p->next = head_PLOC;
3759         head_PLOC = p;
3760         my_strlcpy(p->dir, unixdir, sizeof(p->dir));
3761     }
3762 #endif
3763     PerlMem_free(unixdir);
3764 }
3765
3766 static I32 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective,
3767                                   const char *fname, int opts);
3768 #if !defined(PERL_IMPLICIT_CONTEXT)
3769 #define cando_by_name_int               Perl_cando_by_name_int
3770 #else
3771 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3772 #endif
3773
3774 static char *
3775 find_vmspipe(pTHX)
3776 {
3777     static int   vmspipe_file_status = 0;
3778     static char  vmspipe_file[NAM$C_MAXRSS+1];
3779
3780     /* already found? Check and use ... need read+execute permission */
3781
3782     if (vmspipe_file_status == 1) {
3783         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3784          && cando_by_name_int
3785            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3786             return vmspipe_file;
3787         }
3788         vmspipe_file_status = 0;
3789     }
3790
3791     /* scan through stored @INC, $^X */
3792
3793     if (vmspipe_file_status == 0) {
3794         char file[NAM$C_MAXRSS+1];
3795         pPLOC  p = head_PLOC;
3796
3797         while (p) {
3798             char * exp_res;
3799             int dirlen;
3800             dirlen = my_strlcpy(file, p->dir, sizeof(file));
3801             my_strlcat(file, "vmspipe.com", sizeof(file));
3802             p = p->next;
3803
3804             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3805             if (!exp_res) continue;
3806
3807             if (cando_by_name_int
3808                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3809              && cando_by_name_int
3810                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3811                 vmspipe_file_status = 1;
3812                 return vmspipe_file;
3813             }
3814         }
3815         vmspipe_file_status = -1;   /* failed, use tempfiles */
3816     }
3817
3818     return 0;
3819 }
3820
3821 static FILE *
3822 vmspipe_tempfile(pTHX)
3823 {
3824     char file[NAM$C_MAXRSS+1];
3825     FILE *fp;
3826     static int index = 0;
3827     Stat_t s0, s1;
3828     int cmp_result;
3829
3830     /* create a tempfile */
3831
3832     /* we can't go from   W, shr=get to  R, shr=get without
3833        an intermediate vulnerable state, so don't bother trying...
3834
3835        and lib$spawn doesn't shr=put, so have to close the write
3836
3837        So... match up the creation date/time and the FID to
3838        make sure we're dealing with the same file
3839
3840     */
3841
3842     index++;
3843     if (!DECC_FILENAME_UNIX_ONLY) {
3844       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3845       fp = fopen(file,"w");
3846       if (!fp) {
3847         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3848         fp = fopen(file,"w");
3849         if (!fp) {
3850             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3851             fp = fopen(file,"w");
3852         }
3853       }
3854      }
3855      else {
3856       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3857       fp = fopen(file,"w");
3858       if (!fp) {
3859         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3860         fp = fopen(file,"w");
3861         if (!fp) {
3862           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3863           fp = fopen(file,"w");
3864         }
3865       }
3866     }
3867     if (!fp) return 0;  /* we're hosed */
3868
3869     fprintf(fp,"$! 'f$verify(0)'\n");
3870     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3871     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3872     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3873     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3874     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3875     fprintf(fp,"$ perl_del    = \"delete\"\n");
3876     fprintf(fp,"$ pif         = \"if\"\n");
3877     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3878     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3879     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3880     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3881     fprintf(fp,"$!  --- build command line to get max possible length\n");
3882     fprintf(fp,"$c=perl_popen_cmd0\n");
3883     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3884     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3885     fprintf(fp,"$x=perl_popen_cmd3\n");
3886     fprintf(fp,"$c=c+x\n");
3887     fprintf(fp,"$ perl_on\n");
3888     fprintf(fp,"$ 'c'\n");
3889     fprintf(fp,"$ perl_status = $STATUS\n");
3890     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3891     fprintf(fp,"$ perl_exit 'perl_status'\n");
3892     fsync(fileno(fp));
3893
3894     fgetname(fp, file, 1);
3895     fstat(fileno(fp), &s0.crtl_stat);
3896     fclose(fp);
3897
3898     if (DECC_FILENAME_UNIX_ONLY)
3899         int_tounixspec(file, file, NULL);
3900     fp = fopen(file,"r","shr=get");
3901     if (!fp) return 0;
3902     fstat(fileno(fp), &s1.crtl_stat);
3903
3904     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3905     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3906         fclose(fp);
3907         return 0;
3908     }
3909
3910     return fp;
3911 }
3912
3913
3914 static int
3915 vms_is_syscommand_xterm(void)
3916 {
3917     const static struct dsc$descriptor_s syscommand_dsc =
3918       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3919
3920     const static struct dsc$descriptor_s decwdisplay_dsc =
3921       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3922
3923     struct item_list_3 items[2];
3924     unsigned short dvi_iosb[4];
3925     unsigned long devchar;
3926     unsigned long devclass;
3927     int status;
3928
3929     /* Very simple check to guess if sys$command is a decterm? */
3930     /* First see if the DECW$DISPLAY: device exists */
3931     items[0].len = 4;
3932     items[0].code = DVI$_DEVCHAR;
3933     items[0].bufadr = &devchar;
3934     items[0].retadr = NULL;
3935     items[1].len = 0;
3936     items[1].code = 0;
3937
3938     status = sys$getdviw
3939         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3940
3941     if ($VMS_STATUS_SUCCESS(status)) {
3942         status = dvi_iosb[0];
3943     }
3944
3945     if (!$VMS_STATUS_SUCCESS(status)) {
3946         SETERRNO(EVMSERR, status);
3947         return -1;
3948     }
3949
3950     /* If it does, then for now assume that we are on a workstation */
3951     /* Now verify that SYS$COMMAND is a terminal */
3952     /* for creating the debugger DECTerm */
3953
3954     items[0].len = 4;
3955     items[0].code = DVI$_DEVCLASS;
3956     items[0].bufadr = &devclass;
3957     items[0].retadr = NULL;
3958     items[1].len = 0;
3959     items[1].code = 0;
3960
3961     status = sys$getdviw
3962         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3963
3964     if ($VMS_STATUS_SUCCESS(status)) {
3965         status = dvi_iosb[0];
3966     }
3967
3968     if (!$VMS_STATUS_SUCCESS(status)) {
3969         SETERRNO(EVMSERR, status);
3970         return -1;
3971     }
3972     else {
3973         if (devclass == DC$_TERM) {
3974             return 0;
3975         }
3976     }
3977     return -1;
3978 }
3979
3980 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3981 static PerlIO*
3982 create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3983 {
3984     int status;
3985     int ret_stat;
3986     char * ret_char;
3987     char device_name[65];
3988     unsigned short device_name_len;
3989     struct dsc$descriptor_s customization_dsc;
3990     struct dsc$descriptor_s device_name_dsc;
3991     const char * cptr;
3992     char customization[200];
3993     char title[40];
3994     pInfo info = NULL;
3995     char mbx1[64];
3996     unsigned short p_chan;
3997     int n;
3998     unsigned short iosb[4];
3999     const char * cust_str =
4000         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4001     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4002                                           DSC$K_CLASS_S, mbx1};
4003
4004      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4005     /*---------------------------------------*/
4006     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4007
4008
4009     /* Make sure that this is from the Perl debugger */
4010     ret_char = strstr(cmd," xterm ");
4011     if (ret_char == NULL)
4012         return NULL;
4013     cptr = ret_char + 7;
4014     ret_char = strstr(cmd,"tty");
4015     if (ret_char == NULL)
4016         return NULL;
4017     ret_char = strstr(cmd,"sleep");
4018     if (ret_char == NULL)
4019         return NULL;
4020
4021     if (decw_term_port == 0) {
4022         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4023         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4024         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4025
4026        status = lib$find_image_symbol
4027                                (&filename1_dsc,
4028                                 &decw_term_port_dsc,
4029                                 (void *)&decw_term_port,
4030                                 NULL,
4031                                 0);
4032
4033         /* Try again with the other image name */
4034         if (!$VMS_STATUS_SUCCESS(status)) {
4035
4036            status = lib$find_image_symbol
4037                                (&filename2_dsc,
4038                                 &decw_term_port_dsc,
4039                                 (void *)&decw_term_port,
4040                                 NULL,
4041                                 0);
4042
4043         }
4044
4045     }
4046
4047
4048     /* No decw$term_port, give it up */
4049     if (!$VMS_STATUS_SUCCESS(status))
4050         return NULL;
4051
4052     /* Are we on a workstation? */
4053     /* to do: capture the rows / columns and pass their properties */
4054     ret_stat = vms_is_syscommand_xterm();
4055     if (ret_stat < 0)
4056         return NULL;
4057
4058     /* Make the title: */
4059     ret_char = strstr(cptr,"-title");
4060     if (ret_char != NULL) {
4061         while ((*cptr != 0) && (*cptr != '\"')) {
4062             cptr++;
4063         }
4064         if (*cptr == '\"')
4065             cptr++;
4066         n = 0;
4067         while ((*cptr != 0) && (*cptr != '\"')) {
4068             title[n] = *cptr;
4069             n++;
4070             if (n == 39) {
4071                 title[39] = 0;
4072                 break;
4073             }
4074             cptr++;
4075         }
4076         title[n] = 0;
4077     }
4078     else {
4079             /* Default title */
4080             strcpy(title,"Perl Debug DECTerm");
4081     }
4082     sprintf(customization, cust_str, title);
4083
4084     customization_dsc.dsc$a_pointer = customization;
4085     customization_dsc.dsc$w_length = strlen(customization);
4086     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4087     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4088
4089     device_name_dsc.dsc$a_pointer = device_name;
4090     device_name_dsc.dsc$w_length = sizeof device_name -1;
4091     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4092     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4093
4094     device_name_len = 0;
4095
4096     /* Try to create the window */
4097      status = (*decw_term_port)
4098        (NULL,
4099         NULL,
4100         &customization_dsc,
4101         &device_name_dsc,
4102         &device_name_len,
4103         NULL,
4104         NULL,
4105         NULL);
4106     if (!$VMS_STATUS_SUCCESS(status)) {
4107         SETERRNO(EVMSERR, status);
4108         return NULL;
4109     }
4110
4111     device_name[device_name_len] = '\0';
4112
4113     /* Need to set this up to look like a pipe for cleanup */
4114     n = sizeof(Info);
4115     status = lib$get_vm(&n, &info);
4116     if (!$VMS_STATUS_SUCCESS(status)) {
4117         SETERRNO(ENOMEM, status);
4118         return NULL;
4119     }
4120
4121     info->mode = *mode;
4122     info->done = FALSE;
4123     info->completion = 0;
4124     info->closing    = FALSE;
4125     info->in         = 0;
4126     info->out        = 0;
4127     info->err        = 0;
4128     info->fp         = NULL;
4129     info->useFILE    = 0;
4130     info->waiting    = 0;
4131     info->in_done    = TRUE;
4132     info->out_done   = TRUE;
4133     info->err_done   = TRUE;
4134
4135     /* Assign a channel on this so that it will persist, and not login */
4136     /* We stash this channel in the info structure for reference. */
4137     /* The created xterm self destructs when the last channel is removed */
4138     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4139     /* So leave this assigned. */
4140     device_name_dsc.dsc$w_length = device_name_len;
4141     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4142     if (!$VMS_STATUS_SUCCESS(status)) {
4143         SETERRNO(EVMSERR, status);
4144         return NULL;
4145     }
4146     info->xchan_valid = 1;
4147
4148     /* Now create a mailbox to be read by the application */
4149
4150     create_mbx(&p_chan, &d_mbx1);
4151
4152     /* write the name of the created terminal to the mailbox */
4153     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4154             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4155
4156     if (!$VMS_STATUS_SUCCESS(status)) {
4157         SETERRNO(EVMSERR, status);
4158         return NULL;
4159     }
4160
4161     info->fp  = PerlIO_open(mbx1, mode);
4162
4163     /* Done with this channel */
4164     sys$dassgn(p_chan);
4165
4166     /* If any errors, then clean up */
4167     if (!info->fp) {
4168         n = sizeof(Info);
4169         _ckvmssts_noperl(lib$free_vm(&n, &info));
4170         return NULL;
4171         }
4172
4173     /* All done */
4174     return info->fp;
4175 }
4176
4177 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4178
4179 static PerlIO *
4180 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4181 {
4182     static int handler_set_up = FALSE;
4183     PerlIO * ret_fp;
4184     unsigned long int sts, flags = CLI$M_NOWAIT;
4185     /* The use of a GLOBAL table (as was done previously) rendered
4186      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4187      * environment.  Hence we've switched to LOCAL symbol table.
4188      */
4189     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4190     int j, wait = 0, n;
4191     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4192     char *in, *out, *err, mbx[512];
4193     FILE *tpipe = 0;
4194     char tfilebuf[NAM$C_MAXRSS+1];
4195     pInfo info = NULL;
4196     char cmd_sym_name[20];
4197     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4198                                       DSC$K_CLASS_S, symbol};
4199     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4200                                       DSC$K_CLASS_S, 0};
4201     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4202                                       DSC$K_CLASS_S, cmd_sym_name};
4203     struct dsc$descriptor_s *vmscmd;
4204     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4205     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4206     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4207
4208     /* Check here for Xterm create request.  This means looking for
4209      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4210      *  is possible to create an xterm.
4211      */
4212     if (*in_mode == 'r') {
4213         PerlIO * xterm_fd;
4214
4215 #if defined(PERL_IMPLICIT_CONTEXT)
4216         /* Can not fork an xterm with a NULL context */
4217         /* This probably could never happen */
4218         xterm_fd = NULL;
4219         if (aTHX != NULL)
4220 #endif
4221         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4222         if (xterm_fd != NULL)
4223             return xterm_fd;
4224     }
4225
4226     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4227
4228     /* once-per-program initialization...
4229        note that the SETAST calls and the dual test of pipe_ef
4230        makes sure that only the FIRST thread through here does
4231        the initialization...all other threads wait until it's
4232        done.
4233
4234        Yeah, uglier than a pthread call, it's got all the stuff inline
4235        rather than in a separate routine.
4236     */
4237
4238     if (!pipe_ef) {
4239         _ckvmssts_noperl(sys$setast(0));
4240         if (!pipe_ef) {
4241             unsigned long int pidcode = JPI$_PID;
4242             $DESCRIPTOR(d_delay, RETRY_DELAY);
4243             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4244             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4245             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4246         }
4247         if (!handler_set_up) {
4248           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4249           handler_set_up = TRUE;
4250         }
4251         _ckvmssts_noperl(sys$setast(1));
4252     }
4253
4254     /* see if we can find a VMSPIPE.COM */
4255
4256     tfilebuf[0] = '@';
4257     vmspipe = find_vmspipe(aTHX);
4258     if (vmspipe) {
4259         vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
4260     } else {        /* uh, oh...we're in tempfile hell */
4261         tpipe = vmspipe_tempfile(aTHX);
4262         if (!tpipe) {       /* a fish popular in Boston */
4263             if (ckWARN(WARN_PIPE)) {
4264                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4265             }
4266         return NULL;
4267         }
4268         fgetname(tpipe,tfilebuf+1,1);
4269         vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4270     }
4271     vmspipedsc.dsc$a_pointer = tfilebuf;
4272
4273     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4274     if (!(sts & 1)) {
4275       switch (sts) {
4276         case RMS$_FNF:  case RMS$_DNF:
4277           set_errno(ENOENT); break;
4278         case RMS$_DIR:
4279           set_errno(ENOTDIR); break;
4280         case RMS$_DEV:
4281           set_errno(ENODEV); break;
4282         case RMS$_PRV:
4283           set_errno(EACCES); break;
4284         case RMS$_SYN:
4285           set_errno(EINVAL); break;
4286         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4287           set_errno(E2BIG); break;
4288         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4289           _ckvmssts_noperl(sts); /* fall through */
4290         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4291           set_errno(EVMSERR);
4292       }
4293       set_vaxc_errno(sts);
4294       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4295         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4296       }
4297       *psts = sts;
4298       return NULL;
4299     }
4300     n = sizeof(Info);
4301     _ckvmssts_noperl(lib$get_vm(&n, &info));
4302
4303     my_strlcpy(mode, in_mode, sizeof(mode));
4304     info->mode = *mode;
4305     info->done = FALSE;
4306     info->completion = 0;
4307     info->closing    = FALSE;
4308     info->in         = 0;
4309     info->out        = 0;
4310     info->err        = 0;
4311     info->fp         = NULL;
4312     info->useFILE    = 0;
4313     info->waiting    = 0;
4314     info->in_done    = TRUE;
4315     info->out_done   = TRUE;
4316     info->err_done   = TRUE;
4317     info->xchan      = 0;
4318     info->xchan_valid = 0;
4319
4320     in = (char *)PerlMem_malloc(VMS_MAXRSS);
4321     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4322     out = (char *)PerlMem_malloc(VMS_MAXRSS);
4323     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4324     err = (char *)PerlMem_malloc(VMS_MAXRSS);
4325     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4326
4327     in[0] = out[0] = err[0] = '\0';
4328
4329     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4330         info->useFILE = 1;
4331         strcpy(p,p+1);
4332     }
4333     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4334         wait = 1;
4335         strcpy(p,p+1);
4336     }
4337
4338     if (*mode == 'r') {             /* piping from subroutine */
4339
4340         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4341         if (info->out) {
4342             info->out->pipe_done = &info->out_done;
4343             info->out_done = FALSE;
4344             info->out->info = info;
4345         }
4346         if (!info->useFILE) {
4347             info->fp  = PerlIO_open(mbx, mode);
4348         } else {
4349             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4350             vmssetuserlnm("SYS$INPUT", mbx);
4351         }
4352
4353         if (!info->fp && info->out) {
4354             sys$cancel(info->out->chan_out);
4355
4356             while (!info->out_done) {
4357                 int done;
4358                 _ckvmssts_noperl(sys$setast(0));
4359                 done = info->out_done;
4360                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4361                 _ckvmssts_noperl(sys$setast(1));
4362                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4363             }
4364
4365             if (info->out->buf) {
4366                 n = info->out->bufsize * sizeof(char);
4367                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4368             }
4369             n = sizeof(Pipe);
4370             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4371             n = sizeof(Info);
4372             _ckvmssts_noperl(lib$free_vm(&n, &info));
4373             *psts = RMS$_FNF;
4374             return NULL;
4375         }
4376
4377         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4378         if (info->err) {
4379             info->err->pipe_done = &info->err_done;
4380             info->err_done = FALSE;
4381             info->err->info = info;
4382         }
4383
4384     } else if (*mode == 'w') {      /* piping to subroutine */
4385
4386         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4387         if (info->out) {
4388             info->out->pipe_done = &info->out_done;
4389             info->out_done = FALSE;
4390             info->out->info = info;
4391         }
4392
4393         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4394         if (info->err) {
4395             info->err->pipe_done = &info->err_done;
4396             info->err_done = FALSE;
4397             info->err->info = info;
4398         }
4399
4400         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4401         if (!info->useFILE) {
4402             info->fp  = PerlIO_open(mbx, mode);
4403         } else {
4404             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4405             vmssetuserlnm("SYS$OUTPUT", mbx);
4406         }
4407
4408         if (info->in) {
4409             info->in->pipe_done = &info->in_done;
4410             info->in_done = FALSE;
4411             info->in->info = info;
4412         }
4413
4414         /* error cleanup */
4415         if (!info->fp && info->in) {
4416             info->done = TRUE;
4417             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4418                                       0, 0, 0, 0, 0, 0, 0, 0));
4419
4420             while (!info->in_done) {
4421                 int done;
4422                 _ckvmssts_noperl(sys$setast(0));
4423                 done = info->in_done;
4424                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4425                 _ckvmssts_noperl(sys$setast(1));
4426                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4427             }
4428
4429             if (info->in->buf) {
4430                 n = info->in->bufsize * sizeof(char);
4431                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4432             }
4433             n = sizeof(Pipe);
4434             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4435             n = sizeof(Info);
4436             _ckvmssts_noperl(lib$free_vm(&n, &info));
4437             *psts = RMS$_FNF;
4438             return NULL;
4439         }
4440
4441
4442     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4443         /* Let the child inherit standard input, unless it's a directory. */
4444         Stat_t st;
4445         if (my_trnlnm("SYS$INPUT", in, 0)) {
4446             if (flex_stat(in, &st) != 0 || S_ISDIR(st.st_mode))
4447                 *in = '\0';
4448         }
4449
4450         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4451         if (info->out) {
4452             info->out->pipe_done = &info->out_done;
4453             info->out_done = FALSE;
4454             info->out->info = info;
4455         }
4456
4457         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4458         if (info->err) {
4459             info->err->pipe_done = &info->err_done;
4460             info->err_done = FALSE;
4461             info->err->info = info;
4462         }
4463     }
4464
4465     d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
4466     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4467
4468     d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
4469     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4470
4471     d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
4472     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4473
4474     /* Done with the names for the pipes */
4475     PerlMem_free(err);
4476     PerlMem_free(out);
4477     PerlMem_free(in);
4478
4479     p = vmscmd->dsc$a_pointer;
4480     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4481     if (*p == '$') p++;                         /* remove leading $ */
4482     while (*p == ' ' || *p == '\t') p++;
4483
4484     for (j = 0; j < 4; j++) {
4485         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4486         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4487
4488     d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
4489     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4490
4491         if (strlen(p) > MAX_DCL_SYMBOL) {
4492             p += MAX_DCL_SYMBOL;
4493         } else {
4494             p += strlen(p);
4495         }
4496     }
4497     _ckvmssts_noperl(sys$setast(0));
4498     info->next=open_pipes;  /* prepend to list */
4499     open_pipes=info;
4500     _ckvmssts_noperl(sys$setast(1));
4501     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4502      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4503      * have SYS$COMMAND if we need it.
4504      */
4505     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4506                       0, &info->pid, &info->completion,
4507                       0, popen_completion_ast,info,0,0,0));
4508
4509     /* if we were using a tempfile, close it now */
4510
4511     if (tpipe) fclose(tpipe);
4512
4513     /* once the subprocess is spawned, it has copied the symbols and
4514        we can get rid of ours */
4515
4516     for (j = 0; j < 4; j++) {
4517         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4518         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4519     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4520     }
4521     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4522     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4523     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4524     vms_execfree(vmscmd);
4525
4526 #ifdef PERL_IMPLICIT_CONTEXT
4527     if (aTHX)
4528 #endif
4529     PL_forkprocess = info->pid;
4530
4531     ret_fp = info->fp;
4532     if (wait) {
4533          dSAVEDERRNO;
4534          int done = 0;
4535          while (!done) {
4536              _ckvmssts_noperl(sys$setast(0));
4537              done = info->done;
4538              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4539              _ckvmssts_noperl(sys$setast(1));
4540              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4541          }
4542         *psts = info->completion;
4543 /* Caller thinks it is open and tries to close it. */
4544 /* This causes some problems, as it changes the error status */
4545 /*        my_pclose(info->fp); */
4546
4547          /* If we did not have a file pointer open, then we have to */
4548          /* clean up here or eventually we will run out of something */
4549          SAVE_ERRNO;
4550          if (info->fp == NULL) {
4551              my_pclose_pinfo(aTHX_ info);
4552          }
4553          RESTORE_ERRNO;
4554
4555     } else {
4556         *psts = info->pid;
4557     }
4558     return ret_fp;
4559 }  /* end of safe_popen */
4560
4561
4562 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4563 PerlIO *
4564 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4565 {
4566     int sts;
4567     TAINT_ENV();
4568     TAINT_PROPER("popen");
4569     PERL_FLUSHALL_FOR_CHILD;
4570     return safe_popen(aTHX_ cmd,mode,&sts);
4571 }
4572
4573 /*}}}*/
4574
4575
4576 /* Routine to close and cleanup a pipe info structure */
4577
4578 static I32
4579 my_pclose_pinfo(pTHX_ pInfo info) {
4580
4581     unsigned long int retsts;
4582     int done, n;
4583     pInfo next, last;
4584
4585     /* If we were writing to a subprocess, insure that someone reading from
4586      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4587      * produce an EOF record in the mailbox.
4588      *
4589      *  well, at least sometimes it *does*, so we have to watch out for
4590      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4591      */
4592      if (info->fp) {
4593         if (!info->useFILE
4594 #if defined(USE_ITHREADS)
4595           && my_perl
4596 #endif
4597 #ifdef USE_PERLIO
4598           && PL_perlio_fd_refcnt
4599 #endif
4600            )
4601             PerlIO_flush(info->fp);
4602         else
4603             fflush((FILE *)info->fp);
4604     }
4605
4606     _ckvmssts(sys$setast(0));
4607      info->closing = TRUE;
4608      done = info->done && info->in_done && info->out_done && info->err_done;
4609      /* hanging on write to Perl's input? cancel it */
4610      if (info->mode == 'r' && info->out && !info->out_done) {
4611         if (info->out->chan_out) {
4612             _ckvmssts(sys$cancel(info->out->chan_out));
4613             if (!info->out->chan_in) {   /* EOF generation, need AST */
4614                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4615             }
4616         }
4617      }
4618      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4619          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4620                            0, 0, 0, 0, 0, 0));
4621     _ckvmssts(sys$setast(1));
4622     if (info->fp) {
4623      if (!info->useFILE
4624 #if defined(USE_ITHREADS)
4625          && my_perl
4626 #endif
4627 #ifdef USE_PERLIO
4628          && PL_perlio_fd_refcnt
4629 #endif
4630         )
4631         PerlIO_close(info->fp);
4632      else
4633         fclose((FILE *)info->fp);
4634     }
4635      /*
4636         we have to wait until subprocess completes, but ALSO wait until all
4637         the i/o completes...otherwise we'll be freeing the "info" structure
4638         that the i/o ASTs could still be using...
4639      */
4640
4641      while (!done) {
4642          _ckvmssts(sys$setast(0));
4643          done = info->done && info->in_done && info->out_done && info->err_done;
4644          if (!done) _ckvmssts(sys$clref(pipe_ef));
4645          _ckvmssts(sys$setast(1));
4646          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4647      }
4648      retsts = info->completion;
4649
4650     /* remove from list of open pipes */
4651     _ckvmssts(sys$setast(0));
4652     last = NULL;
4653     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4654         if (next == info)
4655             break;
4656     }
4657
4658     if (last)
4659         last->next = info->next;
4660     else
4661         open_pipes = info->next;
4662     _ckvmssts(sys$setast(1));
4663
4664     /* free buffers and structures */
4665
4666     if (info->in) {
4667         if (info->in->buf) {
4668             n = info->in->bufsize * sizeof(char);
4669             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4670         }
4671         n = sizeof(Pipe);
4672         _ckvmssts(lib$free_vm(&n, &info->in));
4673     }
4674     if (info->out) {
4675         if (info->out->buf) {
4676             n = info->out->bufsize * sizeof(char);
4677             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4678         }
4679         n = sizeof(Pipe);
4680         _ckvmssts(lib$free_vm(&n, &info->out));
4681     }
4682     if (info->err) {
4683         if (info->err->buf) {
4684             n = info->err->bufsize * sizeof(char);
4685             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4686         }
4687         n = sizeof(Pipe);
4688         _ckvmssts(lib$free_vm(&n, &info->err));
4689     }
4690     n = sizeof(Info);
4691     _ckvmssts(lib$free_vm(&n, &info));
4692
4693     return retsts;
4694 }
4695
4696
4697 /*{{{  I32 my_pclose(PerlIO *fp)*/
4698 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4699 {
4700     pInfo info, last = NULL;
4701     I32 ret_status;
4702
4703     /* Fixme - need ast and mutex protection here */
4704     for (info = open_pipes; info != NULL; last = info, info = info->next)
4705         if (info->fp == fp) break;
4706
4707     if (info == NULL) {  /* no such pipe open */
4708       set_errno(ECHILD); /* quoth POSIX */
4709       set_vaxc_errno(SS$_NONEXPR);
4710       return -1;
4711     }
4712
4713     ret_status = my_pclose_pinfo(aTHX_ info);
4714
4715     return ret_status;
4716
4717 }  /* end of my_pclose() */
4718
4719   /* Roll our own prototype because we want this regardless of whether
4720    * _VMS_WAIT is defined.
4721    */
4722
4723 #ifdef __cplusplus
4724 extern "C" {
4725 #endif
4726   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4727 #ifdef __cplusplus
4728 }
4729 #endif
4730
4731 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4732    created with popen(); otherwise partially emulate waitpid() unless
4733    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4734    Also check processes not considered by the CRTL waitpid().
4735  */
4736 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4737 Pid_t
4738 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4739 {
4740     pInfo info;
4741     int done;
4742     int sts;
4743     int j;
4744
4745     if (statusp) *statusp = 0;
4746
4747     for (info = open_pipes; info != NULL; info = info->next)
4748         if (info->pid == pid) break;
4749
4750     if (info != NULL) {  /* we know about this child */
4751       while (!info->done) {
4752           _ckvmssts(sys$setast(0));
4753           done = info->done;
4754           if (!done) _ckvmssts(sys$clref(pipe_ef));
4755           _ckvmssts(sys$setast(1));
4756           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4757       }
4758
4759       if (statusp) *statusp = info->completion;
4760       return pid;
4761     }
4762
4763     /* child that already terminated? */
4764
4765     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4766         if (closed_list[j].pid == pid) {
4767             if (statusp) *statusp = closed_list[j].completion;
4768             return pid;
4769         }
4770     }
4771
4772     /* fall through if this child is not one of our own pipe children */
4773
4774       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4775        * in 7.2 did we get a version that fills in the VMS completion
4776        * status as Perl has always tried to do.
4777        */
4778
4779       sts = __vms_waitpid( pid, statusp, flags );
4780
4781       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4782          return sts;
4783
4784       /* If the real waitpid tells us the child does not exist, we
4785        * fall through here to implement waiting for a child that
4786        * was created by some means other than exec() (say, spawned
4787        * from DCL) or to wait for a process that is not a subprocess
4788        * of the current process.
4789        */
4790
4791     {
4792       $DESCRIPTOR(intdsc,"0 00:00:01");
4793       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4794       unsigned long int pidcode = JPI$_PID, mypid;
4795       unsigned long int interval[2];
4796       unsigned int jpi_iosb[2];
4797       struct itmlst_3 jpilist[2] = {
4798           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4799           {                      0,         0,                 0, 0}
4800       };
4801
4802       if (pid <= 0) {
4803         /* Sorry folks, we don't presently implement rooting around for
4804            the first child we can find, and we definitely don't want to
4805            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4806          */
4807         set_errno(ENOTSUP);
4808         return -1;
4809       }
4810
4811       /* Get the owner of the child so I can warn if it's not mine. If the
4812        * process doesn't exist or I don't have the privs to look at it,
4813        * I can go home early.
4814        */
4815       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4816       if (sts & 1) sts = jpi_iosb[0];
4817       if (!(sts & 1)) {
4818         switch (sts) {
4819             case SS$_NONEXPR:
4820                 set_errno(ECHILD);
4821                 break;
4822             case SS$_NOPRIV:
4823                 set_errno(EACCES);
4824                 break;
4825             default:
4826                 _ckvmssts(sts);
4827         }
4828         set_vaxc_errno(sts);
4829         return -1;
4830       }
4831
4832       if (ckWARN(WARN_EXEC)) {
4833         /* remind folks they are asking for non-standard waitpid behavior */
4834         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4835         if (ownerpid != mypid)
4836           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4837                       "waitpid: process %x is not a child of process %x",
4838                       pid,mypid);
4839       }
4840
4841       /* simply check on it once a second until it's not there anymore. */
4842
4843       _ckvmssts(sys$bintim(&intdsc,interval));
4844       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4845             _ckvmssts(sys$schdwk(0,0,interval,0));
4846             _ckvmssts(sys$hiber());
4847       }
4848       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4849
4850       _ckvmssts(sts);
4851       return pid;
4852     }
4853 }  /* end of waitpid() */
4854 /*}}}*/
4855 /*}}}*/
4856 /*}}}*/
4857
4858 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4859 char *
4860 my_gconvert(double val, int ndig, int trail, char *buf)
4861 {
4862   static char __gcvtbuf[DBL_DIG+1];
4863   char *loc;
4864
4865   loc = buf ? buf : __gcvtbuf;
4866
4867   if (val) {
4868     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4869     return gcvt(val,ndig,loc);
4870   }
4871   else {
4872     loc[0] = '0'; loc[1] = '\0';
4873     return loc;
4874   }
4875
4876 }
4877 /*}}}*/
4878
4879 #if !defined(NAML$C_MAXRSS)
4880 static int
4881 rms_free_search_context(struct FAB * fab)
4882 {
4883     struct NAM * nam;
4884
4885     nam = fab->fab$l_nam;
4886     nam->nam$b_nop |= NAM$M_SYNCHK;
4887     nam->nam$l_rlf = NULL;
4888     fab->fab$b_dns = 0;
4889     return sys$parse(fab, NULL, NULL);
4890 }
4891
4892 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4893 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4894 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4895 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4896 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4897 #define rms_nam_esll(nam) nam.nam$b_esl
4898 #define rms_nam_esl(nam) nam.nam$b_esl
4899 #define rms_nam_name(nam) nam.nam$l_name
4900 #define rms_nam_namel(nam) nam.nam$l_name
4901 #define rms_nam_type(nam) nam.nam$l_type
4902 #define rms_nam_typel(nam) nam.nam$l_type
4903 #define rms_nam_ver(nam) nam.nam$l_ver
4904 #define rms_nam_verl(nam) nam.nam$l_ver
4905 #define rms_nam_rsll(nam) nam.nam$b_rsl
4906 #define rms_nam_rsl(nam) nam.nam$b_rsl
4907 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4908 #define rms_set_fna(fab, nam, name, size) \
4909         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4910 #define rms_get_fna(fab, nam) fab.fab$l_fna
4911 #define rms_set_dna(fab, nam, name, size) \
4912         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4913 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4914 #define rms_set_esa(nam, name, size) \
4915         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4916 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4917         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4918 #define rms_set_rsa(nam, name, size) \
4919         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4920 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4921         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4922 #define rms_nam_name_type_l_size(nam) \
4923         (nam.nam$b_name + nam.nam$b_type)
4924 #else
4925 static int
4926 rms_free_search_context(struct FAB * fab)
4927 {
4928     struct NAML * nam;
4929
4930     nam = fab->fab$l_naml;
4931     nam->naml$b_nop |= NAM$M_SYNCHK;
4932     nam->naml$l_rlf = NULL;
4933     nam->naml$l_long_defname_size = 0;
4934
4935     fab->fab$b_dns = 0;
4936     return sys$parse(fab, NULL, NULL);
4937 }
4938
4939 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4940 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4941 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4942 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4943 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4944 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4945 #define rms_nam_esl(nam) nam.naml$b_esl
4946 #define rms_nam_name(nam) nam.naml$l_name
4947 #define rms_nam_namel(nam) nam.naml$l_long_name
4948 #define rms_nam_type(nam) nam.naml$l_type
4949 #define rms_nam_typel(nam) nam.naml$l_long_type
4950 #define rms_nam_ver(nam) nam.naml$l_ver
4951 #define rms_nam_verl(nam) nam.naml$l_long_ver
4952 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4953 #define rms_nam_rsl(nam) nam.naml$b_rsl
4954 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4955 #define rms_set_fna(fab, nam, name, size) \
4956         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4957         nam.naml$l_long_filename_size = size; \
4958         nam.naml$l_long_filename = name;}
4959 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4960 #define rms_set_dna(fab, nam, name, size) \
4961         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4962         nam.naml$l_long_defname_size = size; \
4963         nam.naml$l_long_defname = name; }
4964 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4965 #define rms_set_esa(nam, name, size) \
4966         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4967         nam.naml$l_long_expand_alloc = size; \
4968         nam.naml$l_long_expand = name; }
4969 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4970         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4971         nam.naml$l_long_expand = l_name; \
4972         nam.naml$l_long_expand_alloc = l_size; }
4973 #define rms_set_rsa(nam, name, size) \
4974         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4975         nam.naml$l_long_result = name; \
4976         nam.naml$l_long_result_alloc = size; }
4977 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4978         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4979         nam.naml$l_long_result = l_name; \
4980         nam.naml$l_long_result_alloc = l_size; }
4981 #define rms_nam_name_type_l_size(nam) \
4982         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4983 #endif
4984
4985
4986 /* rms_erase
4987  * The CRTL for 8.3 and later can create symbolic links in any mode,
4988  * however in 8.3 the unlink/remove/delete routines will only properly handle
4989  * them if one of the PCP modes is active.
4990  */
4991 static int
4992 rms_erase(const char * vmsname)
4993 {
4994   int status;
4995   struct FAB myfab = cc$rms_fab;
4996   rms_setup_nam(mynam);
4997
4998   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4999   rms_bind_fab_nam(myfab, mynam);
5000
5001 #ifdef NAML$M_OPEN_SPECIAL
5002   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5003 #endif
5004
5005   status = sys$erase(&myfab, 0, 0);
5006
5007   return status;
5008 }
5009
5010
5011 static int
5012 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5013                     const struct dsc$descriptor_s * vms_dst_dsc,
5014                     unsigned long flags)
5015 {
5016     /*  VMS and UNIX handle file permissions differently and the
5017      * the same ACL trick may be needed for renaming files,
5018      * especially if they are directories.
5019      */
5020
5021    /* todo: get kill_file and rename to share common code */
5022    /* I can not find online documentation for $change_acl
5023     * it appears to be replaced by $set_security some time ago */
5024
5025     const unsigned int access_mode = 0;
5026     $DESCRIPTOR(obj_file_dsc,"FILE");
5027     char *vmsname;
5028     char *rslt;
5029     unsigned long int jpicode = JPI$_UIC;
5030     int aclsts, fndsts, rnsts = -1;
5031     unsigned int ctx = 0;
5032     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5033     struct dsc$descriptor_s * clean_dsc;
5034
5035     struct myacedef {
5036         unsigned char myace$b_length;
5037         unsigned char myace$b_type;
5038         unsigned short int myace$w_flags;
5039         unsigned long int myace$l_access;
5040         unsigned long int myace$l_ident;
5041     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5042              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5043              0},
5044              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5045
5046     struct item_list_3
5047         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5048                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5049                       {0,0,0,0}},
5050         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5051         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5052                      {0,0,0,0}};
5053
5054
5055     /* Expand the input spec using RMS, since we do not want to put
5056      * ACLs on the target of a symbolic link */
5057     vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
5058     if (vmsname == NULL)
5059         return SS$_INSFMEM;
5060
5061     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5062                         vmsname,
5063                         PERL_RMSEXPAND_M_SYMLINK);
5064     if (rslt == NULL) {
5065         PerlMem_free(vmsname);
5066         return SS$_INSFMEM;
5067     }
5068
5069     /* So we get our own UIC to use as a rights identifier,
5070      * and the insert an ACE at the head of the ACL which allows us
5071      * to delete the file.
5072      */
5073     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5074
5075     fildsc.dsc$w_length = strlen(vmsname);
5076     fildsc.dsc$a_pointer = vmsname;
5077     ctx = 0;
5078     newace.myace$l_ident = oldace.myace$l_ident;
5079     rnsts = SS$_ABORT;
5080
5081     /* Grab any existing ACEs with this identifier in case we fail */
5082     clean_dsc = &fildsc;
5083     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5084                                &fildsc,
5085                                NULL,
5086                                OSS$M_WLOCK,
5087                                findlst,
5088                                &ctx,
5089                                &access_mode);
5090
5091     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5092         /* Add the new ACE . . . */
5093
5094         /* if the sys$get_security succeeded, then ctx is valid, and the
5095          * object/file descriptors will be ignored.  But otherwise they
5096          * are needed
5097          */
5098         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5099                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5100         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5101             set_errno(EVMSERR);
5102             set_vaxc_errno(aclsts);
5103             PerlMem_free(vmsname);
5104             return aclsts;
5105         }
5106
5107         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5108                                 NULL, NULL,
5109                                 &flags,
5110                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5111
5112         if ($VMS_STATUS_SUCCESS(rnsts)) {
5113             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5114         }
5115
5116         /* Put things back the way they were. */
5117         ctx = 0;
5118         aclsts = sys$get_security(&obj_file_dsc,
5119                                   clean_dsc,
5120                                   NULL,
5121                                   OSS$M_WLOCK,
5122                                   findlst,
5123                                   &ctx,
5124                                   &access_mode);
5125
5126         if ($VMS_STATUS_SUCCESS(aclsts)) {
5127         int sec_flags;
5128
5129             sec_flags = 0;
5130             if (!$VMS_STATUS_SUCCESS(fndsts))
5131                 sec_flags = OSS$M_RELCTX;
5132
5133             /* Get rid of the new ACE */
5134             aclsts = sys$set_security(NULL, NULL, NULL,
5135                                   sec_flags, dellst, &ctx, &access_mode);
5136
5137             /* If there was an old ACE, put it back */
5138             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5139                 addlst[0].bufadr = &oldace;
5140                 aclsts = sys$set_security(NULL, NULL, NULL,
5141                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5142                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5143                     set_errno(EVMSERR);
5144                     set_vaxc_errno(aclsts);
5145                     rnsts = aclsts;
5146                 }
5147             } else {
5148             int aclsts2;
5149
5150                 /* Try to clear the lock on the ACL list */
5151                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5152                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5153
5154                 /* Rename errors are most important */
5155                 if (!$VMS_STATUS_SUCCESS(rnsts))
5156                     aclsts = rnsts;
5157                 set_errno(EVMSERR);
5158                 set_vaxc_errno(aclsts);
5159                 rnsts = aclsts;
5160             }
5161         }
5162         else {
5163             if (aclsts != SS$_ACLEMPTY)
5164                 rnsts = aclsts;
5165         }
5166     }
5167     else
5168         rnsts = fndsts;
5169
5170     PerlMem_free(vmsname);
5171     return rnsts;
5172 }
5173
5174
5175 /*{{{int rename(const char *, const char * */
5176 /* Not exactly what X/Open says to do, but doing it absolutely right
5177  * and efficiently would require a lot more work.  This should be close
5178  * enough to pass all but the most strict X/Open compliance test.
5179  */
5180 int
5181 Perl_rename(pTHX_ const char *src, const char * dst)
5182 {
5183     int retval;
5184     int pre_delete = 0;
5185     int src_sts;
5186     int dst_sts;
5187     Stat_t src_st;
5188     Stat_t dst_st;
5189
5190     /* Validate the source file */
5191     src_sts = flex_lstat(src, &src_st);
5192     if (src_sts != 0) {
5193
5194         /* No source file or other problem */
5195         return src_sts;
5196     }
5197     if (src_st.st_devnam[0] == 0)  {
5198         /* This may be possible so fail if it is seen. */
5199         errno = EIO;
5200         return -1;
5201     }
5202
5203     dst_sts = flex_lstat(dst, &dst_st);
5204     if (dst_sts == 0) {
5205
5206         if (dst_st.st_dev != src_st.st_dev) {
5207             /* Must be on the same device */
5208             errno = EXDEV;
5209             return -1;
5210         }
5211
5212         /* VMS_INO_T_COMPARE is true if the inodes are different
5213          * to match the output of memcmp
5214          */
5215
5216         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5217             /* That was easy, the files are the same! */
5218             return 0;
5219         }
5220
5221         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5222             /* If source is a directory, so must be dest */
5223                 errno = EISDIR;
5224                 return -1;
5225         }
5226
5227     }
5228
5229
5230     if ((dst_sts == 0) &&
5231         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5232
5233         /* We have issues here if vms_unlink_all_versions is set
5234          * If the destination exists, and is not a directory, then
5235          * we must delete in advance.
5236          *
5237          * If the src is a directory, then we must always pre-delete
5238          * the destination.
5239          *
5240          * If we successfully delete the dst in advance, and the rename fails
5241          * X/Open requires that errno be EIO.
5242          *
5243          */
5244
5245         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5246             int d_sts;
5247             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5248                                      S_ISDIR(dst_st.st_mode));
5249
5250            /* Need to delete all versions ? */
5251            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5252                 int i = 0;
5253
5254                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5255                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5256                     if (d_sts != 0)
5257                         break;
5258                     i++;
5259
5260                     /* Make sure that we do not loop forever */
5261                     if (i > 32767) {
5262                         errno = EIO;
5263                         d_sts = -1;
5264                         break;
5265                     }
5266                 }
5267            }
5268
5269             if (d_sts != 0)
5270                 return d_sts;
5271
5272             /* We killed the destination, so only errno now is EIO */
5273             pre_delete = 1;
5274         }
5275     }
5276
5277     /* Originally the idea was to call the CRTL rename() and only
5278      * try the lib$rename_file if it failed.
5279      * It turns out that there are too many variants in what the
5280      * the CRTL rename might do, so only use lib$rename_file
5281      */
5282     retval = -1;
5283
5284     {
5285         /* Is the source and dest both in VMS format */
5286         /* if the source is a directory, then need to fileify */
5287         /*  and dest must be a directory or non-existent. */
5288
5289         char * vms_dst;
5290         int sts;
5291         char * ret_str;
5292         unsigned long flags;
5293         struct dsc$descriptor_s old_file_dsc;
5294         struct dsc$descriptor_s new_file_dsc;
5295
5296         /* We need to modify the src and dst depending
5297          * on if one or more of them are directories.
5298          */
5299
5300         vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
5301         if (vms_dst == NULL)
5302             _ckvmssts_noperl(SS$_INSFMEM);
5303
5304         if (S_ISDIR(src_st.st_mode)) {
5305         char * ret_str;
5306         char * vms_dir_file;
5307
5308             vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
5309             if (vms_dir_file == NULL)
5310                 _ckvmssts_noperl(SS$_INSFMEM);
5311
5312             /* If the dest is a directory, we must remove it */
5313             if (dst_sts == 0) {
5314                 int d_sts;
5315                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5316                 if (d_sts != 0) {
5317                     PerlMem_free(vms_dst);
5318                     errno = EIO;
5319                     return d_sts;
5320                 }
5321
5322                 pre_delete = 1;
5323             }
5324
5325            /* The dest must be a VMS file specification */
5326            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5327            if (ret_str == NULL) {
5328                 PerlMem_free(vms_dst);
5329                 errno = EIO;
5330                 return -1;
5331            }
5332
5333             /* The source must be a file specification */
5334             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5335             if (ret_str == NULL) {
5336                 PerlMem_free(vms_dst);
5337                 PerlMem_free(vms_dir_file);
5338                 errno = EIO;
5339                 return -1;
5340             }
5341             PerlMem_free(vms_dst);
5342             vms_dst = vms_dir_file;
5343
5344         } else {
5345             /* File to file or file to new dir */
5346
5347             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5348                 /* VMS pathify a dir target */
5349                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5350                 if (ret_str == NULL) {
5351                     PerlMem_free(vms_dst);
5352                     errno = EIO;
5353                     return -1;
5354                 }
5355             } else {
5356                 char * v_spec, * r_spec, * d_spec, * n_spec;
5357                 char * e_spec, * vs_spec;
5358                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5359
5360                 /* fileify a target VMS file specification */
5361                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5362                 if (ret_str == NULL) {
5363                     PerlMem_free(vms_dst);
5364                     errno = EIO;
5365                     return -1;
5366                 }
5367
5368                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5369                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5370                              &e_len, &vs_spec, &vs_len);
5371                 if (sts == 0) {
5372                      if (e_len == 0) {
5373                          /* Get rid of the version */
5374                          if (vs_len != 0) {
5375                              *vs_spec = '\0';
5376                          }
5377                          /* Need to specify a '.' so that the extension */
5378                          /* is not inherited */
5379                          strcat(vms_dst,".");
5380                      }
5381                 }
5382             }
5383         }
5384
5385         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5386         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5387         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5388         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5389
5390         new_file_dsc.dsc$a_pointer = vms_dst;
5391         new_file_dsc.dsc$w_length = strlen(vms_dst);
5392         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5393         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5394
5395         flags = 0;
5396 #if defined(NAML$C_MAXRSS)
5397         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5398 #endif
5399
5400         sts = lib$rename_file(&old_file_dsc,
5401                               &new_file_dsc,
5402                               NULL, NULL,
5403                               &flags,
5404                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5405         if (!$VMS_STATUS_SUCCESS(sts)) {
5406
5407            /* We could have failed because VMS style permissions do not
5408             * permit renames that UNIX will allow.  Just like the hack
5409             * in for kill_file.
5410             */
5411            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5412         }
5413
5414         PerlMem_free(vms_dst);
5415         if (!$VMS_STATUS_SUCCESS(sts)) {
5416             errno = EIO;
5417             return -1;
5418         }
5419         retval = 0;
5420     }
5421
5422     if (vms_unlink_all_versions) {
5423         /* Now get rid of any previous versions of the source file that
5424          * might still exist
5425          */
5426         int i = 0;
5427         dSAVEDERRNO;
5428         SAVE_ERRNO;
5429         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5430                                    S_ISDIR(src_st.st_mode));
5431         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5432              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5433                                        S_ISDIR(src_st.st_mode));
5434              if (src_sts != 0)
5435                  break;
5436              i++;
5437
5438              /* Make sure that we do not loop forever */
5439              if (i > 32767) {
5440                  src_sts = -1;
5441                  break;
5442              }
5443         }
5444         RESTORE_ERRNO;
5445     }
5446
5447     /* We deleted the destination, so must force the error to be EIO */
5448     if ((retval != 0) && (pre_delete != 0))
5449         errno = EIO;
5450
5451     return retval;
5452 }
5453 /*}}}*/
5454
5455
5456 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5457 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5458  * to expand file specification.  Allows for a single default file
5459  * specification and a simple mask of options.  If outbuf is non-NULL,
5460  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5461  * the resultant file specification is placed.  If outbuf is NULL, the
5462  * resultant file specification is placed into a static buffer.
5463  * The third argument, if non-NULL, is taken to be a default file
5464  * specification string.  The fourth argument is unused at present.
5465  * rmesexpand() returns the address of the resultant string if
5466  * successful, and NULL on error.
5467  *
5468  * New functionality for previously unused opts value:
5469  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5470  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5471  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5472  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5473  */
5474 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5475
5476 static char *
5477 int_rmsexpand
5478    (const char *filespec,
5479     char *outbuf,
5480     const char *defspec,
5481     unsigned opts,
5482     int * fs_utf8,
5483     int * dfs_utf8)
5484 {
5485   char * ret_spec;
5486   const char * in_spec;
5487   char * spec_buf;
5488   const char * def_spec;
5489   char * vmsfspec, *vmsdefspec;
5490   char * esa;
5491   char * esal = NULL;
5492   char * outbufl;
5493   struct FAB myfab = cc$rms_fab;
5494   rms_setup_nam(mynam);
5495   STRLEN speclen;
5496   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5497   int sts;
5498
5499   /* temp hack until UTF8 is actually implemented */
5500   if (fs_utf8 != NULL)
5501     *fs_utf8 = 0;
5502
5503   if (!filespec || !*filespec) {
5504     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5505     return NULL;
5506   }
5507
5508   vmsfspec = NULL;
5509   vmsdefspec = NULL;
5510   outbufl = NULL;
5511
5512   in_spec = filespec;
5513   isunix = 0;
5514   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5515       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5516       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5517
5518       /* If this is a UNIX file spec, convert it to VMS */
5519       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5520                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5521                            &e_len, &vs_spec, &vs_len);
5522       if (sts != 0) {
5523           isunix = 1;
5524           char * ret_spec;
5525
5526           vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5527           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5528           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5529           if (ret_spec == NULL) {
5530               PerlMem_free(vmsfspec);
5531               return NULL;
5532           }
5533           in_spec = (const char *)vmsfspec;
5534
5535           /* Unless we are forcing to VMS format, a UNIX input means
5536            * UNIX output, and that requires long names to be used
5537            */
5538           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5539 #if defined(NAML$C_MAXRSS)
5540               opts |= PERL_RMSEXPAND_M_LONG;
5541 #else
5542               NOOP;
5543 #endif
5544           else
5545               isunix = 0;
5546       }
5547
5548   }
5549
5550   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5551   rms_bind_fab_nam(myfab, mynam);
5552
5553   /* Process the default file specification if present */
5554   def_spec = defspec;
5555   if (defspec && *defspec) {
5556     int t_isunix;
5557     t_isunix = is_unix_filespec(defspec);
5558     if (t_isunix) {
5559       vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
5560       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5561       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5562
5563       if (ret_spec == NULL) {
5564           /* Clean up and bail */
5565           PerlMem_free(vmsdefspec);
5566           if (vmsfspec != NULL)
5567               PerlMem_free(vmsfspec);
5568               return NULL;
5569           }
5570           def_spec = (const char *)vmsdefspec;
5571       }
5572       rms_set_dna(myfab, mynam,
5573                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5574   }
5575
5576   /* Now we need the expansion buffers */
5577   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
5578   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5579 #if defined(NAML$C_MAXRSS)
5580   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
5581   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5582 #endif
5583   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5584
5585   /* If a NAML block is used RMS always writes to the long and short
5586    * addresses unless you suppress the short name.
5587    */
5588 #if defined(NAML$C_MAXRSS)
5589   outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
5590   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5591 #endif
5592    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5593
5594 #ifdef NAM$M_NO_SHORT_UPCASE
5595   if (DECC_EFS_CASE_PRESERVE)
5596     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5597 #endif
5598
5599    /* We may not want to follow symbolic links */
5600 #ifdef NAML$M_OPEN_SPECIAL
5601   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5602     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5603 #endif
5604
5605   /* First attempt to parse as an existing file */
5606   retsts = sys$parse(&myfab,0,0);
5607   if (!(retsts & STS$K_SUCCESS)) {
5608
5609     /* Could not find the file, try as syntax only if error is not fatal */
5610     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5611     if (retsts == RMS$_DNF ||
5612         retsts == RMS$_DIR ||
5613         retsts == RMS$_DEV ||
5614         retsts == RMS$_PRV) {
5615       retsts = sys$parse(&myfab,0,0);
5616       if (retsts & STS$K_SUCCESS) goto int_expanded;
5617     }
5618
5619      /* Still could not parse the file specification */
5620     /*----------------------------------------------*/
5621     sts = rms_free_search_context(&myfab); /* Free search context */
5622     if (vmsdefspec != NULL)
5623         PerlMem_free(vmsdefspec);
5624     if (vmsfspec != NULL)
5625         PerlMem_free(vmsfspec);
5626     if (outbufl != NULL)
5627         PerlMem_free(outbufl);
5628     PerlMem_free(esa);
5629     if (esal != NULL)
5630         PerlMem_free(esal);
5631     set_vaxc_errno(retsts);
5632     if      (retsts == RMS$_PRV) set_errno(EACCES);
5633     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5634     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5635     else                         set_errno(EVMSERR);
5636     return NULL;
5637   }
5638   retsts = sys$search(&myfab,0,0);
5639   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5640     sts = rms_free_search_context(&myfab); /* Free search context */
5641     if (vmsdefspec != NULL)
5642         PerlMem_free(vmsdefspec);
5643     if (vmsfspec != NULL)
5644         PerlMem_free(vmsfspec);
5645     if (outbufl != NULL)
5646         PerlMem_free(outbufl);
5647     PerlMem_free(esa);
5648     if (esal != NULL)
5649         PerlMem_free(esal);
5650     set_vaxc_errno(retsts);
5651     if      (retsts == RMS$_PRV) set_errno(EACCES);
5652     else                         set_errno(EVMSERR);
5653     return NULL;
5654   }
5655
5656   /* If the input filespec contained any lowercase characters,
5657    * downcase the result for compatibility with Unix-minded code. */
5658 int_expanded:
5659   if (!DECC_EFS_CASE_PRESERVE) {
5660     char * tbuf;
5661     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5662       if (islower(*tbuf)) { haslower = 1; break; }
5663   }
5664
5665    /* Is a long or a short name expected */
5666   /*------------------------------------*/
5667   spec_buf = NULL;
5668 #if defined(NAML$C_MAXRSS)
5669   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5670     if (rms_nam_rsll(mynam)) {
5671         spec_buf = outbufl;
5672         speclen = rms_nam_rsll(mynam);
5673     }
5674     else {
5675         spec_buf = esal; /* Not esa */
5676         speclen = rms_nam_esll(mynam);
5677     }
5678   }
5679   else {
5680 #endif
5681     if (rms_nam_rsl(mynam)) {
5682         spec_buf = outbuf;
5683         speclen = rms_nam_rsl(mynam);
5684     }
5685     else {
5686         spec_buf = esa; /* Not esal */
5687         speclen = rms_nam_esl(mynam);
5688     }
5689 #if defined(NAML$C_MAXRSS)
5690   }
5691 #endif
5692   spec_buf[speclen] = '\0';
5693
5694   /* Trim off null fields added by $PARSE
5695    * If type > 1 char, must have been specified in original or default spec
5696    * (not true for version; $SEARCH may have added version of existing file).
5697    */
5698   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5699   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5700     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5701              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5702   }
5703   else {
5704     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5705              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5706   }
5707   if (trimver || trimtype) {
5708     if (defspec && *defspec) {
5709       char *defesal = NULL;
5710       char *defesa = NULL;
5711       defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5712       if (defesa != NULL) {
5713         struct FAB deffab = cc$rms_fab;
5714 #if defined(NAML$C_MAXRSS)
5715         defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
5716         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5717 #endif
5718         rms_setup_nam(defnam);
5719
5720         rms_bind_fab_nam(deffab, defnam);
5721
5722         /* Cast ok */
5723         rms_set_fna
5724             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5725
5726         /* RMS needs the esa/esal as a work area if wildcards are involved */
5727         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5728
5729         rms_clear_nam_nop(defnam);
5730         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5731 #ifdef NAM$M_NO_SHORT_UPCASE
5732         if (DECC_EFS_CASE_PRESERVE)
5733           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5734 #endif
5735 #ifdef NAML$M_OPEN_SPECIAL
5736         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5737           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5738 #endif
5739         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5740           if (trimver) {
5741              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5742           }
5743           if (trimtype) {
5744             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5745           }
5746         }
5747         if (defesal != NULL)
5748             PerlMem_free(defesal);
5749         PerlMem_free(defesa);
5750       } else {
5751           _ckvmssts_noperl(SS$_INSFMEM);
5752       }
5753     }
5754     if (trimver) {
5755       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5756         if (*(rms_nam_verl(mynam)) != '\"')
5757           speclen = rms_nam_verl(mynam) - spec_buf;
5758       }
5759       else {
5760         if (*(rms_nam_ver(mynam)) != '\"')
5761           speclen = rms_nam_ver(mynam) - spec_buf;
5762       }
5763     }
5764     if (trimtype) {
5765       /* If we didn't already trim version, copy down */
5766       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5767         if (speclen > rms_nam_verl(mynam) - spec_buf)
5768           memmove
5769            (rms_nam_typel(mynam),
5770             rms_nam_verl(mynam),
5771             speclen - (rms_nam_verl(mynam) - spec_buf));
5772           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5773       }
5774       else {
5775         if (speclen > rms_nam_ver(mynam) - spec_buf)
5776           memmove
5777            (rms_nam_type(mynam),
5778             rms_nam_ver(mynam),
5779             speclen - (rms_nam_ver(mynam) - spec_buf));
5780           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5781       }
5782     }
5783   }
5784
5785    /* Done with these copies of the input files */
5786   /*-------------------------------------------*/
5787   if (vmsfspec != NULL)
5788         PerlMem_free(vmsfspec);
5789   if (vmsdefspec != NULL)
5790         PerlMem_free(vmsdefspec);
5791
5792   /* If we just had a directory spec on input, $PARSE "helpfully"
5793    * adds an empty name and type for us */
5794 #if defined(NAML$C_MAXRSS)
5795   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5796     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5797         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5798         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5799       speclen = rms_nam_namel(mynam) - spec_buf;
5800   }
5801   else
5802 #endif
5803   {
5804     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5805         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5806         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5807       speclen = rms_nam_name(mynam) - spec_buf;
5808   }
5809
5810   /* Posix format specifications must have matching quotes */
5811   if (speclen < (VMS_MAXRSS - 1)) {
5812     if (DECC_POSIX_COMPLIANT_PATHNAMES && (spec_buf[0] == '\"')) {
5813       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5814         spec_buf[speclen] = '\"';
5815         speclen++;
5816       }
5817     }
5818   }
5819   spec_buf[speclen] = '\0';
5820   if (haslower && !DECC_EFS_CASE_PRESERVE) __mystrtolower(spec_buf);
5821
5822   /* Have we been working with an expanded, but not resultant, spec? */
5823   /* Also, convert back to Unix syntax if necessary. */
5824   {
5825   int rsl;
5826
5827 #if defined(NAML$C_MAXRSS)
5828     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5829       rsl = rms_nam_rsll(mynam);
5830     } else
5831 #endif
5832     {
5833       rsl = rms_nam_rsl(mynam);
5834     }
5835     if (!rsl) {
5836       /* rsl is not present, it means that spec_buf is either */
5837       /* esa or esal, and needs to be copied to outbuf */
5838       /* convert to Unix if desired */
5839       if (isunix) {
5840         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5841       } else {
5842         /* VMS file specs are not in UTF-8 */
5843         if (fs_utf8 != NULL)
5844             *fs_utf8 = 0;
5845         my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5846         ret_spec = outbuf;
5847       }
5848     }
5849     else {
5850       /* Now spec_buf is either outbuf or outbufl */
5851       /* We need the result into outbuf */
5852       if (isunix) {
5853            /* If we need this in UNIX, then we need another buffer */
5854            /* to keep things in order */
5855            char * src;
5856            char * new_src = NULL;
5857            if (spec_buf == outbuf) {
5858                new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
5859                my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
5860            } else {
5861                src = spec_buf;
5862            }
5863            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5864            if (new_src) {
5865                PerlMem_free(new_src);
5866            }
5867       } else {
5868            /* VMS file specs are not in UTF-8 */
5869            if (fs_utf8 != NULL)
5870                *fs_utf8 = 0;
5871
5872            /* Copy the buffer if needed */
5873            if (outbuf != spec_buf)
5874                my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
5875            ret_spec = outbuf;
5876       }
5877     }
5878   }
5879
5880   /* Need to clean up the search context */
5881   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5882   sts = rms_free_search_context(&myfab); /* Free search context */
5883
5884   /* Clean up the extra buffers */
5885   if (esal != NULL)
5886       PerlMem_free(esal);
5887   PerlMem_free(esa);
5888   if (outbufl != NULL)
5889      PerlMem_free(outbufl);
5890
5891   /* Return the result */
5892   return ret_spec;
5893 }
5894
5895 /* Common simple case - Expand an already VMS spec */
5896 static char *
5897 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5898     opts |= PERL_RMSEXPAND_M_VMS_IN;
5899     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5900 }
5901
5902 /* Common simple case - Expand to a VMS spec */
5903 static char *
5904 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5905     opts |= PERL_RMSEXPAND_M_VMS;
5906     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5907 }
5908
5909
5910 /* Entry point used by perl routines */
5911 static char *
5912 mp_do_rmsexpand
5913    (pTHX_ const char *filespec,
5914     char *outbuf,
5915     int ts,
5916     const char *defspec,
5917     unsigned opts,
5918     int * fs_utf8,
5919     int * dfs_utf8)
5920 {
5921     static char __rmsexpand_retbuf[VMS_MAXRSS];
5922     char * expanded, *ret_spec, *ret_buf;
5923
5924     expanded = NULL;
5925     ret_buf = outbuf;
5926     if (ret_buf == NULL) {
5927         if (ts) {
5928             Newx(expanded, VMS_MAXRSS, char);
5929             if (expanded == NULL)
5930                 _ckvmssts(SS$_INSFMEM);
5931             ret_buf = expanded;
5932         } else {
5933             ret_buf = __rmsexpand_retbuf;
5934         }
5935     }
5936
5937
5938     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5939                              opts, fs_utf8,  dfs_utf8);
5940
5941     if (ret_spec == NULL) {
5942        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5943        if (expanded)
5944            Safefree(expanded);
5945     }
5946
5947     return ret_spec;
5948 }
5949 /*}}}*/
5950 /* External entry points */
5951 char *
5952 Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5953 {
5954     return do_rmsexpand(spec, buf, 0, def, opt, NULL, NULL);
5955 }
5956
5957 char *
5958 Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5959 {
5960     return do_rmsexpand(spec, buf, 1, def, opt, NULL, NULL);
5961 }
5962
5963 char *
5964 Perl_rmsexpand_utf8(pTHX_ const char *spec, char *buf, const char *def,
5965                     unsigned opt, int * fs_utf8, int * dfs_utf8)
5966 {
5967     return do_rmsexpand(spec, buf, 0, def, opt, fs_utf8, dfs_utf8);
5968 }
5969
5970 char *
5971 Perl_rmsexpand_utf8_ts(pTHX_ const char *spec, char *buf, const char *def,
5972                        unsigned opt, int * fs_utf8, int * dfs_utf8)
5973 {
5974     return do_rmsexpand(spec, buf, 1, def, opt, fs_utf8, dfs_utf8);
5975 }
5976
5977
5978 /*
5979 ** The following routines are provided to make life easier when
5980 ** converting among VMS-style and Unix-style directory specifications.
5981 ** All will take input specifications in either VMS or Unix syntax. On
5982 ** failure, all return NULL.  If successful, the routines listed below
5983 ** return a pointer to a buffer containing the appropriately
5984 ** reformatted spec (and, therefore, subsequent calls to that routine
5985 ** will clobber the result), while the routines of the same names with
5986 ** a _ts suffix appended will return a pointer to a mallocd string
5987 ** containing the appropriately reformatted spec.
5988 ** In all cases, only explicit syntax is altered; no check is made that
5989 ** the resulting string is valid or that the directory in question
5990 ** actually exists.
5991 **
5992 **   fileify_dirspec() - convert a directory spec into the name of the
5993 **     directory file (i.e. what you can stat() to see if it's a dir).
5994 **     The style (VMS or Unix) of the result is the same as the style
5995 **     of the parameter passed in.
5996 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5997 **     what you prepend to a filename to indicate what directory it's in).
5998 **     The style (VMS or Unix) of the result is the same as the style
5999 **     of the parameter passed in.
6000 **   tounixpath() - convert a directory spec into a Unix-style path.
6001 **   tovmspath() - convert a directory spec into a VMS-style path.
6002 **   tounixspec() - convert any file spec into a Unix-style file spec.
6003 **   tovmsspec() - convert any file spec into a VMS-style spec.
6004 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
6005 **
6006 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
6007 ** Permission is given to distribute this code as part of the Perl
6008 ** standard distribution under the terms of the GNU General Public
6009 ** License or the Perl Artistic License.  Copies of each may be
6010 ** found in the Perl standard distribution.
6011  */
6012
6013 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6014 static char *
6015 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
6016 {
6017     unsigned long int dirlen, retlen, hasfilename = 0;
6018     char *cp1, *cp2, *lastdir;
6019     char *trndir, *vmsdir;
6020     unsigned short int trnlnm_iter_count;
6021     int sts;
6022     if (utf8_fl != NULL)
6023         *utf8_fl = 0;
6024
6025     if (!dir || !*dir) {
6026       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6027     }
6028     dirlen = strlen(dir);
6029     while (dirlen && dir[dirlen-1] == '/') --dirlen;
6030     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6031       if (!DECC_POSIX_COMPLIANT_PATHNAMES && DECC_DISABLE_POSIX_ROOT) {
6032         dir = "/sys$disk";
6033         dirlen = 9;
6034       }
6035       else
6036         dirlen = 1;
6037     }
6038     if (dirlen > (VMS_MAXRSS - 1)) {
6039       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6040       return NULL;
6041     }
6042     trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
6043     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6044     if (!strpbrk(dir+1,"/]>:")  &&
6045         (!DECC_POSIX_COMPLIANT_PATHNAMES && DECC_DISABLE_POSIX_ROOT)) {
6046       strcpy(trndir,*dir == '/' ? dir + 1: dir);
6047       trnlnm_iter_count = 0;
6048       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6049         trnlnm_iter_count++;
6050         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6051       }
6052       dirlen = strlen(trndir);
6053     }
6054     else {
6055       memcpy(trndir, dir, dirlen);
6056       trndir[dirlen] = '\0';
6057     }
6058
6059     /* At this point we are done with *dir and use *trndir which is a
6060      * copy that can be modified.  *dir must not be modified.
6061      */
6062
6063     /* If we were handed a rooted logical name or spec, treat it like a
6064      * simple directory, so that
6065      *    $ Define myroot dev:[dir.]
6066      *    ... do_fileify_dirspec("myroot",buf,1) ...
6067      * does something useful.
6068      */
6069     if (dirlen >= 2 && strEQ(trndir+dirlen-2,".]")) {
6070       trndir[--dirlen] = '\0';
6071       trndir[dirlen-1] = ']';
6072     }
6073     if (dirlen >= 2 && strEQ(trndir+dirlen-2,".>")) {
6074       trndir[--dirlen] = '\0';
6075       trndir[dirlen-1] = '>';
6076     }
6077
6078     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6079       /* If we've got an explicit filename, we can just shuffle the string. */
6080       if (*(cp1+1)) hasfilename = 1;
6081       /* Similarly, we can just back up a level if we've got multiple levels
6082          of explicit directories in a VMS spec which ends with directories. */
6083       else {
6084         for (cp2 = cp1; cp2 > trndir; cp2--) {
6085           if (*cp2 == '.') {
6086             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6087 /* fix-me, can not scan EFS file specs backward like this */
6088               *cp2 = *cp1; *cp1 = '\0';
6089               hasfilename = 1;
6090               break;
6091             }
6092           }
6093           if (*cp2 == '[' || *cp2 == '<') break;
6094         }
6095       }
6096     }
6097
6098     vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
6099     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6100     cp1 = strpbrk(trndir,"]:>");
6101     if (cp1 && *(cp1+1) == ':')   /* DECNet node spec with :: */
6102         cp1 = strpbrk(cp1+2,"]:>");
6103
6104     if (hasfilename || !cp1) { /* filename present or not VMS */
6105
6106       if (trndir[0] == '.') {
6107         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6108           PerlMem_free(trndir);
6109           PerlMem_free(vmsdir);
6110           return int_fileify_dirspec("[]", buf, NULL);
6111         }
6112         else if (trndir[1] == '.' &&
6113                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6114           PerlMem_free(trndir);
6115           PerlMem_free(vmsdir);
6116           return int_fileify_dirspec("[-]", buf, NULL);
6117         }
6118       }
6119       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6120         dirlen -= 1;                 /* to last element */
6121         lastdir = strrchr(trndir,'/');
6122       }
6123       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6124         /* If we have "/." or "/..", VMSify it and let the VMS code
6125          * below expand it, rather than repeating the code to handle
6126          * relative components of a filespec here */
6127         do {
6128           if (*(cp1+2) == '.') cp1++;
6129           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6130             char * ret_chr;
6131             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6132                 PerlMem_free(trndir);
6133                 PerlMem_free(vmsdir);
6134                 return NULL;
6135             }
6136             if (strchr(vmsdir,'/') != NULL) {
6137               /* If int_tovmsspec() returned it, it must have VMS syntax
6138                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6139                * the time to check this here only so we avoid a recursion
6140                * loop; otherwise, gigo.
6141                */
6142               PerlMem_free(trndir);
6143               PerlMem_free(vmsdir);
6144               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6145               return NULL;
6146             }
6147             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6148                 PerlMem_free(trndir);
6149                 PerlMem_free(vmsdir);
6150                 return NULL;
6151             }
6152             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6153             PerlMem_free(trndir);
6154             PerlMem_free(vmsdir);
6155             return ret_chr;
6156           }
6157           cp1++;
6158         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6159         lastdir = strrchr(trndir,'/');
6160       }
6161       else if (dirlen >= 7 && strEQ(&trndir[dirlen-7],"/000000")) {
6162         char * ret_chr;
6163         /* Ditto for specs that end in an MFD -- let the VMS code
6164          * figure out whether it's a real device or a rooted logical. */
6165
6166         /* This should not happen any more.  Allowing the fake /000000
6167          * in a UNIX pathname causes all sorts of problems when trying
6168          * to run in UNIX emulation.  So the VMS to UNIX conversions
6169          * now remove the fake /000000 directories.
6170          */
6171
6172         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6173         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6174             PerlMem_free(trndir);
6175             PerlMem_free(vmsdir);
6176             return NULL;
6177         }
6178         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6179             PerlMem_free(trndir);
6180             PerlMem_free(vmsdir);
6181             return NULL;
6182         }
6183         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6184         PerlMem_free(trndir);
6185         PerlMem_free(vmsdir);
6186         return ret_chr;
6187       }
6188       else {
6189
6190         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6191              !(lastdir = cp1 = strrchr(trndir,']')) &&
6192              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6193
6194         cp2 = strrchr(cp1,'.');
6195         if (cp2) {
6196             int e_len, vs_len = 0;
6197             int is_dir = 0;
6198             char * cp3;
6199             cp3 = strchr(cp2,';');
6200             e_len = strlen(cp2);
6201             if (cp3) {
6202                 vs_len = strlen(cp3);
6203                 e_len = e_len - vs_len;
6204             }
6205             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6206             if (!is_dir) {
6207                 if (!DECC_EFS_CHARSET) {
6208                     /* If this is not EFS, then not a directory */
6209                     PerlMem_free(trndir);
6210                     PerlMem_free(vmsdir);
6211                     set_errno(ENOTDIR);
6212                     set_vaxc_errno(RMS$_DIR);
6213                     return NULL;
6214                 }
6215             } else {
6216                 /* Ok, here we have an issue, technically if a .dir shows */
6217                 /* from inside a directory, then we should treat it as */
6218                 /* xxx^.dir.dir.  But we do not have that context at this */
6219                 /* point unless this is totally restructured, so we remove */
6220                 /* The .dir for now, and fix this better later */
6221                 dirlen = cp2 - trndir;
6222             }
6223             if (DECC_EFS_CHARSET && !strchr(trndir,'/')) {
6224                 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
6225                 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6226
6227                 for (; cp4 > cp1; cp4--) {
6228                     if (*cp4 == '.') {
6229                         if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6230                             memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6231                             *cp4 = '^';
6232                             dirlen++;
6233                         }
6234                     }
6235                 }
6236             }
6237         }
6238
6239       }
6240
6241       retlen = dirlen + 6;
6242       memcpy(buf, trndir, dirlen);
6243       buf[dirlen] = '\0';
6244
6245       /* We've picked up everything up to the directory file name.
6246          Now just add the type and version, and we're set. */
6247       if ((!DECC_EFS_CASE_PRESERVE) && vms_process_case_tolerant)
6248           strcat(buf,".dir");
6249       else
6250           strcat(buf,".DIR");
6251       if (!DECC_FILENAME_UNIX_NO_VERSION)
6252           strcat(buf,";1");
6253       PerlMem_free(trndir);
6254       PerlMem_free(vmsdir);
6255       return buf;
6256     }
6257     else {  /* VMS-style directory spec */
6258
6259       char *esa, *esal, term, *cp;
6260       char *my_esa;
6261       int my_esa_len;
6262       unsigned long int cmplen, haslower = 0;
6263       struct FAB dirfab = cc$rms_fab;
6264       rms_setup_nam(savnam);
6265       rms_setup_nam(dirnam);
6266
6267       esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
6268       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6269       esal = NULL;
6270 #if defined(NAML$C_MAXRSS)
6271       esal = (char *)PerlMem_malloc(VMS_MAXRSS);
6272       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6273 #endif
6274       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6275       rms_bind_fab_nam(dirfab, dirnam);
6276       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6277       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6278 #ifdef NAM$M_NO_SHORT_UPCASE
6279       if (DECC_EFS_CASE_PRESERVE)
6280         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6281 #endif
6282
6283       for (cp = trndir; *cp; cp++)
6284         if (islower(*cp)) { haslower = 1; break; }
6285       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6286         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6287             (dirfab.fab$l_sts == RMS$_DNF) ||
6288             (dirfab.fab$l_sts == RMS$_PRV)) {
6289             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6290             sts = sys$parse(&dirfab);
6291         }
6292         if (!sts) {
6293           PerlMem_free(esa);
6294           if (esal != NULL)
6295               PerlMem_free(esal);
6296           PerlMem_free(trndir);
6297           PerlMem_free(vmsdir);
6298           set_errno(EVMSERR);
6299           set_vaxc_errno(dirfab.fab$l_sts);
6300           return NULL;
6301         }
6302       }
6303       else {
6304         savnam = dirnam;
6305         /* Does the file really exist? */
6306         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6307           /* Yes; fake the fnb bits so we'll check type below */
6308           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6309         }
6310         else { /* No; just work with potential name */
6311           if (dirfab.fab$l_sts    == RMS$_FNF
6312               || dirfab.fab$l_sts == RMS$_DNF
6313               || dirfab.fab$l_sts == RMS$_FND)
6314                 dirnam = savnam;
6315           else {
6316             int fab_sts;
6317             fab_sts = dirfab.fab$l_sts;
6318             sts = rms_free_search_context(&dirfab);
6319             PerlMem_free(esa);
6320             if (esal != NULL)
6321                 PerlMem_free(esal);
6322             PerlMem_free(trndir);
6323             PerlMem_free(vmsdir);
6324             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6325             return NULL;
6326           }
6327         }
6328       }
6329
6330       /* Make sure we are using the right buffer */
6331 #if defined(NAML$C_MAXRSS)
6332       if (esal != NULL) {
6333         my_esa = esal;
6334         my_esa_len = rms_nam_esll(dirnam);
6335       } else {
6336 #endif
6337         my_esa = esa;
6338         my_esa_len = rms_nam_esl(dirnam);
6339 #if defined(NAML$C_MAXRSS)
6340       }
6341 #endif
6342       my_esa[my_esa_len] = '\0';
6343       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6344         cp1 = strchr(my_esa,']');
6345         if (!cp1) cp1 = strchr(my_esa,'>');
6346         if (cp1) {  /* Should always be true */
6347           my_esa_len -= cp1 - my_esa - 1;
6348           memmove(my_esa, cp1 + 1, my_esa_len);
6349         }
6350       }
6351       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6352         /* Yep; check version while we're at it, if it's there. */
6353         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6354         if (strnNE(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6355           /* Something other than .DIR[;1].  Bzzt. */
6356           sts = rms_free_search_context(&dirfab);
6357           PerlMem_free(esa);
6358           if (esal != NULL)
6359              PerlMem_free(esal);
6360           PerlMem_free(trndir);
6361           PerlMem_free(vmsdir);
6362           set_errno(ENOTDIR);
6363           set_vaxc_errno(RMS$_DIR);
6364           return NULL;
6365         }
6366       }
6367
6368       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6369         /* They provided at least the name; we added the type, if necessary, */
6370         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6371         sts = rms_free_search_context(&dirfab);
6372         PerlMem_free(trndir);
6373         PerlMem_free(esa);
6374         if (esal != NULL)
6375             PerlMem_free(esal);
6376         PerlMem_free(vmsdir);
6377         return buf;
6378       }
6379       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6380         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6381         *cp1 = '\0';
6382         my_esa_len -= 9;
6383       }
6384       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6385       if (cp1 == NULL) { /* should never happen */
6386         sts = rms_free_search_context(&dirfab);
6387         PerlMem_free(trndir);
6388         PerlMem_free(esa);
6389         if (esal != NULL)
6390             PerlMem_free(esal);
6391         PerlMem_free(vmsdir);
6392         return NULL;
6393       }
6394       term = *cp1;
6395       *cp1 = '\0';
6396       retlen = strlen(my_esa);
6397       cp1 = strrchr(my_esa,'.');
6398       /* ODS-5 directory specifications can have extra "." in them. */
6399       /* Fix-me, can not scan EFS file specifications backwards */
6400       while (cp1 != NULL) {
6401         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6402           break;
6403         else {
6404            cp1--;
6405            while ((cp1 > my_esa) && (*cp1 != '.'))
6406              cp1--;
6407         }
6408         if (cp1 == my_esa)
6409           cp1 = NULL;
6410       }
6411
6412       if ((cp1) != NULL) {
6413         /* There's more than one directory in the path.  Just roll back. */
6414         *cp1 = term;
6415         my_strlcpy(buf, my_esa, VMS_MAXRSS);
6416       }
6417       else {
6418         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6419           /* Go back and expand rooted logical name */
6420           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6421 #ifdef NAM$M_NO_SHORT_UPCASE
6422           if (DECC_EFS_CASE_PRESERVE)
6423             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6424 #endif
6425           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6426             sts = rms_free_search_context(&dirfab);
6427             PerlMem_free(esa);
6428             if (esal != NULL)
6429                 PerlMem_free(esal);
6430             PerlMem_free(trndir);
6431             PerlMem_free(vmsdir);
6432             set_errno(EVMSERR);
6433             set_vaxc_errno(dirfab.fab$l_sts);
6434             return NULL;
6435           }
6436
6437           /* This changes the length of the string of course */
6438           if (esal != NULL) {
6439               my_esa_len = rms_nam_esll(dirnam);
6440           } else {
6441               my_esa_len = rms_nam_esl(dirnam);
6442           }
6443
6444           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6445           cp1 = strstr(my_esa,"][");
6446           if (!cp1) cp1 = strstr(my_esa,"]<");
6447           dirlen = cp1 - my_esa;
6448           memcpy(buf, my_esa, dirlen);
6449           if (strBEGINs(cp1+2,"000000]")) {
6450             buf[dirlen-1] = '\0';
6451             /* fix-me Not full ODS-5, just extra dots in directories for now */
6452             cp1 = buf + dirlen - 1;
6453             while (cp1 > buf)
6454             {
6455               if (*cp1 == '[')
6456                 break;
6457               if (*cp1 == '.') {
6458                 if (*(cp1-1) != '^')
6459                   break;
6460               }
6461               cp1--;
6462             }
6463             if (*cp1 == '.') *cp1 = ']';
6464             else {
6465               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6466               memmove(cp1+1,"000000]",7);
6467             }
6468           }
6469           else {
6470             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6471             buf[retlen] = '\0';
6472             /* Convert last '.' to ']' */
6473             cp1 = buf+retlen-1;
6474             while (*cp != '[') {
6475               cp1--;
6476               if (*cp1 == '.') {
6477                 /* Do not trip on extra dots in ODS-5 directories */
6478                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6479                 break;
6480               }
6481             }
6482             if (*cp1 == '.') *cp1 = ']';
6483             else {
6484               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6485               memmove(cp1+1,"000000]",7);
6486             }
6487           }
6488         }
6489         else {  /* This is a top-level dir.  Add the MFD to the path. */
6490           cp1 = strrchr(my_esa, ':');
6491           assert(cp1);
6492           memmove(buf, my_esa, cp1 - my_esa + 1);
6493           memmove(buf + (cp1 - my_esa) + 1, "[000000]", 8);
6494           memmove(buf + (cp1 - my_esa) + 9, cp1 + 2, retlen - (cp1 - my_esa + 2));
6495           buf[retlen + 7] = '\0';  /* We've inserted '000000]' */
6496         }
6497       }
6498       sts = rms_free_search_context(&dirfab);
6499       /* We've set up the string up through the filename.  Add the
6500          type and version, and we're done. */
6501       strcat(buf,".DIR;1");
6502
6503       /* $PARSE may have upcased filespec, so convert output to lower
6504        * case if input contained any lowercase characters. */
6505       if (haslower && !DECC_EFS_CASE_PRESERVE) __mystrtolower(buf);
6506       PerlMem_free(trndir);
6507       PerlMem_free(esa);
6508       if (esal != NULL)
6509         PerlMem_free(esal);
6510       PerlMem_free(vmsdir);
6511       return buf;
6512     }
6513 }  /* end of int_fileify_dirspec() */
6514
6515
6516 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6517 static char *
6518 mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6519 {
6520     static char __fileify_retbuf[VMS_MAXRSS];
6521     char * fileified, *ret_spec, *ret_buf;
6522
6523     fileified = NULL;
6524     ret_buf = buf;
6525     if (ret_buf == NULL) {
6526         if (ts) {
6527             Newx(fileified, VMS_MAXRSS, char);
6528             if (fileified == NULL)
6529                 _ckvmssts(SS$_INSFMEM);
6530             ret_buf = fileified;
6531         } else {
6532             ret_buf = __fileify_retbuf;
6533         }
6534     }
6535
6536     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6537
6538     if (ret_spec == NULL) {
6539        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6540        if (fileified)
6541            Safefree(fileified);
6542     }
6543
6544     return ret_spec;
6545 }  /* end of do_fileify_dirspec() */
6546 /*}}}*/
6547
6548 /* External entry points */
6549 char *
6550 Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6551 {
6552     return do_fileify_dirspec(dir, buf, 0, NULL);
6553 }
6554
6555 char *
6556 Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6557 {
6558     return do_fileify_dirspec(dir, buf, 1, NULL);
6559 }
6560
6561 char *
6562 Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6563 {
6564     return do_fileify_dirspec(dir, buf, 0, utf8_fl);
6565 }
6566
6567 char *
6568 Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6569 {
6570     return do_fileify_dirspec(dir, buf, 1, utf8_fl);
6571 }
6572
6573 static char *
6574 int_pathify_dirspec_simple(const char * dir, char * buf,
6575     char * v_spec, int v_len, char * r_spec, int r_len,
6576     char * d_spec, int d_len, char * n_spec, int n_len,
6577     char * e_spec, int e_len, char * vs_spec, int vs_len)
6578 {
6579
6580     /* VMS specification - Try to do this the simple way */
6581     if ((v_len + r_len > 0) || (d_len > 0)) {
6582         int is_dir;
6583
6584         /* No name or extension component, already a directory */
6585         if ((n_len + e_len + vs_len) == 0) {
6586             strcpy(buf, dir);
6587             return buf;
6588         }
6589
6590         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6591         /* This results from catfile() being used instead of catdir() */
6592         /* So even though it should not work, we need to allow it */
6593
6594         /* If this is .DIR;1 then do a simple conversion */
6595         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6596         if (is_dir || (e_len == 0) && (d_len > 0)) {
6597              int len;
6598              len = v_len + r_len + d_len - 1;
6599              char dclose = d_spec[d_len - 1];
6600              memcpy(buf, dir, len);
6601              buf[len] = '.';
6602              len++;
6603              memcpy(&buf[len], n_spec, n_len);
6604              len += n_len;
6605              buf[len] = dclose;
6606              buf[len + 1] = '\0';
6607              return buf;
6608         }
6609
6610 #ifdef HAS_SYMLINK
6611         else if (d_len > 0) {
6612             /* In the olden days, a directory needed to have a .DIR */
6613             /* extension to be a valid directory, but now it could  */
6614             /* be a symbolic link */
6615             int len;
6616             len = v_len + r_len + d_len - 1;
6617             char dclose = d_spec[d_len - 1];
6618             memcpy(buf, dir, len);
6619             buf[len] = '.';
6620             len++;
6621             memcpy(&buf[len], n_spec, n_len);
6622             len += n_len;
6623             if (e_len > 0) {
6624                 if (DECC_EFS_CHARSET) {
6625                     if (e_len == 4
6626                         && (toUPPER_A(e_spec[1]) == 'D')
6627                         && (toUPPER_A(e_spec[2]) == 'I')
6628                         && (toUPPER_A(e_spec[3]) == 'R')) {
6629
6630                         /* Corner case: directory spec with invalid version.
6631                          * Valid would have followed is_dir path above.
6632                          */
6633                         SETERRNO(ENOTDIR, RMS$_DIR);
6634                         return NULL;
6635                     }
6636                     else {
6637                         buf[len] = '^';
6638                         len++;
6639                         memcpy(&buf[len], e_spec, e_len);
6640                         len += e_len;
6641                     }
6642                 }
6643                 else {
6644                     SETERRNO(ENOTDIR, RMS$_DIR);
6645                     return NULL;
6646                 }
6647             }
6648             buf[len] = dclose;
6649             buf[len + 1] = '\0';
6650             return buf;
6651         }
6652 #else
6653         else {
6654             set_vaxc_errno(RMS$_DIR);
6655             set_errno(ENOTDIR);
6656             return NULL;
6657         }
6658 #endif
6659     }
6660     set_vaxc_errno(RMS$_DIR);
6661     set_errno(ENOTDIR);
6662     return NULL;
6663 }
6664
6665
6666 /* Internal routine to make sure or convert a directory to be in a */
6667 /* path specification.  No utf8 flag because it is not changed or used */
6668 static char *
6669 int_pathify_dirspec(const char *dir, char *buf)
6670 {
6671     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6672     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6673     char * exp_spec, *ret_spec;
6674     char * trndir;
6675     unsigned short int trnlnm_iter_count;
6676     STRLEN trnlen;
6677     int need_to_lower;
6678
6679     if (vms_debug_fileify) {
6680         if (dir == NULL)
6681             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6682         else
6683             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6684     }
6685
6686     /* We may need to lower case the result if we translated  */
6687     /* a logical name or got the current working directory */
6688     need_to_lower = 0;
6689
6690     if (!dir || !*dir) {
6691       set_errno(EINVAL);
6692       set_vaxc_errno(SS$_BADPARAM);
6693       return NULL;
6694     }
6695
6696     trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
6697     if (trndir == NULL)
6698         _ckvmssts_noperl(SS$_INSFMEM);
6699
6700     /* If no directory specified use the current default */
6701     if (*dir)
6702         my_strlcpy(trndir, dir, VMS_MAXRSS);
6703     else {
6704         getcwd(trndir, VMS_MAXRSS - 1);
6705         need_to_lower = 1;
6706     }
6707
6708     /* now deal with bare names that could be logical names */
6709     trnlnm_iter_count = 0;
6710     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6711            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6712         trnlnm_iter_count++;
6713         need_to_lower = 1;
6714         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6715             break;
6716         trnlen = strlen(trndir);
6717
6718         /* Trap simple rooted lnms, and return lnm:[000000] */
6719         if (strEQ(trndir+trnlen-2,".]")) {
6720             my_strlcpy(buf, dir, VMS_MAXRSS);
6721             strcat(buf, ":[000000]");
6722             PerlMem_free(trndir);
6723
6724             if (vms_debug_fileify) {
6725                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6726             }
6727             return buf;
6728         }
6729     }
6730
6731     /* At this point we do not work with *dir, but the copy in  *trndir */
6732
6733     if (need_to_lower && !DECC_EFS_CASE_PRESERVE) {
6734         /* Legacy mode, lower case the returned value */
6735         __mystrtolower(trndir);
6736     }
6737
6738
6739     /* Some special cases, '..', '.' */
6740     sts = 0;
6741     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6742        /* Force UNIX filespec */
6743        sts = 1;
6744
6745     } else {
6746         /* Is this Unix or VMS format? */
6747         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6748                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6749                              &e_len, &vs_spec, &vs_len);
6750         if (sts == 0) {
6751
6752             /* Just a filename? */
6753             if ((v_len + r_len + d_len) == 0) {
6754
6755                 /* Now we have a problem, this could be Unix or VMS */
6756                 /* We have to guess.  .DIR usually means VMS */
6757
6758                 /* In UNIX report mode, the .DIR extension is removed */
6759                 /* if one shows up, it is for a non-directory or a directory */
6760                 /* in EFS charset mode */
6761
6762                 /* So if we are in Unix report mode, assume that this */
6763                 /* is a relative Unix directory specification */
6764
6765                 sts = 1;
6766                 if (!DECC_FILENAME_UNIX_REPORT && DECC_EFS_CHARSET) {
6767                     int is_dir;
6768                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6769
6770                     if (is_dir) {
6771                         /* Traditional mode, assume .DIR is directory */
6772                         buf[0] = '[';
6773                         buf[1] = '.';
6774                         memcpy(&buf[2], n_spec, n_len);
6775                         buf[n_len + 2] = ']';
6776                         buf[n_len + 3] = '\0';
6777                         PerlMem_free(trndir);
6778                         if (vms_debug_fileify) {
6779                             fprintf(stderr,
6780                                     "int_pathify_dirspec: buf = %s\n",
6781                                     buf);
6782                         }
6783                         return buf;
6784                     }
6785                 }
6786             }
6787         }
6788     }
6789     if (sts == 0) {
6790         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6791             v_spec, v_len, r_spec, r_len,
6792             d_spec, d_len, n_spec, n_len,
6793             e_spec, e_len, vs_spec, vs_len);
6794
6795         if (ret_spec != NULL) {
6796             PerlMem_free(trndir);
6797             if (vms_debug_fileify) {
6798                 fprintf(stderr,
6799                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6800             }
6801             return ret_spec;
6802         }
6803
6804         /* Simple way did not work, which means that a logical name */
6805         /* was present for the directory specification.             */
6806         /* Need to use an rmsexpand variant to decode it completely */
6807         exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
6808         if (exp_spec == NULL)
6809             _ckvmssts_noperl(SS$_INSFMEM);
6810
6811         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6812         if (ret_spec != NULL) {
6813             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6814                                  &r_spec, &r_len, &d_spec, &d_len,
6815                                  &n_spec, &n_len, &e_spec,
6816                                  &e_len, &vs_spec, &vs_len);
6817             if (sts == 0) {
6818                 ret_spec = int_pathify_dirspec_simple(
6819                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6820                     d_spec, d_len, n_spec, n_len,
6821                     e_spec, e_len, vs_spec, vs_len);
6822
6823                 if ((ret_spec != NULL) && (!DECC_EFS_CASE_PRESERVE)) {
6824                     /* Legacy mode, lower case the returned value */
6825                     __mystrtolower(ret_spec);
6826                 }
6827             } else {
6828                 set_vaxc_errno(RMS$_DIR);
6829                 set_errno(ENOTDIR);
6830                 ret_spec = NULL;
6831             }
6832         }
6833         PerlMem_free(exp_spec);
6834         PerlMem_free(trndir);
6835         if (vms_debug_fileify) {
6836             if (ret_spec == NULL)
6837                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6838             else
6839                 fprintf(stderr,
6840                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6841         }
6842         return ret_spec;
6843
6844     } else {
6845         /* Unix specification, Could be trivial conversion, */
6846         /* but have to deal with trailing '.dir' or extra '.' */
6847
6848         char * lastdot;
6849         char * lastslash;
6850         int is_dir;
6851         STRLEN dir_len = strlen(trndir);
6852
6853         lastslash = strrchr(trndir, '/');
6854         if (lastslash == NULL)
6855             lastslash = trndir;
6856         else
6857             lastslash++;
6858
6859         lastdot = NULL;
6860
6861         /* '..' or '.' are valid directory components */
6862         is_dir = 0;
6863         if (lastslash[0] == '.') {
6864             if (lastslash[1] == '\0') {
6865                is_dir = 1;
6866             } else if (lastslash[1] == '.') {
6867                 if (lastslash[2] == '\0') {
6868                     is_dir = 1;
6869                 } else {
6870                     /* And finally allow '...' */
6871                     if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6872                         is_dir = 1;
6873                     }
6874                 }
6875             }
6876         }
6877
6878         if (!is_dir) {
6879            lastdot = strrchr(lastslash, '.');
6880         }
6881         if (lastdot != NULL) {
6882             STRLEN e_len;
6883              /* '.dir' is discarded, and any other '.' is invalid */
6884             e_len = strlen(lastdot);
6885
6886             is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6887
6888             if (is_dir) {
6889                 dir_len = dir_len - 4;
6890             }
6891         }
6892
6893         my_strlcpy(buf, trndir, VMS_MAXRSS);
6894         if (buf[dir_len - 1] != '/') {
6895             buf[dir_len] = '/';
6896             buf[dir_len + 1] = '\0';
6897         }
6898
6899         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6900         if (!DECC_EFS_CHARSET) {
6901              int dir_start = 0;
6902              char * str = buf;
6903              if (str[0] == '.') {
6904                  char * dots = str;
6905                  int cnt = 1;
6906                  while ((dots[cnt] == '.') && (cnt < 3))
6907                      cnt++;
6908                  if (cnt <= 3) {
6909                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6910                          dir_start = 1;
6911                          str += cnt;
6912                      }
6913                  }
6914              }
6915              for (; *str; ++str) {
6916                  while (*str == '/') {
6917                      dir_start = 1;
6918                      *str++;
6919                  }
6920                  if (dir_start) {
6921
6922                      /* Have to skip up to three dots which could be */
6923                      /* directories, 3 dots being a VMS extension for Perl */
6924                      char * dots = str;
6925                      int cnt = 0;
6926                      while ((dots[cnt] == '.') && (cnt < 3)) {
6927                          cnt++;
6928                      }
6929                      if (dots[cnt] == '\0')
6930                          break;
6931                      if ((cnt > 1) && (dots[cnt] != '/')) {
6932                          dir_start = 0;
6933                      } else {
6934                          str += cnt;
6935                      }
6936
6937                      /* too many dots? */
6938                      if ((cnt == 0) || (cnt > 3)) {
6939                          dir_start = 0;
6940                      }
6941                  }
6942                  if (!dir_start && (*str == '.')) {
6943                      *str = '_';
6944                  }
6945              }
6946         }
6947         PerlMem_free(trndir);
6948         ret_spec = buf;
6949         if (vms_debug_fileify) {
6950             if (ret_spec == NULL)
6951                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6952             else
6953                 fprintf(stderr,
6954                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6955         }
6956         return ret_spec;
6957     }
6958 }
6959
6960 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6961 static char *
6962 mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6963 {
6964     static char __pathify_retbuf[VMS_MAXRSS];
6965     char * pathified, *ret_spec, *ret_buf;
6966
6967     pathified = NULL;
6968     ret_buf = buf;
6969     if (ret_buf == NULL) {
6970         if (ts) {
6971             Newx(pathified, VMS_MAXRSS, char);
6972             if (pathified == NULL)
6973                 _ckvmssts(SS$_INSFMEM);
6974             ret_buf = pathified;
6975         } else {
6976             ret_buf = __pathify_retbuf;
6977         }
6978     }
6979
6980     ret_spec = int_pathify_dirspec(dir, ret_buf);
6981
6982     if (ret_spec == NULL) {
6983        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6984        if (pathified)
6985            Safefree(pathified);
6986     }
6987
6988     return ret_spec;
6989
6990 }  /* end of do_pathify_dirspec() */
6991
6992
6993 /* External entry points */
6994 char *
6995 Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6996 {
6997     return do_pathify_dirspec(dir, buf, 0, NULL);
6998 }
6999
7000 char *
7001 Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
7002 {
7003     return do_pathify_dirspec(dir, buf, 1, NULL);
7004 }
7005
7006 char *
7007 Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
7008 {
7009     return do_pathify_dirspec(dir, buf, 0, utf8_fl);
7010 }
7011
7012 char *
7013 Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
7014 {
7015     return do_pathify_dirspec(dir, buf, 1, utf8_fl);
7016 }
7017
7018 /* Internal tounixspec routine that does not use a thread context */
7019 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7020 static char *
7021 int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7022 {
7023   char *dirend, *cp1, *cp3, *tmp;
7024   const char *cp2;
7025   int dirlen;
7026   unsigned short int trnlnm_iter_count;
7027   int cmp_rslt, outchars_added;
7028   if (utf8_fl != NULL)
7029     *utf8_fl = 0;
7030
7031   if (vms_debug_fileify) {
7032       if (spec == NULL)
7033           fprintf(stderr, "int_tounixspec: spec = NULL\n");
7034       else
7035           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7036   }
7037
7038
7039   if (spec == NULL) {
7040       set_errno(EINVAL);
7041       set_vaxc_errno(SS$_BADPARAM);
7042       return NULL;
7043   }
7044   if (strlen(spec) > (VMS_MAXRSS-1)) {
7045       set_errno(E2BIG);
7046       set_vaxc_errno(SS$_BUFFEROVF);
7047       return NULL;
7048   }
7049
7050   /* New VMS specific format needs translation
7051    * glob passes filenames with trailing '\n' and expects this preserved.
7052    */
7053   if (DECC_POSIX_COMPLIANT_PATHNAMES) {
7054     if (! strBEGINs(spec, "\"^UP^")) {
7055       char * uspec;
7056       char *tunix;
7057       int tunix_len;
7058       int nl_flag;
7059
7060       tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
7061       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7062       tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
7063       nl_flag = 0;
7064       if (tunix[tunix_len - 1] == '\n') {
7065         tunix[tunix_len - 1] = '\"';
7066         tunix[tunix_len] = '\0';
7067         tunix_len--;
7068         nl_flag = 1;
7069       }
7070       uspec = decc$translate_vms(tunix);
7071       PerlMem_free(tunix);
7072       if ((int)uspec > 0) {
7073         my_strlcpy(rslt, uspec, VMS_MAXRSS);
7074         if (nl_flag) {
7075           strcat(rslt,"\n");
7076         }
7077         else {
7078           /* If we can not translate it, makemaker wants as-is */
7079           my_strlcpy(rslt, spec, VMS_MAXRSS);
7080         }
7081         return rslt;
7082       }
7083     }
7084   }
7085
7086   cmp_rslt = 0; /* Presume VMS */
7087   cp1 = strchr(spec, '/');
7088   if (cp1 == NULL)
7089     cmp_rslt = 0;
7090
7091     /* Look for EFS ^/ */
7092     if (DECC_EFS_CHARSET) {
7093       while (cp1 != NULL) {
7094         cp2 = cp1 - 1;
7095         if (*cp2 != '^') {
7096           /* Found illegal VMS, assume UNIX */
7097           cmp_rslt = 1;
7098           break;
7099         }
7100       cp1++;
7101       cp1 = strchr(cp1, '/');
7102     }
7103   }
7104
7105   /* Look for "." and ".." */
7106   if (DECC_FILENAME_UNIX_REPORT) {
7107     if (spec[0] == '.') {
7108       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7109         cmp_rslt = 1;
7110       }
7111       else {
7112         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7113           cmp_rslt = 1;
7114         }
7115       }
7116     }
7117   }
7118
7119   cp1 = rslt;
7120   cp2 = spec;
7121
7122   /* This is already UNIX or at least nothing VMS understands,
7123    * so all we can reasonably do is unescape extended chars.
7124    */
7125   if (cmp_rslt) {
7126     while (*cp2) {
7127         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7128         cp1 += outchars_added;
7129     }
7130     *cp1 = '\0';
7131     if (vms_debug_fileify) {
7132         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7133     }
7134     return rslt;
7135   }
7136
7137   dirend = strrchr(spec,']');
7138   if (dirend == NULL) dirend = strrchr(spec,'>');
7139   if (dirend == NULL) dirend = strchr(spec,':');
7140   if (dirend == NULL) {
7141     while (*cp2) {
7142         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7143         cp1 += outchars_added;
7144     }
7145     *cp1 = '\0';
7146     if (vms_debug_fileify) {
7147         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7148     }
7149     return rslt;
7150   }
7151
7152   /* Special case 1 - sys$posix_root = / */
7153   if (!DECC_DISABLE_POSIX_ROOT) {
7154     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7155       *cp1 = '/';
7156       cp1++;
7157       cp2 = cp2 + 15;
7158       }
7159   }
7160
7161   /* Special case 2 - Convert NLA0: to /dev/null */
7162   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7163   if (cmp_rslt == 0) {
7164     strcpy(rslt, "/dev/null");
7165     cp1 = cp1 + 9;
7166     cp2 = cp2 + 5;
7167     if (spec[6] != '\0') {
7168       cp1[9] = '/';
7169       cp1++;
7170       cp2++;
7171     }
7172   }
7173
7174    /* Also handle special case "SYS$SCRATCH:" */
7175   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7176   tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
7177   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7178   if (cmp_rslt == 0) {
7179   int islnm;
7180
7181     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7182     if (!islnm) {
7183       strcpy(rslt, "/tmp");
7184       cp1 = cp1 + 4;
7185       cp2 = cp2 + 12;
7186       if (spec[12] != '\0') {
7187         cp1[4] = '/';
7188         cp1++;
7189         cp2++;
7190       }
7191     }
7192   }
7193
7194   if (*cp2 != '[' && *cp2 != '<') {
7195     *(cp1++) = '/';
7196   }
7197   else {  /* the VMS spec begins with directories */
7198     cp2++;
7199     if (*cp2 == ']' || *cp2 == '>') {
7200       *(cp1++) = '.';
7201       *(cp1++) = '/';
7202     }
7203     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7204       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7205         PerlMem_free(tmp);
7206         if (vms_debug_fileify) {
7207             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7208         }
7209         return NULL;
7210       }
7211       trnlnm_iter_count = 0;
7212       do {
7213         cp3 = tmp;
7214         while (*cp3 != ':' && *cp3) cp3++;
7215         *(cp3++) = '\0';
7216         if (strchr(cp3,']') != NULL) break;
7217         trnlnm_iter_count++;
7218         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7219       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7220       cp1 = rslt;
7221       cp3 = tmp;
7222       *(cp1++) = '/';
7223       while (*cp3) {
7224         *(cp1++) = *(cp3++);
7225         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7226             PerlMem_free(tmp);
7227             set_errno(ENAMETOOLONG);
7228             set_vaxc_errno(SS$_BUFFEROVF);
7229             if (vms_debug_fileify) {
7230                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7231             }
7232             return NULL; /* No room */
7233         }
7234       }
7235       *(cp1++) = '/';
7236     }
7237     if ((*cp2 == '^')) {
7238         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7239         cp1 += outchars_added;
7240     }
7241     else if ( *cp2 == '.') {
7242       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7243         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7244         cp2 += 3;
7245       }
7246       else cp2++;
7247     }
7248   }
7249   PerlMem_free(tmp);
7250   for (; cp2 <= dirend; cp2++) {
7251     if ((*cp2 == '^')) {
7252         /* EFS file escape -- unescape it. */
7253         cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added) - 1;
7254         cp1 += outchars_added;
7255     }
7256     else if (*cp2 == ':') {
7257       *(cp1++) = '/';
7258       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7259     }
7260     else if (*cp2 == ']' || *cp2 == '>') {
7261       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7262     }
7263     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7264       *(cp1++) = '/';
7265       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7266         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7267                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7268         if (memEQs(cp2,7,"[000000") && (*(cp2+7) == ']' ||
7269             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7270       }
7271       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7272         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7273         cp2 += 2;
7274       }
7275     }
7276     else if (*cp2 == '-') {
7277       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7278         while (*cp2 == '-') {
7279           cp2++;
7280           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7281         }
7282         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7283                                                          /* filespecs like */
7284           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7285           if (vms_debug_fileify) {
7286               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7287           }
7288           return NULL;
7289         }
7290       }
7291       else *(cp1++) = *cp2;
7292     }
7293     else *(cp1++) = *cp2;
7294   }
7295   /* Translate the rest of the filename. */
7296   while (*cp2) {
7297       int dot_seen = 0;
7298       switch(*cp2) {
7299       /* Fixme - for compatibility with the CRTL we should be removing */
7300       /* spaces from the file specifications, but this may show that */
7301       /* some tests that were appearing to pass are not really passing */
7302       case '%':
7303           cp2++;
7304           *(cp1++) = '?';
7305           break;
7306       case '^':
7307           cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7308           cp1 += outchars_added;
7309           break;
7310       case ';':
7311           if (DECC_FILENAME_UNIX_NO_VERSION) {
7312               /* Easy, drop the version */
7313               while (*cp2)
7314                   cp2++;
7315               break;
7316           } else {
7317               /* Punt - passing the version as a dot will probably */
7318               /* break perl in weird ways, but so did passing */
7319               /* through the ; as a version.  Follow the CRTL and */
7320               /* hope for the best. */
7321               cp2++;
7322               *(cp1++) = '.';
7323           }
7324           break;
7325       case '.':
7326           if (dot_seen) {
7327               /* We will need to fix this properly later */
7328               /* As Perl may be installed on an ODS-5 volume, but not */
7329               /* have the EFS_CHARSET enabled, it still may encounter */
7330               /* filenames with extra dots in them, and a precedent got */
7331               /* set which allowed them to work, that we will uphold here */
7332               /* If extra dots are present in a name and no ^ is on them */
7333               /* VMS assumes that the first one is the extension delimiter */
7334               /* the rest have an implied ^. */
7335
7336               /* this is also a conflict as the . is also a version */
7337               /* delimiter in VMS, */
7338
7339               *(cp1++) = *(cp2++);
7340               break;
7341           }
7342           dot_seen = 1;
7343           /* This is an extension */
7344           if (DECC_READDIR_DROPDOTNOTYPE) {
7345               cp2++;
7346               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7347                   /* Drop the dot for the extension */
7348                   break;
7349               } else {
7350                   *(cp1++) = '.';
7351               }
7352               break;
7353           }
7354       default:
7355           *(cp1++) = *(cp2++);
7356       }
7357   }
7358   *cp1 = '\0';
7359
7360   /* This still leaves /000000/ when working with a
7361    * VMS device root or concealed root.
7362    */
7363   {
7364       int ulen;
7365       char * zeros;
7366
7367       ulen = strlen(rslt);
7368
7369       /* Get rid of "000000/ in rooted filespecs */
7370       if (ulen > 7) {
7371         zeros = strstr(rslt, "/000000/");
7372         if (zeros != NULL) {
7373           int mlen;
7374           mlen = ulen - (zeros - rslt) - 7;
7375           memmove(zeros, &zeros[7], mlen);
7376           ulen = ulen - 7;
7377           rslt[ulen] = '\0';
7378         }
7379       }
7380   }
7381
7382   if (vms_debug_fileify) {
7383       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7384   }
7385   return rslt;
7386
7387 }  /* end of int_tounixspec() */
7388
7389
7390 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7391 static char *
7392 mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7393 {
7394     static char __tounixspec_retbuf[VMS_MAXRSS];
7395     char * unixspec, *ret_spec, *ret_buf;
7396
7397     unixspec = NULL;
7398     ret_buf = buf;
7399     if (ret_buf == NULL) {
7400         if (ts) {
7401             Newx(unixspec, VMS_MAXRSS, char);
7402             if (unixspec == NULL)
7403                 _ckvmssts(SS$_INSFMEM);
7404             ret_buf = unixspec;
7405         } else {
7406             ret_buf = __tounixspec_retbuf;
7407         }
7408     }
7409
7410     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7411
7412     if (ret_spec == NULL) {
7413        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7414        if (unixspec)
7415            Safefree(unixspec);
7416     }
7417
7418     return ret_spec;
7419
7420 }  /* end of do_tounixspec() */
7421 /*}}}*/
7422 /* External entry points */
7423 char *
7424 Perl_tounixspec(pTHX_ const char *spec, char *buf)
7425 {
7426     return do_tounixspec(spec, buf, 0, NULL);
7427 }
7428
7429 char *
7430 Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7431 {
7432     return do_tounixspec(spec,buf,1, NULL);
7433 }
7434
7435 char *
7436 Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7437 {
7438     return do_tounixspec(spec,buf,0, utf8_fl);
7439 }
7440
7441 char *
7442 Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7443 {
7444     return do_tounixspec(spec,buf,1, utf8_fl);
7445 }
7446
7447 /*
7448  This procedure is used to identify if a path is based in either
7449  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7450  it returns the OpenVMS format directory for it.
7451
7452  It is expecting specifications of only '/' or '/xxxx/'
7453
7454  If a posix root does not exist, or 'xxxx' is not a directory
7455  in the posix root, it returns a failure.
7456
7457  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7458
7459  It is used only internally by posix_to_vmsspec_hardway().
7460  */
7461
7462 static int
7463 posix_root_to_vms(char *vmspath, int vmspath_len,
7464                   const char *unixpath, const int * utf8_fl)
7465 {
7466   int sts;
7467   struct FAB myfab = cc$rms_fab;
7468   rms_setup_nam(mynam);
7469   struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7470   struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7471   char * esa, * esal, * rsa, * rsal;
7472   int dir_flag;
7473   int unixlen;
7474
7475   dir_flag = 0;
7476   vmspath[0] = '\0';
7477   unixlen = strlen(unixpath);
7478   if (unixlen == 0) {
7479     return RMS$_FNF;
7480   }
7481
7482 #if __CRTL_VER >= 80200000
7483   /* If not a posix spec already, convert it */
7484   if (DECC_POSIX_COMPLIANT_PATHNAMES) {
7485     if (! strBEGINs(unixpath,"\"^UP^")) {
7486       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7487     }
7488     else {
7489       /* This is already a VMS specification, no conversion */
7490       unixlen--;
7491       my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7492     }
7493   }
7494   else
7495 #endif
7496   {
7497      int path_len;
7498      int i,j;
7499
7500      /* Check to see if this is under the POSIX root */
7501      if (DECC_DISABLE_POSIX_ROOT) {
7502         return RMS$_FNF;
7503      }
7504
7505      /* Skip leading / */
7506      if (unixpath[0] == '/') {
7507         unixpath++;
7508         unixlen--;
7509      }
7510
7511
7512      strcpy(vmspath,"SYS$POSIX_ROOT:");
7513
7514      /* If this is only the / , or blank, then... */
7515      if (unixpath[0] == '\0') {
7516         /* by definition, this is the answer */
7517         return SS$_NORMAL;
7518      }
7519
7520      /* Need to look up a directory */
7521      vmspath[15] = '[';
7522      vmspath[16] = '\0';
7523
7524      /* Copy and add '^' escape characters as needed */
7525      j = 16;
7526      i = 0;
7527      while (unixpath[i] != 0) {
7528      int k;
7529
7530         j += copy_expand_unix_filename_escape
7531             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7532         i += k;
7533      }
7534
7535      path_len = strlen(vmspath);
7536      if (vmspath[path_len - 1] == '/')
7537         path_len--;
7538      vmspath[path_len] = ']';
7539      path_len++;
7540      vmspath[path_len] = '\0';
7541
7542   }
7543   vmspath[vmspath_len] = 0;
7544   if (unixpath[unixlen - 1] == '/')
7545   dir_flag = 1;
7546   esal = (char *)PerlMem_malloc(VMS_MAXRSS);
7547   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7548   esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7549   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7550   rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
7551   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7552   rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
7553   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7554   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7555   rms_bind_fab_nam(myfab, mynam);
7556   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7557   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7558   if (DECC_EFS_CASE_PRESERVE)
7559     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7560 #ifdef NAML$M_OPEN_SPECIAL
7561   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7562 #endif
7563
7564   /* Set up the remaining naml fields */
7565   sts = sys$parse(&myfab);
7566
7567   /* It failed! Try again as a UNIX filespec */
7568   if (!(sts & 1)) {
7569     PerlMem_free(esal);
7570     PerlMem_free(esa);
7571     PerlMem_free(rsal);
7572     PerlMem_free(rsa);
7573     return sts;
7574   }
7575
7576    /* get the Device ID and the FID */
7577    sts = sys$search(&myfab);
7578
7579    /* These are no longer needed */
7580    PerlMem_free(esa);
7581    PerlMem_free(rsal);
7582    PerlMem_free(rsa);
7583
7584    /* on any failure, returned the POSIX ^UP^ filespec */
7585    if (!(sts & 1)) {
7586       PerlMem_free(esal);
7587       return sts;
7588    }
7589    specdsc.dsc$a_pointer = vmspath;
7590    specdsc.dsc$w_length = vmspath_len;
7591
7592    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7593    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7594    sts = lib$fid_to_name
7595       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7596
7597   /* on any failure, returned the POSIX ^UP^ filespec */
7598   if (!(sts & 1)) {
7599      /* This can happen if user does not have permission to read directories */
7600      if (! strBEGINs(unixpath,"\"^UP^"))
7601        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7602      else
7603        my_strlcpy(vmspath, unixpath, vmspath_len + 1);
7604   }
7605   else {
7606     vmspath[specdsc.dsc$w_length] = 0;
7607
7608     /* Are we expecting a directory? */
7609     if (dir_flag != 0) {
7610     int i;
7611     char *eptr;
7612
7613       eptr = NULL;
7614
7615       i = specdsc.dsc$w_length - 1;
7616       while (i > 0) {
7617       int zercnt;
7618         zercnt = 0;
7619         /* Version must be '1' */
7620         if (vmspath[i--] != '1')
7621           break;
7622         /* Version delimiter is one of ".;" */
7623         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7624           break;
7625         i--;
7626         if (vmspath[i--] != 'R')
7627           break;
7628         if (vmspath[i--] != 'I')
7629           break;
7630         if (vmspath[i--] != 'D')
7631           break;
7632         if (vmspath[i--] != '.')
7633           break;
7634         eptr = &vmspath[i+1];
7635         while (i > 0) {
7636           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7637             if (vmspath[i-1] != '^') {
7638               if (zercnt != 6) {
7639                 *eptr = vmspath[i];
7640                 eptr[1] = '\0';
7641                 vmspath[i] = '.';
7642                 break;
7643               }
7644               else {
7645                 /* Get rid of 6 imaginary zero directory filename */
7646                 vmspath[i+1] = '\0';
7647               }
7648             }
7649           }
7650           if (vmspath[i] == '0')
7651             zercnt++;
7652           else
7653             zercnt = 10;
7654           i--;
7655         }
7656         break;
7657       }
7658     }
7659   }
7660   PerlMem_free(esal);
7661   return sts;
7662 }
7663
7664 /* /dev/mumble needs to be handled special.
7665    /dev/null becomes NLA0:, And there is the potential for other stuff
7666    like /dev/tty which may need to be mapped to something.
7667 */
7668
7669 static int
7670 slash_dev_special_to_vms(const char *unixptr, char *vmspath, int vmspath_len)
7671 {
7672     char * nextslash;
7673     int len;
7674
7675     unixptr += 4;
7676     nextslash = strchr(unixptr, '/');
7677     len = strlen(unixptr);
7678     if (nextslash != NULL)
7679         len = nextslash - unixptr;
7680     if (strEQ(unixptr, "null")) {
7681         if (vmspath_len >= 6) {
7682             strcpy(vmspath, "_NLA0:");
7683             return SS$_NORMAL;
7684         }
7685     }
7686     return 0;
7687 }
7688
7689
7690 /* The built in routines do not understand perl's special needs, so
7691     doing a manual conversion from UNIX to VMS
7692
7693     If the utf8_fl is not null and points to a non-zero value, then
7694     treat 8 bit characters as UTF-8.
7695
7696     The sequence starting with '$(' and ending with ')' will be passed
7697     through with out interpretation instead of being escaped.
7698
7699   */
7700 static int
7701 posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath,
7702                          int dir_flag, int * utf8_fl)
7703 {
7704
7705   char *esa;
7706   const char *unixptr;
7707   const char *unixend;
7708   char *vmsptr;
7709   const char *lastslash;
7710   const char *lastdot;
7711   int unixlen;
7712   int vmslen;
7713   int dir_start;
7714   int dir_dot;
7715   int quoted;
7716   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7717   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7718
7719   if (utf8_fl != NULL)
7720     *utf8_fl = 0;
7721
7722   unixptr = unixpath;
7723   dir_dot = 0;
7724
7725   /* Ignore leading "/" characters */
7726   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7727     unixptr++;
7728   }
7729   unixlen = strlen(unixptr);
7730
7731   /* Do nothing with blank paths */
7732   if (unixlen == 0) {
7733     vmspath[0] = '\0';
7734     return SS$_NORMAL;
7735   }
7736
7737   quoted = 0;
7738   /* This could have a "^UP^ on the front */
7739   if (strBEGINs(unixptr,"\"^UP^")) {
7740     quoted = 1;
7741     unixptr+= 5;
7742     unixlen-= 5;
7743   }
7744
7745   lastslash = strrchr(unixptr,'/');
7746   lastdot = strrchr(unixptr,'.');
7747   unixend = strrchr(unixptr,'\"');
7748   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7749     unixend = unixptr + unixlen;
7750   }
7751
7752   /* last dot is last dot or past end of string */
7753   if (lastdot == NULL)
7754     lastdot = unixptr + unixlen;
7755
7756   /* if no directories, set last slash to beginning of string */
7757   if (lastslash == NULL) {
7758     lastslash = unixptr;
7759   }
7760   else {
7761     /* Watch out for trailing "." after last slash, still a directory */
7762     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7763       lastslash = unixptr + unixlen;
7764     }
7765
7766     /* Watch out for trailing ".." after last slash, still a directory */
7767     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7768       lastslash = unixptr + unixlen;
7769     }
7770
7771     /* dots in directories are aways escaped */
7772     if (lastdot < lastslash)
7773       lastdot = unixptr + unixlen;
7774   }
7775
7776   /* if (unixptr < lastslash) then we are in a directory */
7777
7778   dir_start = 0;
7779
7780   vmsptr = vmspath;
7781   vmslen = 0;
7782
7783   /* Start with the UNIX path */
7784   if (*unixptr != '/') {
7785     /* relative paths */
7786
7787     /* If allowing logical names on relative pathnames, then handle here */
7788     if ((unixptr[0] != '.') && !DECC_DISABLE_TO_VMS_LOGNAME_TRANSLATION &&
7789         !DECC_POSIX_COMPLIANT_PATHNAMES) {
7790     char * nextslash;
7791     int seg_len;
7792     char * trn;
7793     int islnm;
7794
7795         /* Find the next slash */
7796         nextslash = strchr(unixptr,'/');
7797
7798         esa = (char *)PerlMem_malloc(vmspath_len);
7799         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7800
7801         trn = (char *)PerlMem_malloc(VMS_MAXRSS);
7802         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7803
7804         if (nextslash != NULL) {
7805
7806             seg_len = nextslash - unixptr;
7807             memcpy(esa, unixptr, seg_len);
7808             esa[seg_len] = 0;
7809         }
7810         else {
7811             seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
7812         }
7813         /* trnlnm(section) */
7814         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7815
7816         if (islnm) {
7817             /* Now fix up the directory */
7818
7819             /* Split up the path to find the components */
7820             sts = vms_split_path
7821                   (trn,
7822                    &v_spec,
7823                    &v_len,
7824                    &r_spec,
7825                    &r_len,
7826                    &d_spec,
7827                    &d_len,
7828                    &n_spec,
7829                    &n_len,
7830                    &e_spec,
7831                    &e_len,
7832                    &vs_spec,
7833                    &vs_len);
7834
7835             while (sts == 0) {
7836
7837                 /* A logical name must be a directory  or the full
7838                    specification.  It is only a full specification if
7839                    it is the only component */
7840                 if ((unixptr[seg_len] == '\0') ||
7841                     (unixptr[seg_len+1] == '\0')) {
7842
7843                     /* Is a directory being required? */
7844                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7845                         /* Not a logical name */
7846                         break;
7847                     }
7848
7849
7850                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7851                         /* This must be a directory */
7852                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7853                             vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
7854                             vmsptr[vmslen] = ':';
7855                             vmslen++;
7856                             vmsptr[vmslen] = '\0';
7857                             return SS$_NORMAL;
7858                         }
7859                     }
7860
7861                 }
7862
7863
7864                 /* must be dev/directory - ignore version */
7865                 if ((n_len + e_len) != 0)
7866                     break;
7867
7868                 /* transfer the volume */
7869                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7870                     memcpy(vmsptr, v_spec, v_len);
7871                     vmsptr += v_len;
7872                     vmsptr[0] = '\0';
7873                     vmslen += v_len;
7874                 }
7875
7876                 /* unroot the rooted directory */
7877                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7878                     r_spec[0] = '[';
7879                     r_spec[r_len - 1] = ']';
7880
7881                     /* This should not be there, but nothing is perfect */
7882                     if (r_len > 9) {
7883                         if (strEQ(&r_spec[1], "000000.")) {
7884                             r_spec += 7;
7885                             r_spec[7] = '[';
7886                             r_len -= 7;
7887                             if (r_len == 2)
7888                                 r_len = 0;
7889                         }
7890                     }
7891                     if (r_len > 0) {
7892                         memcpy(vmsptr, r_spec, r_len);
7893                         vmsptr += r_len;
7894                         vmslen += r_len;
7895                         vmsptr[0] = '\0';
7896                     }
7897                 }
7898                 /* Bring over the directory. */
7899                 if ((d_len > 0) &&
7900                     ((d_len + vmslen) < vmspath_len)) {
7901                     d_spec[0] = '[';
7902                     d_spec[d_len - 1] = ']';
7903                     if (d_len > 9) {
7904                         if (strEQ(&d_spec[1], "000000.")) {
7905                             d_spec += 7;
7906                             d_spec[7] = '[';
7907                             d_len -= 7;
7908                             if (d_len == 2)
7909                                 d_len = 0;
7910                         }
7911                     }
7912
7913                     if (r_len > 0) {
7914                         /* Remove the redundant root */
7915                         if (r_len > 0) {
7916                             /* remove the ][ */
7917                             vmsptr--;
7918                             vmslen--;
7919                             d_spec++;
7920                             d_len--;
7921                         }
7922                         memcpy(vmsptr, d_spec, d_len);
7923                             vmsptr += d_len;
7924                             vmslen += d_len;
7925                             vmsptr[0] = '\0';
7926                     }
7927                 }
7928                 break;
7929             }
7930         }
7931
7932         PerlMem_free(esa);
7933         PerlMem_free(trn);
7934     }
7935
7936     if (lastslash > unixptr) {
7937     int dotdir_seen;
7938
7939       /* skip leading ./ */
7940       dotdir_seen = 0;
7941       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7942         dotdir_seen = 1;
7943         unixptr++;
7944         unixptr++;
7945       }
7946
7947       /* Are we still in a directory? */
7948       if (unixptr <= lastslash) {
7949         *vmsptr++ = '[';
7950         vmslen = 1;
7951         dir_start = 1;
7952
7953         /* if not backing up, then it is relative forward. */
7954         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7955               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7956           *vmsptr++ = '.';
7957           vmslen++;
7958           dir_dot = 1;
7959           }
7960        }
7961        else {
7962          if (dotdir_seen) {
7963            /* Perl wants an empty directory here to tell the difference
7964             * between a DCL command and a filename
7965             */
7966           *vmsptr++ = '[';
7967           *vmsptr++ = ']';
7968           vmslen = 2;
7969         }
7970       }
7971     }
7972     else {
7973       /* Handle two special files . and .. */
7974       if (unixptr[0] == '.') {
7975         if (&unixptr[1] == unixend) {
7976           *vmsptr++ = '[';
7977           *vmsptr++ = ']';
7978           vmslen += 2;
7979           *vmsptr++ = '\0';
7980           return SS$_NORMAL;
7981         }
7982         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7983           *vmsptr++ = '[';
7984           *vmsptr++ = '-';
7985           *vmsptr++ = ']';
7986           vmslen += 3;
7987           *vmsptr++ = '\0';
7988           return SS$_NORMAL;
7989         }
7990       }
7991     }
7992   }
7993   else {        /* Absolute PATH handling */
7994   int sts;
7995   char * nextslash;
7996   int seg_len;
7997     /* Need to find out where root is */
7998
7999     /* In theory, this procedure should never get an absolute POSIX pathname
8000      * that can not be found on the POSIX root.
8001      * In practice, that can not be relied on, and things will show up
8002      * here that are a VMS device name or concealed logical name instead.
8003      * So to make things work, this procedure must be tolerant.
8004      */
8005     esa = (char *)PerlMem_malloc(vmspath_len);
8006     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8007
8008     sts = SS$_NORMAL;
8009     nextslash = strchr(&unixptr[1],'/');
8010     seg_len = 0;
8011     if (nextslash != NULL) {
8012       seg_len = nextslash - &unixptr[1];
8013       my_strlcpy(vmspath, unixptr, seg_len + 2);
8014       if (memEQs(vmspath, seg_len, "dev")) {
8015             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8016             if (sts == SS$_NORMAL)
8017                 return SS$_NORMAL;
8018       }
8019       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8020     }
8021
8022     if ($VMS_STATUS_SUCCESS(sts)) {
8023       /* This is verified to be a real path */
8024
8025       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8026       if ($VMS_STATUS_SUCCESS(sts)) {
8027         vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
8028         vmsptr = vmspath + vmslen;
8029         unixptr++;
8030         if (unixptr < lastslash) {
8031         char * rptr;
8032           vmsptr--;
8033           *vmsptr++ = '.';
8034           dir_start = 1;
8035           dir_dot = 1;
8036           if (vmslen > 7) {
8037             rptr = vmsptr - 7;
8038             if (strEQ(rptr,"000000.")) {
8039               vmslen -= 7;
8040               vmsptr -= 7;
8041               vmsptr[1] = '\0';
8042             } /* removing 6 zeros */
8043           } /* vmslen < 7, no 6 zeros possible */
8044         } /* Not in a directory */
8045       } /* Posix root found */
8046       else {
8047         /* No posix root, fall back to default directory */
8048         strcpy(vmspath, "SYS$DISK:[");
8049         vmsptr = &vmspath[10];
8050         vmslen = 10;
8051         if (unixptr > lastslash) {
8052            *vmsptr = ']';
8053            vmsptr++;
8054            vmslen++;
8055         }
8056         else {
8057            dir_start = 1;
8058         }
8059       }
8060     } /* end of verified real path handling */
8061     else {
8062     int add_6zero;
8063     int islnm;
8064
8065       /* Ok, we have a device or a concealed root that is not in POSIX
8066        * or we have garbage.  Make the best of it.
8067        */
8068
8069       /* Posix to VMS destroyed this, so copy it again */
8070       my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
8071       vmslen = strlen(vmspath); /* We know we're truncating. */
8072       vmsptr = &vmsptr[vmslen];
8073       islnm = 0;
8074
8075       /* Now do we need to add the fake 6 zero directory to it? */
8076       add_6zero = 1;
8077       if ((*lastslash == '/') && (nextslash < lastslash)) {
8078         /* No there is another directory */
8079         add_6zero = 0;
8080       }
8081       else {
8082       int trnend;
8083
8084         /* now we have foo:bar or foo:[000000]bar to decide from */
8085         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8086
8087         if (!islnm && !DECC_POSIX_COMPLIANT_PATHNAMES) {
8088             if (strEQ(vmspath, "bin")) {
8089                 /* bin => SYS$SYSTEM: */
8090                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8091             }
8092             else {
8093                 /* tmp => SYS$SCRATCH: */
8094                 if (strEQ(vmspath, "tmp")) {
8095                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8096                 }
8097             }
8098         }
8099
8100         trnend = islnm ? islnm - 1 : 0;
8101
8102         /* if this was a logical name, ']' or '>' must be present */
8103         /* if not a logical name, then assume a device and hope. */
8104         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8105
8106         /* if log name and trailing '.' then rooted - treat as device */
8107         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8108
8109         /* Fix me, if not a logical name, a device lookup should be
8110          * done to see if the device is file structured.  If the device
8111          * is not file structured, the 6 zeros should not be put on.
8112          *
8113          * As it is, perl is occasionally looking for dev:[000000]tty.
8114          * which looks a little strange.
8115          *
8116          * Not that easy to detect as "/dev" may be file structured with
8117          * special device files.
8118          */
8119
8120         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
8121             (&nextslash[1] == unixend)) {
8122           /* No real directory present */
8123           add_6zero = 1;
8124         }
8125       }
8126
8127       /* Put the device delimiter on */
8128       *vmsptr++ = ':';
8129       vmslen++;
8130       unixptr = nextslash;
8131       unixptr++;
8132
8133       /* Start directory if needed */
8134       if (!islnm || add_6zero) {
8135         *vmsptr++ = '[';
8136         vmslen++;
8137         dir_start = 1;
8138       }
8139
8140       /* add fake 000000] if needed */
8141       if (add_6zero) {
8142         *vmsptr++ = '0';
8143         *vmsptr++ = '0';
8144         *vmsptr++ = '0';
8145         *vmsptr++ = '0';
8146         *vmsptr++ = '0';
8147         *vmsptr++ = '0';
8148         *vmsptr++ = ']';
8149         vmslen += 7;
8150         dir_start = 0;
8151       }
8152
8153     } /* non-POSIX translation */
8154     PerlMem_free(esa);
8155   } /* End of relative/absolute path handling */
8156
8157   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8158     int dash_flag;
8159     int in_cnt;
8160     int out_cnt;
8161
8162     dash_flag = 0;
8163
8164     if (dir_start != 0) {
8165
8166       /* First characters in a directory are handled special */
8167       while ((*unixptr == '/') ||
8168              ((*unixptr == '.') &&
8169               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8170                 (&unixptr[1]==unixend)))) {
8171       int loop_flag;
8172
8173         loop_flag = 0;
8174
8175         /* Skip redundant / in specification */
8176         while ((*unixptr == '/') && (dir_start != 0)) {
8177           loop_flag = 1;
8178           unixptr++;
8179           if (unixptr == lastslash)
8180             break;
8181         }
8182         if (unixptr == lastslash)
8183           break;
8184
8185         /* Skip redundant ./ characters */
8186         while ((*unixptr == '.') &&
8187                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8188           loop_flag = 1;
8189           unixptr++;
8190           if (unixptr == lastslash)
8191             break;
8192           if (*unixptr == '/')
8193             unixptr++;
8194         }
8195         if (unixptr == lastslash)
8196           break;
8197
8198         /* Skip redundant ../ characters */
8199         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8200              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8201           /* Set the backing up flag */
8202           loop_flag = 1;
8203           dir_dot = 0;
8204           dash_flag = 1;
8205           *vmsptr++ = '-';
8206           vmslen++;
8207           unixptr++; /* first . */
8208           unixptr++; /* second . */
8209           if (unixptr == lastslash)
8210             break;
8211           if (*unixptr == '/') /* The slash */
8212             unixptr++;
8213         }
8214         if (unixptr == lastslash)
8215           break;
8216
8217         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8218         /* Not needed when VMS is pretending to be UNIX. */
8219
8220         /* Is this loop stuck because of too many dots? */
8221         if (loop_flag == 0) {
8222           /* Exit the loop and pass the rest through */
8223           break;
8224         }
8225       }
8226
8227       /* Are we done with directories yet? */
8228       if (unixptr >= lastslash) {
8229
8230         /* Watch out for trailing dots */
8231         if (dir_dot != 0) {
8232             vmslen --;
8233             vmsptr--;
8234         }
8235         *vmsptr++ = ']';
8236         vmslen++;
8237         dash_flag = 0;
8238         dir_start = 0;
8239         if (*unixptr == '/')
8240           unixptr++;
8241       }
8242       else {
8243         /* Have we stopped backing up? */
8244         if (dash_flag) {
8245           *vmsptr++ = '.';
8246           vmslen++;
8247           dash_flag = 0;
8248           /* dir_start continues to be = 1 */
8249         }
8250         if (*unixptr == '-') {
8251           *vmsptr++ = '^';
8252           *vmsptr++ = *unixptr++;
8253           vmslen += 2;
8254           dir_start = 0;
8255
8256           /* Now are we done with directories yet? */
8257           if (unixptr >= lastslash) {
8258
8259             /* Watch out for trailing dots */
8260             if (dir_dot != 0) {
8261               vmslen --;
8262               vmsptr--;
8263             }
8264
8265             *vmsptr++ = ']';
8266             vmslen++;
8267             dash_flag = 0;
8268             dir_start = 0;
8269           }
8270         }
8271       }
8272     }
8273
8274     /* All done? */
8275     if (unixptr >= unixend)
8276       break;
8277
8278     /* Normal characters - More EFS work probably needed */
8279     dir_start = 0;
8280     dir_dot = 0;
8281
8282     switch(*unixptr) {
8283     case '/':
8284         /* remove multiple / */
8285         while (unixptr[1] == '/') {
8286            unixptr++;
8287         }
8288         if (unixptr == lastslash) {
8289           /* Watch out for trailing dots */
8290           if (dir_dot != 0) {
8291             vmslen --;
8292             vmsptr--;
8293           }
8294           *vmsptr++ = ']';
8295         }
8296         else {
8297           dir_start = 1;
8298           *vmsptr++ = '.';
8299           dir_dot = 1;
8300
8301           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8302           /* Not needed when VMS is pretending to be UNIX. */
8303
8304         }
8305         dash_flag = 0;
8306         if (unixptr != unixend)
8307           unixptr++;
8308         vmslen++;
8309         break;
8310     case '.':
8311         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8312             (&unixptr[1] == unixend)) {
8313           *vmsptr++ = '^';
8314           *vmsptr++ = '.';
8315           vmslen += 2;
8316           unixptr++;
8317
8318           /* trailing dot ==> '^..' on VMS */
8319           if (unixptr == unixend) {
8320             *vmsptr++ = '.';
8321             vmslen++;
8322             unixptr++;
8323           }
8324           break;
8325         }
8326
8327         *vmsptr++ = *unixptr++;
8328         vmslen ++;
8329         break;
8330     case '"':
8331         if (quoted && (&unixptr[1] == unixend)) {
8332             unixptr++;
8333             break;
8334         }
8335         in_cnt = copy_expand_unix_filename_escape
8336                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8337         vmsptr += out_cnt;
8338         unixptr += in_cnt;
8339         break;
8340     case ';':
8341     case '\\':
8342     case '?':
8343     case ' ':
8344     default:
8345         in_cnt = copy_expand_unix_filename_escape
8346                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8347         vmsptr += out_cnt;
8348         unixptr += in_cnt;
8349         break;
8350     }
8351   }
8352
8353   /* Make sure directory is closed */
8354   if (unixptr == lastslash) {
8355     char *vmsptr2;
8356     vmsptr2 = vmsptr - 1;
8357
8358     if (*vmsptr2 != ']') {
8359       *vmsptr2--;
8360
8361       /* directories do not end in a dot bracket */
8362       if (*vmsptr2 == '.') {
8363         vmsptr2--;
8364
8365         /* ^. is allowed */
8366         if (*vmsptr2 != '^') {
8367           vmsptr--; /* back up over the dot */
8368         }
8369       }
8370       *vmsptr++ = ']';
8371     }
8372   }
8373   else {
8374     char *vmsptr2;
8375     /* Add a trailing dot if a file with no extension */
8376     vmsptr2 = vmsptr - 1;
8377     if ((vmslen > 1) &&
8378         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8379         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8380         *vmsptr++ = '.';
8381         vmslen++;
8382     }
8383   }
8384
8385   *vmsptr = '\0';
8386   return SS$_NORMAL;
8387 }
8388
8389 /* A convenience macro for copying dots in filenames and escaping
8390  * them when they haven't already been escaped, with guards to
8391  * avoid checking before the start of the buffer or advancing
8392  * beyond the end of it (allowing room for the NUL terminator).
8393  */
8394 #define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
8395     if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8396           || ((vmsefsdot) == (vmsefsbuf))) \
8397          && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
8398        ) { \
8399         *((vmsefsdot)++) = '^'; \
8400     } \
8401     if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8402         *((vmsefsdot)++) = '.'; \
8403 } STMT_END
8404
8405 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8406 static char *
8407 int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag)
8408 {
8409   char *dirend;
8410   char *lastdot;
8411   char *cp1;
8412   const char *cp2;
8413   unsigned long int infront = 0, hasdir = 1;
8414   int rslt_len;
8415   int no_type_seen;
8416   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8417   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8418
8419   if (vms_debug_fileify) {
8420       if (path == NULL)
8421           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8422       else
8423           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8424   }
8425
8426   if (path == NULL) {
8427       /* If we fail, we should be setting errno */
8428       set_errno(EINVAL);
8429       set_vaxc_errno(SS$_BADPARAM);
8430       return NULL;
8431   }
8432   rslt_len = VMS_MAXRSS-1;
8433
8434   /* '.' and '..' are "[]" and "[-]" for a quick check */
8435   if (path[0] == '.') {
8436     if (path[1] == '\0') {
8437       strcpy(rslt,"[]");
8438       if (utf8_flag != NULL)
8439         *utf8_flag = 0;
8440       return rslt;
8441     }
8442     else {
8443       if (path[1] == '.' && path[2] == '\0') {
8444         strcpy(rslt,"[-]");
8445         if (utf8_flag != NULL)
8446            *utf8_flag = 0;
8447         return rslt;
8448       }
8449     }
8450   }
8451
8452    /* Posix specifications are now a native VMS format */
8453   /*--------------------------------------------------*/
8454 #if __CRTL_VER >= 80200000
8455   if (DECC_POSIX_COMPLIANT_PATHNAMES) {
8456     if (strBEGINs(path,"\"^UP^")) {
8457       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8458       return rslt;
8459     }
8460   }
8461 #endif
8462
8463   /* This is really the only way to see if this is already in VMS format */
8464   sts = vms_split_path
8465        (path,
8466         &v_spec,
8467         &v_len,
8468         &r_spec,
8469         &r_len,
8470         &d_spec,
8471         &d_len,
8472         &n_spec,
8473         &n_len,
8474         &e_spec,
8475         &e_len,
8476         &vs_spec,
8477         &vs_len);
8478   if (sts == 0) {
8479     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8480        replacement, because the above parse just took care of most of
8481        what is needed to do vmspath when the specification is already
8482        in VMS format.
8483
8484        And if it is not already, it is easier to do the conversion as
8485        part of this routine than to call this routine and then work on
8486        the result.
8487      */
8488
8489     /* If VMS punctuation was found, it is already VMS format */
8490     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8491       if (utf8_flag != NULL)
8492         *utf8_flag = 0;
8493       my_strlcpy(rslt, path, VMS_MAXRSS);
8494       if (vms_debug_fileify) {
8495           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8496       }
8497       return rslt;
8498     }
8499     /* Now, what to do with trailing "." cases where there is no
8500        extension?  If this is a UNIX specification, and EFS characters
8501        are enabled, then the trailing "." should be converted to a "^.".
8502        But if this was already a VMS specification, then it should be
8503        left alone.
8504
8505        So in the case of ambiguity, leave the specification alone.
8506      */
8507
8508
8509     /* If there is a possibility of UTF8, then if any UTF8 characters
8510         are present, then they must be converted to VTF-7
8511      */
8512     if (utf8_flag != NULL)
8513       *utf8_flag = 0;
8514     my_strlcpy(rslt, path, VMS_MAXRSS);
8515     if (vms_debug_fileify) {
8516         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8517     }
8518     return rslt;
8519   }
8520
8521   dirend = strrchr(path,'/');
8522
8523   if (dirend == NULL) {
8524      /* If we get here with no Unix directory delimiters, then this is an
8525       * ambiguous file specification, such as a Unix glob specification, a
8526       * shell or make macro, or a filespec that would be valid except for
8527       * unescaped extended characters.  The safest thing if it's a macro
8528       * is to pass it through as-is.
8529       */
8530       if (strstr(path, "$(")) {
8531           my_strlcpy(rslt, path, VMS_MAXRSS);
8532           if (vms_debug_fileify) {
8533               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8534           }
8535           return rslt;
8536       }
8537       hasdir = 0;
8538   }
8539   else if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8540     if (!*(dirend+2)) dirend +=2;
8541     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8542     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8543   }
8544
8545   cp1 = rslt;
8546   cp2 = path;
8547   lastdot = strrchr(cp2,'.');
8548   if (*cp2 == '/') {
8549     char *trndev;
8550     int islnm, rooted;
8551     STRLEN trnend;
8552
8553     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8554     if (!*(cp2+1)) {
8555       if (DECC_DISABLE_POSIX_ROOT) {
8556         strcpy(rslt,"sys$disk:[000000]");
8557       }
8558       else {
8559         strcpy(rslt,"sys$posix_root:[000000]");
8560       }
8561       if (utf8_flag != NULL)
8562         *utf8_flag = 0;
8563       if (vms_debug_fileify) {
8564           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8565       }
8566       return rslt;
8567     }
8568     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8569     *cp1 = '\0';
8570     trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
8571     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8572     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8573
8574      /* DECC special handling */
8575     if (!islnm) {
8576       if (strEQ(rslt,"bin")) {
8577         strcpy(rslt,"sys$system");
8578         cp1 = rslt + 10;
8579         *cp1 = 0;
8580         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8581       }
8582       else if (strEQ(rslt,"tmp")) {
8583         strcpy(rslt,"sys$scratch");
8584         cp1 = rslt + 11;
8585         *cp1 = 0;
8586         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8587       }
8588       else if (!DECC_DISABLE_POSIX_ROOT) {
8589         strcpy(rslt, "sys$posix_root");
8590         cp1 = rslt + 14;
8591         *cp1 = 0;
8592         cp2 = path;
8593         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8594         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8595       }
8596       else if (strEQ(rslt,"dev")) {
8597         if (strBEGINs(cp2,"/null")) {
8598           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8599             strcpy(rslt,"NLA0");
8600             cp1 = rslt + 4;
8601             *cp1 = 0;
8602             cp2 = cp2 + 5;
8603             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8604           }
8605         }
8606       }
8607     }
8608
8609     trnend = islnm ? strlen(trndev) - 1 : 0;
8610     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8611     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8612     /* If the first element of the path is a logical name, determine
8613      * whether it has to be translated so we can add more directories. */
8614     if (!islnm || rooted) {
8615       *(cp1++) = ':';
8616       *(cp1++) = '[';
8617       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8618       else cp2++;
8619     }
8620     else {
8621       if (cp2 != dirend) {
8622         my_strlcpy(rslt, trndev, VMS_MAXRSS);
8623         cp1 = rslt + trnend;
8624         if (*cp2 != 0) {
8625           *(cp1++) = '.';
8626           cp2++;
8627         }
8628       }
8629       else {
8630         if (DECC_DISABLE_POSIX_ROOT) {
8631           *(cp1++) = ':';
8632           hasdir = 0;
8633         }
8634       }
8635     }
8636     PerlMem_free(trndev);
8637   }
8638   else if (hasdir) {
8639     *(cp1++) = '[';
8640     if (*cp2 == '.') {
8641       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8642         cp2 += 2;         /* skip over "./" - it's redundant */
8643         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8644       }
8645       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8646         *(cp1++) = '-';                                 /* "../" --> "-" */
8647         cp2 += 3;
8648       }
8649       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8650                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8651         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8652         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8653         cp2 += 4;
8654       }
8655       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8656         /* Escape the extra dots in EFS file specifications */
8657         *(cp1++) = '^';
8658       }
8659       if (cp2 > dirend) cp2 = dirend;
8660     }
8661     else *(cp1++) = '.';
8662   }
8663   for (; cp2 < dirend; cp2++) {
8664     if (*cp2 == '/') {
8665       if (*(cp2-1) == '/') continue;
8666       if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
8667       infront = 0;
8668     }
8669     else if (!infront && *cp2 == '.') {
8670       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8671       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8672       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8673         if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
8674         else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
8675         else {
8676           *(cp1++) = '-';
8677         }
8678         cp2 += 2;
8679         if (cp2 == dirend) break;
8680       }
8681       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8682                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8683         if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8684         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8685         if (!*(cp2+3)) {
8686           *(cp1++) = '.';  /* Simulate trailing '/' */
8687           cp2 += 2;  /* for loop will incr this to == dirend */
8688         }
8689         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8690       }
8691       else {
8692         if (DECC_EFS_CHARSET == 0) {
8693           if (cp1 > rslt && *(cp1-1) == '^')
8694             cp1--;         /* remove the escape, if any */
8695           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8696         }
8697         else {
8698           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8699         }
8700       }
8701     }
8702     else {
8703       if (!infront && cp1 > rslt && *(cp1-1) == '-')  *(cp1++) = '.';
8704       if (*cp2 == '.') {
8705         if (DECC_EFS_CHARSET == 0) {
8706           if (cp1 > rslt && *(cp1-1) == '^')
8707             cp1--;         /* remove the escape, if any */
8708           *(cp1++) = '_';
8709         }
8710         else {
8711           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8712         }
8713       }
8714       else {
8715         int out_cnt;
8716         cp2 += copy_expand_unix_filename_escape(cp1, cp2, &out_cnt, utf8_flag);
8717         cp2--; /* we're in a loop that will increment this */
8718         cp1 += out_cnt;
8719       }
8720       infront = 1;
8721     }
8722   }
8723   if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8724   if (hasdir) *(cp1++) = ']';
8725   if (*cp2 && *cp2 == '/') cp2++;  /* check in case we ended with trailing '/' */
8726   no_type_seen = 0;
8727   if (cp2 > lastdot)
8728     no_type_seen = 1;
8729   while (*cp2) {
8730     switch(*cp2) {
8731     case '?':
8732         if (DECC_EFS_CHARSET == 0)
8733           *(cp1++) = '%';
8734         else
8735           *(cp1++) = '?';
8736         cp2++;
8737         break;
8738     case ' ':
8739         if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
8740             *(cp1)++ = '^';
8741         *(cp1)++ = '_';
8742         cp2++;
8743         break;
8744     case '.':
8745         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8746             DECC_READDIR_DROPDOTNOTYPE) {
8747           VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
8748           cp2++;
8749
8750           /* trailing dot ==> '^..' on VMS */
8751           if (*cp2 == '\0') {
8752             *(cp1++) = '.';
8753             no_type_seen = 0;
8754           }
8755         }
8756         else {
8757           *(cp1++) = *(cp2++);
8758           no_type_seen = 0;
8759         }
8760         break;
8761     case '$':
8762          /* This could be a macro to be passed through */
8763         *(cp1++) = *(cp2++);
8764         if (*cp2 == '(') {
8765         const char * save_cp2;
8766         char * save_cp1;
8767         int is_macro;
8768
8769             /* paranoid check */
8770             save_cp2 = cp2;
8771             save_cp1 = cp1;
8772             is_macro = 0;
8773
8774             /* Test through */
8775             *(cp1++) = *(cp2++);
8776             if (isALPHA_L1(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8777                 *(cp1++) = *(cp2++);
8778                 while (isALPHA_L1(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8779                     *(cp1++) = *(cp2++);
8780                 }
8781                 if (*cp2 == ')') {
8782                     *(cp1++) = *(cp2++);
8783                     is_macro = 1;
8784                 }
8785             }
8786             if (is_macro == 0) {
8787                 /* Not really a macro - never mind */
8788                 cp2 = save_cp2;
8789                 cp1 = save_cp1;
8790             }
8791         }
8792         break;
8793     case '\"':
8794     case '`':
8795     case '!':
8796     case '#':
8797     case '%':
8798     case '^':
8799         /* Don't escape again if following character is
8800          * already something we escape.
8801          */
8802         if (strchr("\"`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8803             *(cp1++) = *(cp2++);
8804             break;
8805         }
8806         /* But otherwise fall through and escape it. */
8807     case '&':
8808     case '(':
8809     case ')':
8810     case '=':
8811     case '+':
8812     case '\'':
8813     case '@':
8814     case '[':
8815     case ']':
8816     case '{':
8817     case '}':
8818     case ':':
8819     case '\\':
8820     case '|':
8821     case '<':
8822     case '>':
8823         if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */
8824             *(cp1++) = '^';
8825         *(cp1++) = *(cp2++);
8826         break;
8827     case ';':
8828         /* If it doesn't look like the beginning of a version number,
8829          * or we've been promised there are no version numbers, then
8830          * escape it.
8831          */
8832         if (DECC_FILENAME_UNIX_NO_VERSION) {
8833           *(cp1++) = '^';
8834         }
8835         else {
8836           size_t all_nums = strspn(cp2+1, "0123456789");
8837           if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0')
8838             *(cp1++) = '^';
8839         }
8840         *(cp1++) = *(cp2++);
8841         break;
8842     default:
8843         *(cp1++) = *(cp2++);
8844     }
8845   }
8846   if ((no_type_seen == 1) && DECC_READDIR_DROPDOTNOTYPE) {
8847   char *lcp1;
8848     lcp1 = cp1;
8849     lcp1--;
8850      /* Fix me for "^]", but that requires making sure that you do
8851       * not back up past the start of the filename
8852       */
8853     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8854       *cp1++ = '.';
8855   }
8856   *cp1 = '\0';
8857
8858   if (utf8_flag != NULL)
8859     *utf8_flag = 0;
8860   if (vms_debug_fileify) {
8861       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8862   }
8863   return rslt;
8864
8865 }  /* end of int_tovmsspec() */
8866
8867
8868 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8869 static char *
8870 mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag)
8871 {
8872     static char __tovmsspec_retbuf[VMS_MAXRSS];
8873     char * vmsspec, *ret_spec, *ret_buf;
8874
8875     vmsspec = NULL;
8876     ret_buf = buf;
8877     if (ret_buf == NULL) {
8878         if (ts) {
8879             Newx(vmsspec, VMS_MAXRSS, char);
8880             if (vmsspec == NULL)
8881                 _ckvmssts(SS$_INSFMEM);
8882             ret_buf = vmsspec;
8883         } else {
8884             ret_buf = __tovmsspec_retbuf;
8885         }
8886     }
8887
8888     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8889
8890     if (ret_spec == NULL) {
8891        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8892        if (vmsspec)
8893            Safefree(vmsspec);
8894     }
8895
8896     return ret_spec;
8897
8898 }  /* end of mp_do_tovmsspec() */
8899 /*}}}*/
8900 /* External entry points */
8901 char *
8902 Perl_tovmsspec(pTHX_ const char *path, char *buf)
8903 {
8904     return do_tovmsspec(path, buf, 0, NULL);
8905 }
8906
8907 char *
8908 Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8909 {
8910     return do_tovmsspec(path, buf, 1, NULL);
8911 }
8912
8913 char *
8914 Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8915 {
8916     return do_tovmsspec(path, buf, 0, utf8_fl);
8917 }
8918
8919 char *
8920 Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8921 {
8922     return do_tovmsspec(path, buf, 1, utf8_fl);
8923 }
8924
8925 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8926 /* Internal routine for use with out an explicit context present */
8927 static char *
8928 int_tovmspath(const char *path, char *buf, int * utf8_fl)
8929 {
8930     char * ret_spec, *pathified;
8931
8932     if (path == NULL)
8933         return NULL;
8934
8935     pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8936     if (pathified == NULL)
8937         _ckvmssts_noperl(SS$_INSFMEM);
8938
8939     ret_spec = int_pathify_dirspec(path, pathified);
8940
8941     if (ret_spec == NULL) {
8942         PerlMem_free(pathified);
8943         return NULL;
8944     }
8945
8946     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8947
8948     PerlMem_free(pathified);
8949     return ret_spec;
8950
8951 }
8952
8953 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8954 static char *
8955 mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
8956 {
8957   static char __tovmspath_retbuf[VMS_MAXRSS];
8958   int vmslen;
8959   char *pathified, *vmsified, *cp;
8960
8961   if (path == NULL) return NULL;
8962   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
8963   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8964   if (int_pathify_dirspec(path, pathified) == NULL) {
8965     PerlMem_free(pathified);
8966     return NULL;
8967   }
8968
8969   vmsified = NULL;
8970   if (buf == NULL)
8971      Newx(vmsified, VMS_MAXRSS, char);
8972   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8973     PerlMem_free(pathified);
8974     if (vmsified) Safefree(vmsified);
8975     return NULL;
8976   }
8977   PerlMem_free(pathified);
8978   if (buf) {
8979     return buf;
8980   }
8981   else if (ts) {
8982     vmslen = strlen(vmsified);
8983     Newx(cp,vmslen+1,char);
8984     memcpy(cp,vmsified,vmslen);
8985     cp[vmslen] = '\0';
8986     Safefree(vmsified);
8987     return cp;
8988   }
8989   else {
8990     my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
8991     Safefree(vmsified);
8992     return __tovmspath_retbuf;
8993   }
8994
8995 }  /* end of do_tovmspath() */
8996 /*}}}*/
8997 /* External entry points */
8998 char *
8999 Perl_tovmspath(pTHX_ const char *path, char *buf)
9000 {
9001     return do_tovmspath(path, buf, 0, NULL);
9002 }
9003
9004 char *
9005 Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9006 {
9007     return do_tovmspath(path, buf, 1, NULL);
9008 }
9009
9010 char *
9011 Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9012 {
9013     return do_tovmspath(path, buf, 0, utf8_fl);
9014 }
9015
9016 char *
9017 Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9018 {
9019     return do_tovmspath(path, buf, 1, utf8_fl);
9020 }
9021
9022
9023 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9024 static char *
9025 mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
9026 {
9027   static char __tounixpath_retbuf[VMS_MAXRSS];
9028   int unixlen;
9029   char *pathified, *unixified, *cp;
9030
9031   if (path == NULL) return NULL;
9032   pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
9033   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9034   if (int_pathify_dirspec(path, pathified) == NULL) {
9035     PerlMem_free(pathified);
9036     return NULL;
9037   }
9038
9039   unixified = NULL;
9040   if (buf == NULL) {
9041       Newx(unixified, VMS_MAXRSS, char);
9042   }
9043   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9044     PerlMem_free(pathified);
9045     if (unixified) Safefree(unixified);
9046     return NULL;
9047   }
9048   PerlMem_free(pathified);
9049   if (buf) {
9050     return buf;
9051   }
9052   else if (ts) {
9053     unixlen = strlen(unixified);
9054     Newx(cp,unixlen+1,char);
9055     memcpy(cp,unixified,unixlen);
9056     cp[unixlen] = '\0';
9057     Safefree(unixified);
9058     return cp;
9059   }
9060   else {
9061     my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
9062     Safefree(unixified);
9063     return __tounixpath_retbuf;
9064   }
9065
9066 }  /* end of do_tounixpath() */
9067 /*}}}*/
9068 /* External entry points */
9069 char *
9070 Perl_tounixpath(pTHX_ const char *path, char *buf)
9071 {
9072     return do_tounixpath(path, buf, 0, NULL);
9073 }
9074
9075 char *
9076 Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9077 {
9078     return do_tounixpath(path, buf, 1, NULL);
9079 }
9080
9081 char *
9082 Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9083 {
9084     return do_tounixpath(path, buf, 0, utf8_fl);
9085 }
9086
9087 char *
9088 Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9089 {
9090     return do_tounixpath(path, buf, 1, utf8_fl);
9091 }
9092
9093 /*
9094  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
9095  *
9096  *****************************************************************************
9097  *                                                                           *
9098  *  Copyright (C) 1989-1994, 2007 by                                         *
9099  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
9100  *                                                                           *
9101  *  Permission is hereby granted for the reproduction of this software       *
9102  *  on condition that this copyright notice is included in source            *
9103  *  distributions of the software.  The code may be modified and             *
9104  *  distributed under the same terms as Perl itself.                         *
9105  *                                                                           *
9106  *  27-Aug-1994 Modified for inclusion in perl5                              *
9107  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9108  *****************************************************************************
9109  */
9110
9111 /*
9112  * getredirection() is intended to aid in porting C programs
9113  * to VMS (Vax-11 C).  The native VMS environment does not support
9114  * '>' and '<' I/O redirection, or command line wild card expansion,
9115  * or a command line pipe mechanism using the '|' AND background
9116  * command execution '&'.  All of these capabilities are provided to any
9117  * C program which calls this procedure as the first thing in the
9118  * main program.
9119  * The piping mechanism will probably work with almost any 'filter' type
9120  * of program.  With suitable modification, it may useful for other
9121  * portability problems as well.
9122  *
9123  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9124  */
9125 struct list_item
9126     {
9127     struct list_item *next;
9128     char *value;
9129     };
9130
9131 static void add_item(struct list_item **head,
9132                      struct list_item **tail,
9133                      char *value,
9134                      int *count);
9135
9136 static void mp_expand_wild_cards(pTHX_ char *item,
9137                                 struct list_item **head,
9138                                 struct list_item **tail,
9139                                 int *count);
9140
9141 static int background_process(pTHX_ int argc, char **argv);
9142
9143 static void pipe_and_fork(pTHX_ char **cmargv);
9144
9145 /*{{{ void getredirection(int *ac, char ***av)*/
9146 static void
9147 mp_getredirection(pTHX_ int *ac, char ***av)
9148 /*
9149  * Process vms redirection arg's.  Exit if any error is seen.
9150  * If getredirection() processes an argument, it is erased
9151  * from the vector.  getredirection() returns a new argc and argv value.
9152  * In the event that a background command is requested (by a trailing "&"),
9153  * this routine creates a background subprocess, and simply exits the program.
9154  *
9155  * Warning: do not try to simplify the code for vms.  The code
9156  * presupposes that getredirection() is called before any data is
9157  * read from stdin or written to stdout.
9158  *
9159  * Normal usage is as follows:
9160  *
9161  *      main(argc, argv)
9162  *      int             argc;
9163  *      char            *argv[];
9164  *      {
9165  *              getredirection(&argc, &argv);
9166  *      }
9167  */
9168 {
9169     int                 argc = *ac;     /* Argument Count         */
9170     char                **argv = *av;   /* Argument Vector        */
9171     char                *ap;            /* Argument pointer       */
9172     int                 j;              /* argv[] index           */
9173     int                 item_count = 0; /* Count of Items in List */
9174     struct list_item    *list_head = 0; /* First Item in List       */
9175     struct list_item    *list_tail;     /* Last Item in List        */
9176     char                *in = NULL;     /* Input File Name          */
9177     char                *out = NULL;    /* Output File Name         */
9178     char                *outmode = "w"; /* Mode to Open Output File */
9179     char                *err = NULL;    /* Error File Name          */
9180     char                *errmode = "w"; /* Mode to Open Error File  */
9181     int                 cmargc = 0;     /* Piped Command Arg Count  */
9182     char                **cmargv = NULL;/* Piped Command Arg Vector */
9183
9184     /*
9185      * First handle the case where the last thing on the line ends with
9186      * a '&'.  This indicates the desire for the command to be run in a
9187      * subprocess, so we satisfy that desire.
9188      */
9189     ap = argv[argc-1];
9190     if (strEQ(ap, "&"))
9191        exit(background_process(aTHX_ --argc, argv));
9192     if (*ap && '&' == ap[strlen(ap)-1])
9193         {
9194         ap[strlen(ap)-1] = '\0';
9195        exit(background_process(aTHX_ argc, argv));
9196         }
9197     /*
9198      * Now we handle the general redirection cases that involve '>', '>>',
9199      * '<', and pipes '|'.
9200      */
9201     for (j = 0; j < argc; ++j)
9202         {
9203         if (strEQ(argv[j], "<"))
9204             {
9205             if (j+1 >= argc)
9206                 {
9207                 fprintf(stderr,"No input file after < on command line");
9208                 exit(LIB$_WRONUMARG);
9209                 }
9210             in = argv[++j];
9211             continue;
9212             }
9213         if ('<' == *(ap = argv[j]))
9214             {
9215             in = 1 + ap;
9216             continue;
9217             }
9218         if (strEQ(ap, ">"))
9219             {
9220             if (j+1 >= argc)
9221                 {
9222                 fprintf(stderr,"No output file after > on command line");
9223                 exit(LIB$_WRONUMARG);
9224                 }
9225             out = argv[++j];
9226             continue;
9227             }
9228         if ('>' == *ap)
9229             {
9230             if ('>' == ap[1])
9231                 {
9232                 outmode = "a";
9233                 if ('\0' == ap[2])
9234                     out = argv[++j];
9235                 else
9236                     out = 2 + ap;
9237                 }
9238             else
9239                 out = 1 + ap;
9240             if (j >= argc)
9241                 {
9242                 fprintf(stderr,"No output file after > or >> on command line");
9243                 exit(LIB$_WRONUMARG);
9244                 }
9245             continue;
9246             }
9247         if (('2' == *ap) && ('>' == ap[1]))
9248             {
9249             if ('>' == ap[2])
9250                 {
9251                 errmode = "a";
9252                 if ('\0' == ap[3])
9253                     err = argv[++j];
9254                 else
9255                     err = 3 + ap;
9256                 }
9257             else
9258                 if ('\0' == ap[2])
9259                     err = argv[++j];
9260                 else
9261                     err = 2 + ap;
9262             if (j >= argc)
9263                 {
9264                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9265                 exit(LIB$_WRONUMARG);
9266                 }
9267             continue;
9268             }
9269         if (strEQ(argv[j], "|"))
9270             {
9271             if (j+1 >= argc)
9272                 {
9273                 fprintf(stderr,"No command into which to pipe on command line");
9274                 exit(LIB$_WRONUMARG);
9275                 }
9276             cmargc = argc-(j+1);
9277             cmargv = &argv[j+1];
9278             argc = j;
9279             continue;
9280             }
9281         if ('|' == *(ap = argv[j]))
9282             {
9283             ++argv[j];
9284             cmargc = argc-j;
9285             cmargv = &argv[j];
9286             argc = j;
9287             continue;
9288             }
9289         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9290         }
9291     /*
9292      * Allocate and fill in the new argument vector, Some Unix's terminate
9293      * the list with an extra null pointer.
9294      */
9295     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9296     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9297     *av = argv;
9298     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9299         argv[j] = list_head->value;
9300     *ac = item_count;
9301     if (cmargv != NULL)
9302         {
9303         if (out != NULL)
9304             {
9305             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9306             exit(LIB$_INVARGORD);
9307             }
9308         pipe_and_fork(aTHX_ cmargv);
9309         }
9310
9311     /* Check for input from a pipe (mailbox) */
9312
9313     if (in == NULL && 1 == isapipe(0))
9314         {
9315         char mbxname[L_tmpnam];
9316         long int bufsize;
9317         long int dvi_item = DVI$_DEVBUFSIZ;
9318         $DESCRIPTOR(mbxnam, "");
9319         $DESCRIPTOR(mbxdevnam, "");
9320
9321         /* Input from a pipe, reopen it in binary mode to disable       */
9322         /* carriage control processing.                                 */
9323
9324         fgetname(stdin, mbxname, 1);
9325         mbxnam.dsc$a_pointer = mbxname;
9326         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9327         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9328         mbxdevnam.dsc$a_pointer = mbxname;
9329         mbxdevnam.dsc$w_length = sizeof(mbxname);
9330         dvi_item = DVI$_DEVNAM;
9331         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9332         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9333         set_errno(0);
9334         set_vaxc_errno(1);
9335         freopen(mbxname, "rb", stdin);
9336         if (errno != 0)
9337             {
9338             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9339             exit(vaxc$errno);
9340             }
9341         }
9342     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9343         {
9344         fprintf(stderr,"Can't open input file %s as stdin",in);
9345         exit(vaxc$errno);
9346         }
9347     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9348         {
9349         fprintf(stderr,"Can't open output file %s as stdout",out);
9350         exit(vaxc$errno);
9351         }
9352         if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
9353
9354     if (err != NULL) {
9355         if (strEQ(err, "&1")) {
9356             dup2(fileno(stdout), fileno(stderr));
9357             vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
9358         } else {
9359         FILE *tmperr;
9360         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9361             {
9362             fprintf(stderr,"Can't open error file %s as stderr",err);
9363             exit(vaxc$errno);
9364             }
9365             fclose(tmperr);
9366            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9367                 {
9368                 exit(vaxc$errno);
9369                 }
9370             vmssetuserlnm("SYS$ERROR", err);
9371         }
9372         }
9373 #ifdef ARGPROC_DEBUG
9374     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9375     for (j = 0; j < *ac;  ++j)
9376         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9377 #endif
9378    /* Clear errors we may have hit expanding wildcards, so they don't
9379       show up in Perl's $! later */
9380    set_errno(0); set_vaxc_errno(1);
9381 }  /* end of getredirection() */
9382 /*}}}*/
9383
9384 static void
9385 add_item(struct list_item **head, struct list_item **tail, char *value, int *count)
9386 {
9387     if (*head == 0)
9388         {
9389         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9390         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9391         *tail = *head;
9392         }
9393     else {
9394         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9395         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9396         *tail = (*tail)->next;
9397         }
9398     (*tail)->value = value;
9399     ++(*count);
9400 }
9401
9402 static void
9403 mp_expand_wild_cards(pTHX_ char *item, struct list_item **head,
9404                      struct list_item **tail, int *count)
9405 {
9406     int expcount = 0;
9407     unsigned long int context = 0;
9408     int isunix = 0;
9409     int item_len = 0;
9410     char *had_version;
9411     char *had_device;
9412     int had_directory;
9413     char *devdir,*cp;
9414     char *vmsspec;
9415     $DESCRIPTOR(filespec, "");
9416     $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9417     $DESCRIPTOR(resultspec, "");
9418     unsigned long int lff_flags = 0;
9419     int sts;
9420     int rms_sts;
9421
9422 #ifdef VMS_LONGNAME_SUPPORT
9423     lff_flags = LIB$M_FIL_LONG_NAMES;
9424 #endif
9425
9426     for (cp = item; *cp; cp++) {
9427         if (*cp == '*' || *cp == '%' || isSPACE_L1(*cp)) break;
9428         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9429     }
9430     if (!*cp || isSPACE_L1(*cp))
9431         {
9432         add_item(head, tail, item, count);
9433         return;
9434         }
9435     else
9436         {
9437      /* "double quoted" wild card expressions pass as is */
9438      /* From DCL that means using e.g.:                  */
9439      /* perl program """perl.*"""                        */
9440      item_len = strlen(item);
9441      if ( '"' == *item && '"' == item[item_len-1] )
9442        {
9443        item++;
9444        item[item_len-2] = '\0';
9445        add_item(head, tail, item, count);
9446        return;
9447        }
9448      }
9449     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9450     resultspec.dsc$b_class = DSC$K_CLASS_D;
9451     resultspec.dsc$a_pointer = NULL;
9452     vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9453     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9454     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9455       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9456     if (!isunix || !filespec.dsc$a_pointer)
9457       filespec.dsc$a_pointer = item;
9458     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9459     /*
9460      * Only return version specs, if the caller specified a version
9461      */
9462     had_version = strchr(item, ';');
9463     /*
9464      * Only return device and directory specs, if the caller specified either.
9465      */
9466     had_device = strchr(item, ':');
9467     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9468
9469     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9470                                  (&filespec, &resultspec, &context,
9471                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9472         {
9473         char *string;
9474         char *c;
9475
9476         string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
9477         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9478         my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
9479         if (NULL == had_version)
9480             *(strrchr(string, ';')) = '\0';
9481         if ((!had_directory) && (had_device == NULL))
9482             {
9483             if (NULL == (devdir = strrchr(string, ']')))
9484                 devdir = strrchr(string, '>');
9485             my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
9486             }
9487         /*
9488          * Be consistent with what the C RTL has already done to the rest of
9489          * the argv items and lowercase all of these names.
9490          */
9491         if (!DECC_EFS_CASE_PRESERVE) {
9492             for (c = string; *c; ++c)
9493             if (isupper(*c))
9494                 *c = toLOWER_L1(*c);
9495         }
9496         if (isunix) trim_unixpath(string,item,1);
9497         add_item(head, tail, string, count);
9498         ++expcount;
9499     }
9500     PerlMem_free(vmsspec);
9501     if (sts != RMS$_NMF)
9502         {
9503         set_vaxc_errno(sts);
9504         switch (sts)
9505             {
9506             case RMS$_FNF: case RMS$_DNF:
9507                 set_errno(ENOENT); break;
9508             case RMS$_DIR:
9509                 set_errno(ENOTDIR); break;
9510             case RMS$_DEV:
9511                 set_errno(ENODEV); break;
9512             case RMS$_FNM: case RMS$_SYN:
9513                 set_errno(EINVAL); break;
9514             case RMS$_PRV:
9515                 set_errno(EACCES); break;
9516             default:
9517                 _ckvmssts_noperl(sts);
9518             }
9519         }
9520     if (expcount == 0)
9521         add_item(head, tail, item, count);
9522     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9523     _ckvmssts_noperl(lib$find_file_end(&context));
9524 }
9525
9526
9527 static void
9528 pipe_and_fork(pTHX_ char **cmargv)
9529 {
9530     PerlIO *fp;
9531     struct dsc$descriptor_s *vmscmd;
9532     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9533     int sts, j, l, ismcr, quote, tquote = 0;
9534
9535     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9536     vms_execfree(vmscmd);
9537
9538     j = l = 0;
9539     p = subcmd;
9540     q = cmargv[0];
9541     ismcr = q && toUPPER_A(*q) == 'M'     && toUPPER_A(*(q+1)) == 'C'
9542               && toUPPER_A(*(q+2)) == 'R' && !*(q+3);
9543
9544     while (q && l < MAX_DCL_LINE_LENGTH) {
9545         if (!*q) {
9546             if (j > 0 && quote) {
9547                 *p++ = '"';
9548                 l++;
9549             }
9550             q = cmargv[++j];
9551             if (q) {
9552                 if (ismcr && j > 1) quote = 1;
9553                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9554                 *p++ = ' ';
9555                 l++;
9556                 if (quote || tquote) {
9557                     *p++ = '"';
9558                     l++;
9559                 }
9560             }
9561         } else {
9562             if ((quote||tquote) && *q == '"') {
9563                 *p++ = '"';
9564                 l++;
9565             }
9566             *p++ = *q++;
9567             l++;
9568         }
9569     }
9570     *p = '\0';
9571
9572     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9573     if (fp == NULL) {
9574         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9575     }
9576 }
9577
9578 static int
9579 background_process(pTHX_ int argc, char **argv)
9580 {
9581     char command[MAX_DCL_SYMBOL + 1] = "$";
9582     $DESCRIPTOR(value, "");
9583     static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9584     static $DESCRIPTOR(null, "NLA0:");
9585     static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9586     char pidstring[80];
9587     $DESCRIPTOR(pidstr, "");
9588     int pid;
9589     unsigned long int flags = 17, one = 1, retsts;
9590     int len;
9591
9592     len = my_strlcat(command, argv[0], sizeof(command));
9593     while (--argc && (len < MAX_DCL_SYMBOL))
9594         {
9595         my_strlcat(command, " \"", sizeof(command));
9596         my_strlcat(command, *(++argv), sizeof(command));
9597         len = my_strlcat(command, "\"", sizeof(command));
9598         }
9599     value.dsc$a_pointer = command;
9600     value.dsc$w_length = strlen(value.dsc$a_pointer);
9601     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9602     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9603     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9604         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9605     }
9606     else {
9607         _ckvmssts_noperl(retsts);
9608     }
9609 #ifdef ARGPROC_DEBUG
9610     PerlIO_printf(Perl_debug_log, "%s\n", command);
9611 #endif
9612     sprintf(pidstring, "%08X", pid);
9613     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9614     pidstr.dsc$a_pointer = pidstring;
9615     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9616     lib$set_symbol(&pidsymbol, &pidstr);
9617     return(SS$_NORMAL);
9618 }
9619 /*}}}*/
9620 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9621
9622
9623 /* OS-specific initialization at image activation (not thread startup) */
9624 /* Older VAXC header files lack these constants */
9625 #ifndef JPI$_RIGHTS_SIZE
9626 #  define JPI$_RIGHTS_SIZE 817
9627 #endif
9628 #ifndef KGB$M_SUBSYSTEM
9629 #  define KGB$M_SUBSYSTEM 0x8
9630 #endif
9631
9632 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9633
9634 /*{{{void vms_image_init(int *, char ***)*/
9635 void
9636 vms_image_init(int *argcp, char ***argvp)
9637 {
9638   int status;
9639   char eqv[LNM$C_NAMLENGTH+1] = "";
9640   unsigned int len, tabct = 8, tabidx = 0;
9641   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9642   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9643   unsigned short int dummy, rlen;
9644   struct dsc$descriptor_s **tabvec;
9645 #if defined(PERL_IMPLICIT_CONTEXT)
9646   pTHX = NULL;
9647 #endif
9648   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9649                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9650                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9651                                  {          0,                0,    0,      0} };
9652
9653 #ifdef KILL_BY_SIGPRC
9654     Perl_csighandler_init();
9655 #endif
9656
9657   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9658   _ckvmssts_noperl(iosb[0]);
9659   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9660     if (iprv[i]) {           /* Running image installed with privs? */
9661       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9662       will_taint = TRUE;
9663       break;
9664     }
9665   }
9666   /* Rights identifiers might trigger tainting as well. */
9667   if (!will_taint && (rlen || rsz)) {
9668     while (rlen < rsz) {
9669       /* We didn't get all the identifiers on the first pass.  Allocate a
9670        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9671        * were needed to hold all identifiers at time of last call; we'll
9672        * allocate that many unsigned long ints), and go back and get 'em.
9673        * If it gave us less than it wanted to despite ample buffer space,
9674        * something's broken.  Is your system missing a system identifier?
9675        */
9676       if (rsz <= jpilist[1].buflen) {
9677          /* Perl_croak accvios when used this early in startup. */
9678          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9679                          rsz, (unsigned long) jpilist[1].buflen,
9680                          "Check your rights database for corruption.\n");
9681          exit(SS$_ABORT);
9682       }
9683       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9684       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9685       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9686       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9687       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9688       _ckvmssts_noperl(iosb[0]);
9689     }
9690     mask = (unsigned long int *)jpilist[1].bufadr;
9691     /* Check attribute flags for each identifier (2nd longword); protected
9692      * subsystem identifiers trigger tainting.
9693      */
9694     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9695       if (mask[i] & KGB$M_SUBSYSTEM) {
9696         will_taint = TRUE;
9697         break;
9698       }
9699     }
9700     if (mask != rlst) PerlMem_free(mask);
9701   }
9702
9703   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9704    * logical, some versions of the CRTL will add a phanthom /000000/
9705    * directory.  This needs to be removed.
9706    */
9707   if (DECC_FILENAME_UNIX_REPORT) {
9708     char * zeros;
9709     int ulen;
9710     ulen = strlen(argvp[0][0]);
9711     if (ulen > 7) {
9712       zeros = strstr(argvp[0][0], "/000000/");
9713       if (zeros != NULL) {
9714         int mlen;
9715         mlen = ulen - (zeros - argvp[0][0]) - 7;
9716         memmove(zeros, &zeros[7], mlen);
9717         ulen = ulen - 7;
9718         argvp[0][0][ulen] = '\0';
9719       }
9720     }
9721     /* It also may have a trailing dot that needs to be removed otherwise
9722      * it will be converted to VMS mode incorrectly.
9723      */
9724     ulen--;
9725     if ((argvp[0][0][ulen] == '.') && (DECC_READDIR_DROPDOTNOTYPE))
9726       argvp[0][0][ulen] = '\0';
9727   }
9728
9729   /* We need to use this hack to tell Perl it should run with tainting,
9730    * since its tainting flag may be part of the PL_curinterp struct, which
9731    * hasn't been allocated when vms_image_init() is called.
9732    */
9733   if (will_taint) {
9734     char **newargv, **oldargv;
9735     oldargv = *argvp;
9736     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9737     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9738     newargv[0] = oldargv[0];
9739     newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
9740     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9741     strcpy(newargv[1], "-T");
9742     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9743     (*argcp)++;
9744     newargv[*argcp] = NULL;
9745     /* We orphan the old argv, since we don't know where it's come from,
9746      * so we don't know how to free it.
9747      */
9748     *argvp = newargv;
9749   }
9750   else {  /* Did user explicitly request tainting? */
9751     int i;
9752     char *cp, **av = *argvp;
9753     for (i = 1; i < *argcp; i++) {
9754       if (*av[i] != '-') break;
9755       for (cp = av[i]+1; *cp; cp++) {
9756         if (*cp == 'T') { will_taint = 1; break; }
9757         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9758                   strchr("DFIiMmx",*cp)) break;
9759       }
9760       if (will_taint) break;
9761     }
9762   }
9763
9764   for (tabidx = 0;
9765        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9766        tabidx++) {
9767     if (!tabidx) {
9768       tabvec = (struct dsc$descriptor_s **)
9769             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9770       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9771     }
9772     else if (tabidx >= tabct) {
9773       tabct += 8;
9774       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9775       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9776     }
9777     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9778     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9779     tabvec[tabidx]->dsc$w_length  = len;
9780     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9781     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_S;
9782     tabvec[tabidx]->dsc$a_pointer = (char *)PerlMem_malloc(len + 1);
9783     if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9784     my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
9785   }
9786   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9787
9788   getredirection(argcp,argvp);
9789 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9790   {
9791 # include <reentrancy.h>
9792   decc$set_reentrancy(C$C_MULTITHREAD);
9793   }
9794 #endif
9795   return;
9796 }
9797 /*}}}*/
9798
9799
9800 /* trim_unixpath()
9801  * Trim Unix-style prefix off filespec, so it looks like what a shell
9802  * glob expansion would return (i.e. from specified prefix on, not
9803  * full path).  Note that returned filespec is Unix-style, regardless
9804  * of whether input filespec was VMS-style or Unix-style.
9805  *
9806  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9807  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9808  * vector of options; at present, only bit 0 is used, and if set tells
9809  * trim unixpath to try the current default directory as a prefix when
9810  * presented with a possibly ambiguous ... wildcard.
9811  *
9812  * Returns !=0 on success, with trimmed filespec replacing contents of
9813  * fspec, and 0 on failure, with contents of fpsec unchanged.
9814  */
9815 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9816 int
9817 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9818 {
9819   char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
9820   int tmplen, reslen = 0, dirs = 0;
9821
9822   if (!wildspec || !fspec) return 0;
9823
9824   unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
9825   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9826   tplate = unixwild;
9827   if (strpbrk(wildspec,"]>:") != NULL) {
9828     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9829         PerlMem_free(unixwild);
9830         return 0;
9831     }
9832   }
9833   else {
9834     my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
9835   }
9836   unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
9837   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9838   if (strpbrk(fspec,"]>:") != NULL) {
9839     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9840         PerlMem_free(unixwild);
9841         PerlMem_free(unixified);
9842         return 0;
9843     }
9844     else base = unixified;
9845     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9846      * check to see that final result fits into (isn't longer than) fspec */
9847     reslen = strlen(fspec);
9848   }
9849   else base = fspec;
9850
9851   /* No prefix or absolute path on wildcard, so nothing to remove */
9852   if (!*tplate || *tplate == '/') {
9853     PerlMem_free(unixwild);
9854     if (base == fspec) {
9855         PerlMem_free(unixified);
9856         return 1;
9857     }
9858     tmplen = strlen(unixified);
9859     if (tmplen > reslen) {
9860         PerlMem_free(unixified);
9861         return 0;  /* not enough space */
9862     }
9863     /* Copy unixified resultant, including trailing NUL */
9864     memmove(fspec,unixified,tmplen+1);
9865     PerlMem_free(unixified);
9866     return 1;
9867   }
9868
9869   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9870   if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9871     for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
9872     for (cp1 = end ;cp1 >= base; cp1--)
9873       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9874         { cp1++; break; }
9875     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9876     PerlMem_free(unixified);
9877     PerlMem_free(unixwild);
9878     return 1;
9879   }
9880   else {
9881     char *tpl, *lcres;
9882     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9883     int ells = 1, totells, segdirs, match;
9884     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9885                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9886
9887     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9888     totells = ells;
9889     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9890     tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
9891     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9892     if (ellipsis == tplate && opts & 1) {
9893       /* Template begins with an ellipsis.  Since we can't tell how many
9894        * directory names at the front of the resultant to keep for an
9895        * arbitrary starting point, we arbitrarily choose the current
9896        * default directory as a starting point.  If it's there as a prefix,
9897        * clip it off.  If not, fall through and act as if the leading
9898        * ellipsis weren't there (i.e. return shortest possible path that
9899        * could match template).
9900        */
9901       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9902           PerlMem_free(tpl);
9903           PerlMem_free(unixified);
9904           PerlMem_free(unixwild);
9905           return 0;
9906       }
9907       if (!DECC_EFS_CASE_PRESERVE) {
9908         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9909           if (toLOWER_L1(*cp1) != toLOWER_L1(*cp2)) break;
9910       }
9911       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9912       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9913       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9914         memmove(fspec,cp2+1,end - cp2);
9915         PerlMem_free(tpl);
9916         PerlMem_free(unixified);
9917         PerlMem_free(unixwild);
9918         return 1;
9919       }
9920     }
9921     /* First off, back up over constant elements at end of path */
9922     if (dirs) {
9923       for (front = end ; front >= base; front--)
9924          if (*front == '/' && !dirs--) { front++; break; }
9925     }
9926     lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
9927     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9928     for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9929          cp1++,cp2++) {
9930             if (!DECC_EFS_CASE_PRESERVE) {
9931                 *cp2 = toLOWER_L1(*cp1);  /* Make lc copy for match */
9932             }
9933             else {
9934                 *cp2 = *cp1;
9935             }
9936     }
9937     if (cp1 != '\0') {
9938         PerlMem_free(tpl);
9939         PerlMem_free(unixified);
9940         PerlMem_free(unixwild);
9941         PerlMem_free(lcres);
9942         return 0;  /* Path too long. */
9943     }
9944     lcend = cp2;
9945     *cp2 = '\0';  /* Pick up with memcpy later */
9946     lcfront = lcres + (front - base);
9947     /* Now skip over each ellipsis and try to match the path in front of it. */
9948     while (ells--) {
9949       for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
9950         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9951             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9952       if (cp1 < tplate) break; /* template started with an ellipsis */
9953       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9954         ellipsis = cp1; continue;
9955       }
9956       wilddsc.dsc$a_pointer = tpl;
9957       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9958       nextell = cp1;
9959       for (segdirs = 0, cp2 = tpl;
9960            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9961            cp1++, cp2++) {
9962          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9963          else {
9964             if (!DECC_EFS_CASE_PRESERVE) {
9965               *cp2 = toLOWER_L1(*cp1);  /* else lowercase for match */
9966             }
9967             else {
9968               *cp2 = *cp1;  /* else preserve case for match */
9969             }
9970          }
9971          if (*cp2 == '/') segdirs++;
9972       }
9973       if (cp1 != ellipsis - 1) {
9974           PerlMem_free(tpl);
9975           PerlMem_free(unixified);
9976           PerlMem_free(unixwild);
9977           PerlMem_free(lcres);
9978           return 0; /* Path too long */
9979       }
9980       /* Back up at least as many dirs as in template before matching */
9981       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9982         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9983       for (match = 0; cp1 > lcres;) {
9984         resdsc.dsc$a_pointer = cp1;
9985         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9986           match++;
9987           if (match == 1) lcfront = cp1;
9988         }
9989         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9990       }
9991       if (!match) {
9992         PerlMem_free(tpl);
9993         PerlMem_free(unixified);
9994         PerlMem_free(unixwild);
9995         PerlMem_free(lcres);
9996         return 0;  /* Can't find prefix ??? */
9997       }
9998       if (match > 1 && opts & 1) {
9999         /* This ... wildcard could cover more than one set of dirs (i.e.
10000          * a set of similar dir names is repeated).  If the template
10001          * contains more than 1 ..., upstream elements could resolve the
10002          * ambiguity, but it's not worth a full backtracking setup here.
10003          * As a quick heuristic, clip off the current default directory
10004          * if it's present to find the trimmed spec, else use the
10005          * shortest string that this ... could cover.
10006          */
10007         char def[NAM$C_MAXRSS+1], *st;
10008
10009         if (getcwd(def, sizeof def,0) == NULL) {
10010             PerlMem_free(unixified);
10011             PerlMem_free(unixwild);
10012             PerlMem_free(lcres);
10013             PerlMem_free(tpl);
10014             return 0;
10015         }
10016         if (!DECC_EFS_CASE_PRESERVE) {
10017           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10018             if (toLOWER_L1(*cp1) != toLOWER_L1(*cp2)) break;
10019         }
10020         segdirs = dirs - totells;  /* Min # of dirs we must have left */
10021         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10022         if (*cp1 == '\0' && *cp2 == '/') {
10023           memmove(fspec,cp2+1,end - cp2);
10024           PerlMem_free(tpl);
10025           PerlMem_free(unixified);
10026           PerlMem_free(unixwild);
10027           PerlMem_free(lcres);
10028           return 1;
10029         }
10030         /* Nope -- stick with lcfront from above and keep going. */
10031       }
10032     }
10033     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10034     PerlMem_free(tpl);
10035     PerlMem_free(unixified);
10036     PerlMem_free(unixwild);
10037     PerlMem_free(lcres);
10038     return 1;
10039   }
10040
10041 }  /* end of trim_unixpath() */
10042 /*}}}*/
10043
10044
10045 /*
10046  *  VMS readdir() routines.
10047  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10048  *
10049  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10050  *  Minor modifications to original routines.
10051  */
10052
10053 /* readdir may have been redefined by reentr.h, so make sure we get
10054  * the local version for what we do here.
10055  */
10056 #ifdef readdir
10057 # undef readdir
10058 #endif
10059 #if !defined(PERL_IMPLICIT_CONTEXT)
10060 # define readdir Perl_readdir
10061 #else
10062 # define readdir(a) Perl_readdir(aTHX_ a)
10063 #endif
10064
10065     /* Number of elements in vms_versions array */
10066 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10067
10068 /*
10069  *  Open a directory, return a handle for later use.
10070  */
10071 /*{{{ DIR *opendir(char*name) */
10072 DIR *
10073 Perl_opendir(pTHX_ const char *name)
10074 {
10075     DIR *dd;
10076     char *dir;
10077     Stat_t sb;
10078
10079     Newx(dir, VMS_MAXRSS, char);
10080     if (int_tovmspath(name, dir, NULL) == NULL) {
10081       Safefree(dir);
10082       return NULL;
10083     }
10084     /* Check access before stat; otherwise stat does not
10085      * accurately report whether it's a directory.
10086      */
10087     if (!strstr(dir, "::") /* sys$check_access doesn't do remotes */
10088         && !cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10089       /* cando_by_name has already set errno */
10090       Safefree(dir);
10091       return NULL;
10092     }
10093     if (flex_stat(dir,&sb) == -1) return NULL;
10094     if (!S_ISDIR(sb.st_mode)) {
10095       Safefree(dir);
10096       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10097       return NULL;
10098     }
10099     /* Get memory for the handle, and the pattern. */
10100     Newx(dd,1,DIR);
10101     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10102
10103     /* Fill in the fields; mainly playing with the descriptor. */
10104     sprintf(dd->pattern, "%s*.*",dir);
10105     Safefree(dir);
10106     dd->context = 0;
10107     dd->count = 0;
10108     dd->flags = 0;
10109     /* By saying we want the result of readdir() in unix format, we are really
10110      * saying we want all the escapes removed, translating characters that
10111      * must be escaped in a VMS-format name to their unescaped form, which is
10112      * presumably allowed in a Unix-format name.
10113      */
10114     dd->flags = DECC_FILENAME_UNIX_REPORT ? PERL_VMSDIR_M_UNIXSPECS : 0;
10115     dd->pat.dsc$a_pointer = dd->pattern;
10116     dd->pat.dsc$w_length = strlen(dd->pattern);
10117     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10118     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10119 #if defined(USE_ITHREADS)
10120     Newx(dd->mutex,1,perl_mutex);
10121     MUTEX_INIT( (perl_mutex *) dd->mutex );
10122 #else
10123     dd->mutex = NULL;
10124 #endif
10125
10126     return dd;
10127 }  /* end of opendir() */
10128 /*}}}*/
10129
10130 /*
10131  *  Set the flag to indicate we want versions or not.
10132  */
10133 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10134 void
10135 vmsreaddirversions(DIR *dd, int flag)
10136 {
10137     if (flag)
10138         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10139     else
10140         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10141 }
10142 /*}}}*/
10143
10144 /*
10145  *  Free up an opened directory.
10146  */
10147 /*{{{ void closedir(DIR *dd)*/
10148 void
10149 Perl_closedir(DIR *dd)
10150 {
10151     int sts;
10152
10153     sts = lib$find_file_end(&dd->context);
10154     Safefree(dd->pattern);
10155 #if defined(USE_ITHREADS)
10156     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10157     Safefree(dd->mutex);
10158 #endif
10159     Safefree(dd);
10160 }
10161 /*}}}*/
10162
10163 /*
10164  *  Collect all the version numbers for the current file.
10165  */
10166 static void
10167 collectversions(pTHX_ DIR *dd)
10168 {
10169     struct dsc$descriptor_s     pat;
10170     struct dsc$descriptor_s     res;
10171     struct dirent *e;
10172     char *p, *text, *buff;
10173     int i;
10174     unsigned long context, tmpsts;
10175
10176     /* Convenient shorthand. */
10177     e = &dd->entry;
10178
10179     /* Add the version wildcard, ignoring the "*.*" put on before */
10180     i = strlen(dd->pattern);
10181     Newx(text,i + e->d_namlen + 3,char);
10182     my_strlcpy(text, dd->pattern, i + 1);
10183     sprintf(&text[i - 3], "%s;*", e->d_name);
10184
10185     /* Set up the pattern descriptor. */
10186     pat.dsc$a_pointer = text;
10187     pat.dsc$w_length = i + e->d_namlen - 1;
10188     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10189     pat.dsc$b_class = DSC$K_CLASS_S;
10190
10191     /* Set up result descriptor. */
10192     Newx(buff, VMS_MAXRSS, char);
10193     res.dsc$a_pointer = buff;
10194     res.dsc$w_length = VMS_MAXRSS - 1;
10195     res.dsc$b_dtype = DSC$K_DTYPE_T;
10196     res.dsc$b_class = DSC$K_CLASS_S;
10197
10198     /* Read files, collecting versions. */
10199     for (context = 0, e->vms_verscount = 0;
10200          e->vms_verscount < VERSIZE(e);
10201          e->vms_verscount++) {
10202         unsigned long rsts;
10203         unsigned long flags = 0;
10204
10205 #ifdef VMS_LONGNAME_SUPPORT
10206         flags = LIB$M_FIL_LONG_NAMES;
10207 #endif
10208         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10209         if (tmpsts == RMS$_NMF || context == 0) break;
10210         _ckvmssts(tmpsts);
10211         buff[VMS_MAXRSS - 1] = '\0';
10212         if ((p = strchr(buff, ';')))
10213             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10214         else
10215             e->vms_versions[e->vms_verscount] = -1;
10216     }
10217
10218     _ckvmssts(lib$find_file_end(&context));
10219     Safefree(text);
10220     Safefree(buff);
10221
10222 }  /* end of collectversions() */
10223
10224 /*
10225  *  Read the next entry from the directory.
10226  */
10227 /*{{{ struct dirent *readdir(DIR *dd)*/
10228 struct dirent *
10229 Perl_readdir(pTHX_ DIR *dd)
10230 {
10231     struct dsc$descriptor_s     res;
10232     char *p, *buff;
10233     unsigned long int tmpsts;
10234     unsigned long rsts;
10235     unsigned long flags = 0;
10236     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10237     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10238
10239     /* Set up result descriptor, and get next file. */
10240     Newx(buff, VMS_MAXRSS, char);
10241     res.dsc$a_pointer = buff;
10242     res.dsc$w_length = VMS_MAXRSS - 1;
10243     res.dsc$b_dtype = DSC$K_DTYPE_T;
10244     res.dsc$b_class = DSC$K_CLASS_S;
10245
10246 #ifdef VMS_LONGNAME_SUPPORT
10247     flags = LIB$M_FIL_LONG_NAMES;
10248 #endif
10249
10250     tmpsts = lib$find_file
10251         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10252     if (dd->context == 0)
10253         tmpsts = RMS$_NMF;  /* None left. (should be set, but make sure) */
10254
10255     if (!(tmpsts & 1)) {
10256       switch (tmpsts) {
10257         case RMS$_NMF:
10258           break;  /* no more files considered success */
10259         case RMS$_PRV:
10260           SETERRNO(EACCES, tmpsts); break;
10261         case RMS$_DEV:
10262           SETERRNO(ENODEV, tmpsts); break;
10263         case RMS$_DIR:
10264           SETERRNO(ENOTDIR, tmpsts); break;
10265         case RMS$_FNF: case RMS$_DNF:
10266           SETERRNO(ENOENT, tmpsts); break;
10267         default:
10268           SETERRNO(EVMSERR, tmpsts);
10269       }
10270       Safefree(buff);
10271       return NULL;
10272     }
10273     dd->count++;
10274     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10275     buff[res.dsc$w_length] = '\0';
10276     p = buff + res.dsc$w_length;
10277     while (--p >= buff) if (!isSPACE_L1(*p)) break;
10278     *p = '\0';
10279     if (!DECC_EFS_CASE_PRESERVE) {
10280       for (p = buff; *p; p++) *p = toLOWER_L1(*p);
10281     }
10282
10283     /* Skip any directory component and just copy the name. */
10284     sts = vms_split_path
10285        (buff,
10286         &v_spec,
10287         &v_len,
10288         &r_spec,
10289         &r_len,
10290         &d_spec,
10291         &d_len,
10292         &n_spec,
10293         &n_len,
10294         &e_spec,
10295         &e_len,
10296         &vs_spec,
10297         &vs_len);
10298
10299     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10300
10301         /* In Unix report mode, remove the ".dir;1" from the name */
10302         /* if it is a real directory. */
10303         if (DECC_FILENAME_UNIX_REPORT && DECC_EFS_CHARSET) {
10304             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10305                 Stat_t statbuf;
10306                 int ret_sts;
10307
10308                 ret_sts = flex_lstat(buff, &statbuf);
10309                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10310                     e_len = 0;
10311                     e_spec[0] = 0;
10312                 }
10313             }
10314         }
10315
10316         /* Drop NULL extensions on UNIX file specification */
10317         if ((e_len == 1) && DECC_READDIR_DROPDOTNOTYPE) {
10318             e_len = 0;
10319             e_spec[0] = '\0';
10320         }
10321     }
10322
10323     memcpy(dd->entry.d_name, n_spec, n_len + e_len);
10324     dd->entry.d_name[n_len + e_len] = '\0';
10325     dd->entry.d_namlen = n_len + e_len;
10326
10327     /* Convert the filename to UNIX format if needed */
10328     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10329
10330         /* Translate the encoded characters. */
10331         /* Fixme: Unicode handling could result in embedded 0 characters */
10332         if (strchr(dd->entry.d_name, '^') != NULL) {
10333             char new_name[256];
10334             char * q;
10335             p = dd->entry.d_name;
10336             q = new_name;
10337             while (*p != 0) {
10338                 int inchars_read, outchars_added;
10339                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10340                 p += inchars_read;
10341                 q += outchars_added;
10342                 /* fix-me */
10343                 /* if outchars_added > 1, then this is a wide file specification */
10344                 /* Wide file specifications need to be passed in Perl */
10345                 /* counted strings apparently with a Unicode flag */
10346             }
10347             *q = 0;
10348             dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
10349         }
10350     }
10351
10352     dd->entry.vms_verscount = 0;
10353     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10354     Safefree(buff);
10355     return &dd->entry;
10356
10357 }  /* end of readdir() */
10358 /*}}}*/
10359
10360 /*
10361  *  Read the next entry from the directory -- thread-safe version.
10362  */
10363 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10364 int
10365 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10366 {
10367     int retval;
10368
10369     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10370
10371     entry = readdir(dd);
10372     *result = entry;
10373     retval = ( *result == NULL ? errno : 0 );
10374
10375     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10376
10377     return retval;
10378
10379 }  /* end of readdir_r() */
10380 /*}}}*/
10381
10382 /*
10383  *  Return something that can be used in a seekdir later.
10384  */
10385 /*{{{ long telldir(DIR *dd)*/
10386 long
10387 Perl_telldir(DIR *dd)
10388 {
10389     return dd->count;
10390 }
10391 /*}}}*/
10392
10393 /*
10394  *  Return to a spot where we used to be.  Brute force.
10395  */
10396 /*{{{ void seekdir(DIR *dd,long count)*/
10397 void
10398 Perl_seekdir(pTHX_ DIR *dd, long count)
10399 {
10400     int old_flags;
10401
10402     /* If we haven't done anything yet... */
10403     if (dd->count == 0)
10404         return;
10405
10406     /* Remember some state, and clear it. */
10407     old_flags = dd->flags;
10408     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10409     _ckvmssts(lib$find_file_end(&dd->context));
10410     dd->context = 0;
10411
10412     /* The increment is in readdir(). */
10413     for (dd->count = 0; dd->count < count; )
10414         readdir(dd);
10415
10416     dd->flags = old_flags;
10417
10418 }  /* end of seekdir() */
10419 /*}}}*/
10420
10421 /* VMS subprocess management
10422  *
10423  * my_vfork() - just a vfork(), after setting a flag to record that
10424  * the current script is trying a Unix-style fork/exec.
10425  *
10426  * vms_do_aexec() and vms_do_exec() are called in response to the
10427  * perl 'exec' function.  If this follows a vfork call, then they
10428  * call out the regular perl routines in doio.c which do an
10429  * execvp (for those who really want to try this under VMS).
10430  * Otherwise, they do exactly what the perl docs say exec should
10431  * do - terminate the current script and invoke a new command
10432  * (See below for notes on command syntax.)
10433  *
10434  * do_aspawn() and do_spawn() implement the VMS side of the perl
10435  * 'system' function.
10436  *
10437  * Note on command arguments to perl 'exec' and 'system': When handled
10438  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10439  * are concatenated to form a DCL command string.  If the first non-numeric
10440  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10441  * the command string is handed off to DCL directly.  Otherwise,
10442  * the first token of the command is taken as the filespec of an image
10443  * to run.  The filespec is expanded using a default type of '.EXE' and
10444  * the process defaults for device, directory, etc., and if found, the resultant
10445  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10446  * the command string as parameters.  This is perhaps a bit complicated,
10447  * but I hope it will form a happy medium between what VMS folks expect
10448  * from lib$spawn and what Unix folks expect from exec.
10449  */
10450
10451 static int vfork_called;
10452
10453 /*{{{int my_vfork(void)*/
10454 int
10455 my_vfork(void)
10456 {
10457   vfork_called++;
10458   return vfork();
10459 }
10460 /*}}}*/
10461
10462
10463 static void
10464 vms_execfree(struct dsc$descriptor_s *vmscmd)
10465 {
10466   if (vmscmd) {
10467       if (vmscmd->dsc$a_pointer) {
10468           PerlMem_free(vmscmd->dsc$a_pointer);
10469       }
10470       PerlMem_free(vmscmd);
10471   }
10472 }
10473
10474 static char *
10475 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10476 {
10477   char *junk, *tmps = NULL, *cmd;
10478   size_t cmdlen = 0;
10479   size_t rlen;
10480   SV **idx;
10481   STRLEN n_a;
10482
10483   idx = mark;
10484   if (really) {
10485     tmps = SvPV(really,rlen);
10486     if (*tmps) {
10487       cmdlen += rlen + 1;
10488       idx++;
10489     }
10490   }
10491
10492   for (idx++; idx <= sp; idx++) {
10493     if (*idx) {
10494       junk = SvPVx(*idx,rlen);
10495       cmdlen += rlen ? rlen + 1 : 0;
10496     }
10497   }
10498   Newx(cmd, cmdlen+1, char);
10499   SAVEFREEPV(cmd);
10500
10501   if (tmps && *tmps) {
10502     my_strlcpy(cmd, tmps, cmdlen + 1);
10503     mark++;
10504   }
10505   else *cmd = '\0';
10506   while (++mark <= sp) {
10507     if (*mark) {
10508       char *s = SvPVx(*mark,n_a);
10509       if (!*s) continue;
10510       if (*cmd) my_strlcat(cmd, " ", cmdlen+1);
10511       my_strlcat(cmd, s, cmdlen+1);
10512     }
10513   }
10514   return cmd;
10515
10516 }  /* end of setup_argstr() */
10517
10518
10519 static unsigned long int
10520 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10521                    struct dsc$descriptor_s **pvmscmd)
10522 {
10523   char * vmsspec;
10524   char * resspec;
10525   char image_name[NAM$C_MAXRSS+1];
10526   char image_argv[NAM$C_MAXRSS+1];
10527   $DESCRIPTOR(defdsc,".EXE");
10528   $DESCRIPTOR(defdsc2,".");
10529   struct dsc$descriptor_s resdsc;
10530   struct dsc$descriptor_s *vmscmd;
10531   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10532   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10533   char *s, *rest, *cp, *wordbreak;
10534   char * cmd;
10535   int cmdlen;
10536   int isdcl;
10537
10538   vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10539   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10540
10541   /* vmsspec is a DCL command buffer, not just a filename */
10542   vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10543   if (vmsspec == NULL)
10544       _ckvmssts_noperl(SS$_INSFMEM);
10545
10546   resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
10547   if (resspec == NULL)
10548       _ckvmssts_noperl(SS$_INSFMEM);
10549
10550   /* Make a copy for modification */
10551   cmdlen = strlen(incmd);
10552   cmd = (char *)PerlMem_malloc(cmdlen+1);
10553   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10554   my_strlcpy(cmd, incmd, cmdlen + 1);
10555   image_name[0] = 0;
10556   image_argv[0] = 0;
10557
10558   resdsc.dsc$a_pointer = resspec;
10559   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10560   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10561   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10562
10563   vmscmd->dsc$a_pointer = NULL;
10564   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10565   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10566   vmscmd->dsc$w_length = 0;
10567   if (pvmscmd) *pvmscmd = vmscmd;
10568
10569   if (suggest_quote) *suggest_quote = 0;
10570
10571   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10572     PerlMem_free(cmd);
10573     PerlMem_free(vmsspec);
10574     PerlMem_free(resspec);
10575     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10576   }
10577
10578   s = cmd;
10579
10580   while (*s && isSPACE_L1(*s)) s++;
10581
10582   if (*s == '@' || *s == '$') {
10583     vmsspec[0] = *s;  rest = s + 1;
10584     for (cp = &vmsspec[1]; *rest && isSPACE_L1(*rest); rest++,cp++) *cp = *rest;
10585   }
10586   else { cp = vmsspec; rest = s; }
10587
10588   /* If the first word is quoted, then we need to unquote it and
10589    * escape spaces within it.  We'll expand into the resspec buffer,
10590    * then copy back into the cmd buffer, expanding the latter if
10591    * necessary.
10592    */
10593   if (*rest == '"') {
10594     char *cp2;
10595     char *r = rest;
10596     bool in_quote = 0;
10597     int clen = cmdlen;
10598     int soff = s - cmd;
10599
10600     for (cp2 = resspec;
10601          *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10602          rest++) {
10603
10604       if (*rest == ' ') {    /* Escape ' ' to '^_'. */
10605         *cp2 = '^';
10606         *(++cp2) = '_';
10607         cp2++;
10608         clen++;
10609       }
10610       else if (*rest == '"') {
10611         clen--;
10612         if (in_quote) {     /* Must be closing quote. */
10613           rest++;
10614           break;
10615         }
10616         in_quote = 1;
10617       }
10618       else {
10619         *cp2 = *rest;
10620         cp2++;
10621       }
10622     }
10623     *cp2 = '\0';
10624
10625     /* Expand the command buffer if necessary. */
10626     if (clen > cmdlen) {
10627       cmd = (char *)PerlMem_realloc(cmd, clen);
10628       if (cmd == NULL)
10629         _ckvmssts_noperl(SS$_INSFMEM);
10630       /* Where we are may have changed, so recompute offsets */
10631       r = cmd + (r - s - soff);
10632       rest = cmd + (rest - s - soff);
10633       s = cmd + soff;
10634     }
10635
10636     /* Shift the non-verb portion of the command (if any) up or
10637      * down as necessary.
10638      */
10639     if (*rest)
10640       memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10641
10642     /* Copy the unquoted and escaped command verb into place. */
10643     memcpy(r, resspec, cp2 - resspec);
10644     cmd[clen] = '\0';
10645     cmdlen = clen;
10646     rest = r;         /* Rewind for subsequent operations. */
10647   }
10648
10649   if (*rest == '.' || *rest == '/') {
10650     char *cp2;
10651     for (cp2 = resspec;
10652          *rest && !isSPACE_L1(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10653          rest++, cp2++) *cp2 = *rest;
10654     *cp2 = '\0';
10655     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10656       s = vmsspec;
10657
10658       /* When a UNIX spec with no file type is translated to VMS, */
10659       /* A trailing '.' is appended under ODS-5 rules.            */
10660       /* Here we do not want that trailing "." as it prevents     */
10661       /* Looking for a implied ".exe" type. */
10662       if (DECC_EFS_CHARSET) {
10663           int i;
10664           i = strlen(vmsspec);
10665           if (vmsspec[i-1] == '.') {
10666               vmsspec[i-1] = '\0';
10667           }
10668       }
10669
10670       if (*rest) {
10671         for (cp2 = vmsspec + strlen(vmsspec);
10672              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10673              rest++, cp2++) *cp2 = *rest;
10674         *cp2 = '\0';
10675       }
10676     }
10677   }
10678   /* Intuit whether verb (first word of cmd) is a DCL command:
10679    *   - if first nonspace char is '@', it's a DCL indirection
10680    * otherwise
10681    *   - if verb contains a filespec separator, it's not a DCL command
10682    *   - if it doesn't, caller tells us whether to default to a DCL
10683    *     command, or to a local image unless told it's DCL (by leading '$')
10684    */
10685   if (*s == '@') {
10686       isdcl = 1;
10687       if (suggest_quote) *suggest_quote = 1;
10688   } else {
10689     char *filespec = strpbrk(s,":<[.;");
10690     rest = wordbreak = strpbrk(s," \"\t/");
10691     if (!wordbreak) wordbreak = s + strlen(s);
10692     if (*s == '$') check_img = 0;
10693     if (filespec && (filespec < wordbreak)) isdcl = 0;
10694     else isdcl = !check_img;
10695   }
10696
10697   if (!isdcl) {
10698     int rsts;
10699     imgdsc.dsc$a_pointer = s;
10700     imgdsc.dsc$w_length = wordbreak - s;
10701     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10702     if (!(retsts&1)) {
10703         _ckvmssts_noperl(lib$find_file_end(&cxt));
10704         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10705       if (!(retsts & 1) && *s == '$') {
10706         _ckvmssts_noperl(lib$find_file_end(&cxt));
10707         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10708         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10709         if (!(retsts&1)) {
10710           _ckvmssts_noperl(lib$find_file_end(&cxt));
10711           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10712         }
10713       }
10714     }
10715     _ckvmssts_noperl(lib$find_file_end(&cxt));
10716
10717     if (retsts & 1) {
10718       FILE *fp;
10719       s = resspec;
10720       while (*s && !isSPACE_L1(*s)) s++;
10721       *s = '\0';
10722
10723       /* check that it's really not DCL with no file extension */
10724       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10725       if (fp) {
10726         char b[256] = {0,0,0,0};
10727         read(fileno(fp), b, 256);
10728         isdcl = isPRINT_L1(b[0]) && isPRINT_L1(b[1]) && isPRINT_L1(b[2]) && isPRINT_L1(b[3]);
10729         if (isdcl) {
10730           int shebang_len;
10731
10732           /* Check for script */
10733           shebang_len = 0;
10734           if ((b[0] == '#') && (b[1] == '!'))
10735              shebang_len = 2;
10736 #ifdef ALTERNATE_SHEBANG
10737           else {
10738             if (strEQ(b, ALTERNATE_SHEBANG)) {
10739               char * perlstr;
10740                 perlstr = strstr("perl",b);
10741                 if (perlstr == NULL)
10742                   shebang_len = 0;
10743                 else
10744                   shebang_len = strlen(ALTERNATE_SHEBANG);
10745             }
10746             else
10747               shebang_len = 0;
10748           }
10749 #endif
10750
10751           if (shebang_len > 0) {
10752           int i;
10753           int j;
10754           char tmpspec[NAM$C_MAXRSS + 1];
10755
10756             i = shebang_len;
10757              /* Image is following after white space */
10758             /*--------------------------------------*/
10759             while (isPRINT_L1(b[i]) && isSPACE_L1(b[i]))
10760                 i++;
10761
10762             j = 0;
10763             while (isPRINT_L1(b[i]) && !isSPACE_L1(b[i])) {
10764                 tmpspec[j++] = b[i++];
10765                 if (j >= NAM$C_MAXRSS)
10766                    break;
10767             }
10768             tmpspec[j] = '\0';
10769
10770              /* There may be some default parameters to the image */
10771             /*---------------------------------------------------*/
10772             j = 0;
10773             while (isPRINT_L1(b[i])) {
10774                 image_argv[j++] = b[i++];
10775                 if (j >= NAM$C_MAXRSS)
10776                    break;
10777             }
10778             while ((j > 0) && !isPRINT_L1(image_argv[j-1]))
10779                 j--;
10780             image_argv[j] = 0;
10781
10782             /* It will need to be converted to VMS format and validated */
10783             if (tmpspec[0] != '\0') {
10784               char * iname;
10785
10786                /* Try to find the exact program requested to be run */
10787               /*---------------------------------------------------*/
10788               iname = int_rmsexpand
10789                  (tmpspec, image_name, ".exe",
10790                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10791               if (iname != NULL) {
10792                 if (cando_by_name_int
10793                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10794                   /* MCR prefix needed */
10795                   isdcl = 0;
10796                 }
10797                 else {
10798                    /* Try again with a null type */
10799                   /*----------------------------*/
10800                   iname = int_rmsexpand
10801                     (tmpspec, image_name, ".",
10802                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10803                   if (iname != NULL) {
10804                     if (cando_by_name_int
10805                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10806                       /* MCR prefix needed */
10807                       isdcl = 0;
10808                     }
10809                   }
10810                 }
10811
10812                  /* Did we find the image to run the script? */
10813                 /*------------------------------------------*/
10814                 if (isdcl) {
10815                   char *tchr;
10816
10817                    /* Assume DCL or foreign command exists */
10818                   /*--------------------------------------*/
10819                   tchr = strrchr(tmpspec, '/');
10820                   if (tchr != NULL) {
10821                     tchr++;
10822                   }
10823                   else {
10824                     tchr = tmpspec;
10825                   }
10826                   my_strlcpy(image_name, tchr, sizeof(image_name));
10827                 }
10828               }
10829             }
10830           }
10831         }
10832         fclose(fp);
10833       }
10834       if (check_img && isdcl) {
10835           PerlMem_free(cmd);
10836           PerlMem_free(resspec);
10837           PerlMem_free(vmsspec);
10838           return RMS$_FNF;
10839       }
10840
10841       if (cando_by_name(S_IXUSR,0,resspec)) {
10842         vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10843         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10844         if (!isdcl) {
10845             my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
10846             if (image_name[0] != 0) {
10847                 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10848                 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10849             }
10850         } else if (image_name[0] != 0) {
10851             my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10852             my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10853         } else {
10854             my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
10855         }
10856         if (suggest_quote) *suggest_quote = 1;
10857
10858         /* If there is an image name, use original command */
10859         if (image_name[0] == 0)
10860             my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
10861         else {
10862             rest = cmd;
10863             while (*rest && isSPACE_L1(*rest)) rest++;
10864         }
10865
10866         if (image_argv[0] != 0) {
10867           my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10868           my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
10869         }
10870         if (rest) {
10871            int rest_len;
10872            int vmscmd_len;
10873
10874            rest_len = strlen(rest);
10875            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10876            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10877               my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
10878            else
10879              retsts = CLI$_BUFOVF;
10880         }
10881         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10882         PerlMem_free(cmd);
10883         PerlMem_free(vmsspec);
10884         PerlMem_free(resspec);
10885         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10886       }
10887       else
10888         retsts = RMS$_PRV;
10889     }
10890   }
10891   /* It's either a DCL command or we couldn't find a suitable image */
10892   vmscmd->dsc$w_length = strlen(cmd);
10893
10894   vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
10895   my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
10896
10897   PerlMem_free(cmd);
10898   PerlMem_free(resspec);
10899   PerlMem_free(vmsspec);
10900
10901   /* check if it's a symbol (for quoting purposes) */
10902   if (suggest_quote && !*suggest_quote) {
10903     int iss;
10904     char equiv[LNM$C_NAMLENGTH];
10905     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10906     eqvdsc.dsc$a_pointer = equiv;
10907
10908     iss = lib$get_symbol(vmscmd,&eqvdsc);
10909     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10910   }
10911   if (!(retsts & 1)) {
10912     /* just hand off status values likely to be due to user error */
10913     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10914         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10915        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10916     else { _ckvmssts_noperl(retsts); }
10917   }
10918
10919   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10920
10921 }  /* end of setup_cmddsc() */
10922
10923
10924 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10925 bool
10926 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10927 {
10928   bool exec_sts;
10929   char * cmd;
10930
10931   if (vfork_called) {           /* this follows a vfork - act Unixish */
10932     vfork_called--;
10933     if (vfork_called < 0) {
10934       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10935       vfork_called = 0;
10936     }
10937     else return do_aexec(really,mark,sp);
10938   }
10939                                            /* no vfork - act VMSish */
10940   if (sp > mark) {
10941     ENTER;
10942     cmd = setup_argstr(aTHX_ really,mark,sp);
10943     exec_sts = vms_do_exec(cmd);
10944     LEAVE;
10945     return exec_sts;
10946   }
10947
10948   SETERRNO(ENOENT, RMS_FNF);
10949   return FALSE;
10950 }  /* end of vms_do_aexec() */
10951 /*}}}*/
10952
10953 /* {{{bool vms_do_exec(char *cmd) */
10954 bool
10955 Perl_vms_do_exec(pTHX_ const char *cmd)
10956 {
10957   struct dsc$descriptor_s *vmscmd;
10958
10959   if (vfork_called) {             /* this follows a vfork - act Unixish */
10960     vfork_called--;
10961     if (vfork_called < 0) {
10962       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10963       vfork_called = 0;
10964     }
10965     else return do_exec(cmd);
10966   }
10967
10968   {                               /* no vfork - act VMSish */
10969     unsigned long int retsts;
10970
10971     TAINT_ENV();
10972     TAINT_PROPER("exec");
10973     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10974       retsts = lib$do_command(vmscmd);
10975
10976     switch (retsts) {
10977       case RMS$_FNF: case RMS$_DNF:
10978         set_errno(ENOENT); break;
10979       case RMS$_DIR:
10980         set_errno(ENOTDIR); break;
10981       case RMS$_DEV:
10982         set_errno(ENODEV); break;
10983       case RMS$_PRV:
10984         set_errno(EACCES); break;
10985       case RMS$_SYN:
10986         set_errno(EINVAL); break;
10987       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10988         set_errno(E2BIG); break;
10989       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10990         _ckvmssts_noperl(retsts); /* fall through */
10991       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10992         set_errno(EVMSERR);
10993     }
10994     set_vaxc_errno(retsts);
10995     if (ckWARN(WARN_EXEC)) {
10996       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10997              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10998     }
10999     vms_execfree(vmscmd);
11000   }
11001
11002   return FALSE;
11003
11004 }  /* end of vms_do_exec() */
11005 /*}}}*/
11006
11007 int do_spawn2(pTHX_ const char *, int);
11008
11009 int
11010 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11011 {
11012   unsigned long int sts;
11013   char * cmd;
11014   int flags = 0;
11015
11016   if (sp > mark) {
11017
11018     /* We'll copy the (undocumented?) Win32 behavior and allow a
11019      * numeric first argument.  But the only value we'll support
11020      * through do_aspawn is a value of 1, which means spawn without
11021      * waiting for completion -- other values are ignored.
11022      */
11023     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11024         ++mark;
11025         flags = SvIVx(*mark);
11026     }
11027
11028     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
11029         flags = CLI$M_NOWAIT;
11030     else
11031         flags = 0;
11032
11033     ENTER;
11034     cmd = setup_argstr(aTHX_ really, mark, sp);
11035     sts = do_spawn2(aTHX_ cmd, flags);
11036     LEAVE;
11037     /* pp_sys will clean up cmd */
11038     return sts;
11039   }
11040   return SS$_ABORT;
11041 }  /* end of do_aspawn() */
11042 /*}}}*/
11043
11044
11045 /* {{{int do_spawn(char* cmd) */
11046 int
11047 Perl_do_spawn(pTHX_ char* cmd)
11048 {
11049     PERL_ARGS_ASSERT_DO_SPAWN;
11050
11051     return do_spawn2(aTHX_ cmd, 0);
11052 }
11053 /*}}}*/
11054
11055 /* {{{int do_spawn_nowait(char* cmd) */
11056 int
11057 Perl_do_spawn_nowait(pTHX_ char* cmd)
11058 {
11059     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11060
11061     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11062 }
11063 /*}}}*/
11064
11065 /* {{{int do_spawn2(char *cmd) */
11066 int
11067 do_spawn2(pTHX_ const char *cmd, int flags)
11068 {
11069   unsigned long int sts, substs;
11070
11071   TAINT_ENV();
11072   TAINT_PROPER("spawn");
11073   if (!cmd || !*cmd) {
11074     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11075     if (!(sts & 1)) {
11076       switch (sts) {
11077         case RMS$_FNF:  case RMS$_DNF:
11078           set_errno(ENOENT); break;
11079         case RMS$_DIR:
11080           set_errno(ENOTDIR); break;
11081         case RMS$_DEV:
11082           set_errno(ENODEV); break;
11083         case RMS$_PRV:
11084           set_errno(EACCES); break;
11085         case RMS$_SYN:
11086           set_errno(EINVAL); break;
11087         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11088           set_errno(E2BIG); break;
11089         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11090           _ckvmssts_noperl(sts); /* fall through */
11091         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11092           set_errno(EVMSERR);
11093       }
11094       set_vaxc_errno(sts);
11095       if (ckWARN(WARN_EXEC)) {
11096         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11097                     Strerror(errno));
11098       }
11099     }
11100     sts = substs;
11101   }
11102   else {
11103     char mode[3];
11104     PerlIO * fp;
11105     if (flags & CLI$M_NOWAIT)
11106         strcpy(mode, "n");
11107     else
11108         strcpy(mode, "nW");
11109
11110     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11111     if (fp != NULL)
11112       my_pclose(fp);
11113     /* sts will be the pid in the nowait case, so leave a
11114      * hint saying not to do any bit shifting to it.
11115      */
11116     if (flags & CLI$M_NOWAIT)
11117         PL_statusvalue = -1;
11118   }
11119   return sts;
11120 }  /* end of do_spawn2() */
11121 /*}}}*/
11122
11123
11124 static unsigned int *sockflags, sockflagsize;
11125
11126 /*
11127  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11128  * routines found in some versions of the CRTL can't deal with sockets.
11129  * We don't shim the other file open routines since a socket isn't
11130  * likely to be opened by a name.
11131  */
11132 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11133 FILE *
11134 my_fdopen(int fd, const char *mode)
11135 {
11136   FILE *fp = fdopen(fd, mode);
11137
11138   if (fp) {
11139     unsigned int fdoff = fd / sizeof(unsigned int);
11140     Stat_t sbuf; /* native stat; we don't need flex_stat */
11141     if (!sockflagsize || fdoff > sockflagsize) {
11142       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11143       else           Newx  (sockflags,fdoff+2,unsigned int);
11144       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11145       sockflagsize = fdoff + 2;
11146     }
11147     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11148       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11149   }
11150   return fp;
11151
11152 }
11153 /*}}}*/
11154
11155
11156 /*
11157  * Clear the corresponding bit when the (possibly) socket stream is closed.
11158  * There still a small hole: we miss an implicit close which might occur
11159  * via freopen().  >> Todo
11160  */
11161 /*{{{ int my_fclose(FILE *fp)*/
11162 int
11163 my_fclose(FILE *fp) {
11164   if (fp) {
11165     unsigned int fd = fileno(fp);
11166     unsigned int fdoff = fd / sizeof(unsigned int);
11167
11168     if (sockflagsize && fdoff < sockflagsize)
11169       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11170   }
11171   return fclose(fp);
11172 }
11173 /*}}}*/
11174
11175
11176 /*
11177  * A simple fwrite replacement which outputs itmsz*nitm chars without
11178  * introducing record boundaries every itmsz chars.
11179  * We are using fputs, which depends on a terminating null.  We may
11180  * well be writing binary data, so we need to accommodate not only
11181  * data with nulls sprinkled in the middle but also data with no null
11182  * byte at the end.
11183  */
11184 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11185 int
11186 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11187 {
11188   char *cp, *end, *cpd;
11189   char *data;
11190   unsigned int fd = fileno(dest);
11191   unsigned int fdoff = fd / sizeof(unsigned int);
11192   int retval;
11193   int bufsize = itmsz * nitm + 1;
11194
11195   if (fdoff < sockflagsize &&
11196       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11197     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11198     return nitm;
11199   }
11200
11201   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11202   memcpy( data, src, itmsz*nitm );
11203   data[itmsz*nitm] = '\0';
11204
11205   end = data + itmsz * nitm;
11206   retval = (int) nitm; /* on success return # items written */
11207
11208   cpd = data;
11209   while (cpd <= end) {
11210     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11211     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11212     if (cp < end)
11213       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11214     cpd = cp + 1;
11215   }
11216
11217   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11218   return retval;
11219
11220 }  /* end of my_fwrite() */
11221 /*}}}*/
11222
11223 /*{{{ int my_flush(FILE *fp)*/
11224 int
11225 Perl_my_flush(pTHX_ FILE *fp)
11226 {
11227     int res;
11228     if ((res = fflush(fp)) == 0 && fp) {
11229 #ifdef VMS_DO_SOCKETS
11230         Stat_t s;
11231         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11232 #endif
11233             res = fsync(fileno(fp));
11234     }
11235 /*
11236  * If the flush succeeded but set end-of-file, we need to clear
11237  * the error because our caller may check ferror().  BTW, this
11238  * probably means we just flushed an empty file.
11239  */
11240     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11241
11242     return res;
11243 }
11244 /*}}}*/
11245
11246 /* fgetname() is not returning the correct file specifications when
11247  * decc_filename_unix_report mode is active.  So we have to have it
11248  * aways return filenames in VMS mode and convert it ourselves.
11249  */
11250
11251 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11252 char *
11253 Perl_my_fgetname(FILE *fp, char * buf) {
11254     char * retname;
11255     char * vms_name;
11256
11257     retname = fgetname(fp, buf, 1);
11258
11259     /* If we are in VMS mode, then we are done */
11260     if (!DECC_FILENAME_UNIX_REPORT || (retname == NULL)) {
11261        return retname;
11262     }
11263
11264     /* Convert this to Unix format */
11265     vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
11266     my_strlcpy(vms_name, retname, VMS_MAXRSS);
11267     retname = int_tounixspec(vms_name, buf, NULL);
11268     PerlMem_free(vms_name);
11269
11270     return retname;
11271 }
11272 /*}}}*/
11273
11274 /*
11275  * Here are replacements for the following Unix routines in the VMS environment:
11276  *      getpwuid    Get information for a particular UIC or UID
11277  *      getpwnam    Get information for a named user
11278  *      getpwent    Get information for each user in the rights database
11279  *      setpwent    Reset search to the start of the rights database
11280  *      endpwent    Finish searching for users in the rights database
11281  *
11282  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11283  * (defined in pwd.h), which contains the following fields:-
11284  *      struct passwd {
11285  *              char        *pw_name;    Username (in lower case)
11286  *              char        *pw_passwd;  Hashed password
11287  *              unsigned int pw_uid;     UIC
11288  *              unsigned int pw_gid;     UIC group  number
11289  *              char        *pw_unixdir; Default device/directory (VMS-style)
11290  *              char        *pw_gecos;   Owner name
11291  *              char        *pw_dir;     Default device/directory (Unix-style)
11292  *              char        *pw_shell;   Default CLI name (eg. DCL)
11293  *      };
11294  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11295  *
11296  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11297  * not the UIC member number (eg. what's returned by getuid()),
11298  * getpwuid() can accept either as input (if uid is specified, the caller's
11299  * UIC group is used), though it won't recognise gid=0.
11300  *
11301  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11302  * information about other users in your group or in other groups, respectively.
11303  * If the required privilege is not available, then these routines fill only
11304  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11305  * string).
11306  *
11307  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11308  */
11309
11310 /* sizes of various UAF record fields */
11311 #define UAI$S_USERNAME 12
11312 #define UAI$S_IDENT    31
11313 #define UAI$S_OWNER    31
11314 #define UAI$S_DEFDEV   31
11315 #define UAI$S_DEFDIR   63
11316 #define UAI$S_DEFCLI   31
11317 #define UAI$S_PWD       8
11318
11319 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11320                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11321                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11322
11323 static char __empty[]= "";
11324 static struct passwd __passwd_empty=
11325     {(char *) __empty, (char *) __empty, 0, 0,
11326      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11327 static int contxt= 0;
11328 static struct passwd __pwdcache;
11329 static char __pw_namecache[UAI$S_IDENT+1];
11330
11331 /*
11332  * This routine does most of the work extracting the user information.
11333  */
11334 static int
11335 fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11336 {
11337     static struct {
11338         unsigned char length;
11339         char pw_gecos[UAI$S_OWNER+1];
11340     } owner;
11341     static union uicdef uic;
11342     static struct {
11343         unsigned char length;
11344         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11345     } defdev;
11346     static struct {
11347         unsigned char length;
11348         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11349     } defdir;
11350     static struct {
11351         unsigned char length;
11352         char pw_shell[UAI$S_DEFCLI+1];
11353     } defcli;
11354     static char pw_passwd[UAI$S_PWD+1];
11355
11356     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11357     struct dsc$descriptor_s name_desc;
11358     unsigned long int sts;
11359
11360     static struct itmlst_3 itmlst[]= {
11361         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11362         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11363         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11364         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11365         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11366         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11367         {0,                0,           NULL,    NULL}};
11368
11369     name_desc.dsc$w_length=  strlen(name);
11370     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11371     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11372     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11373
11374 /*  Note that sys$getuai returns many fields as counted strings. */
11375     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11376     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11377       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11378     }
11379     else { _ckvmssts(sts); }
11380     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11381
11382     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11383     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11384     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11385     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11386     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11387     owner.pw_gecos[lowner]=            '\0';
11388     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11389     defcli.pw_shell[ldefcli]=          '\0';
11390     if (valid_uic(uic)) {
11391         pwd->pw_uid= uic.uic$l_uic;
11392         pwd->pw_gid= uic.uic$v_group;
11393     }
11394     else
11395       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11396     pwd->pw_passwd=  pw_passwd;
11397     pwd->pw_gecos=   owner.pw_gecos;
11398     pwd->pw_dir=     defdev.pw_dir;
11399     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11400     pwd->pw_shell=   defcli.pw_shell;
11401     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11402         int ldir;
11403         ldir= strlen(pwd->pw_unixdir) - 1;
11404         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11405     }
11406     else
11407         my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
11408     if (!DECC_EFS_CASE_PRESERVE)
11409         __mystrtolower(pwd->pw_unixdir);
11410     return 1;
11411 }
11412
11413 /*
11414  * Get information for a named user.
11415 */
11416 /*{{{struct passwd *getpwnam(char *name)*/
11417 struct passwd *
11418 Perl_my_getpwnam(pTHX_ const char *name)
11419 {
11420     struct dsc$descriptor_s name_desc;
11421     union uicdef uic;
11422     unsigned long int sts;
11423
11424     __pwdcache = __passwd_empty;
11425     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11426       /* We still may be able to determine pw_uid and pw_gid */
11427       name_desc.dsc$w_length=  strlen(name);
11428       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11429       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11430       name_desc.dsc$a_pointer= (char *) name;
11431       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11432         __pwdcache.pw_uid= uic.uic$l_uic;
11433         __pwdcache.pw_gid= uic.uic$v_group;
11434       }
11435       else {
11436         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11437           set_vaxc_errno(sts);
11438           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11439           return NULL;
11440         }
11441         else { _ckvmssts(sts); }
11442       }
11443     }
11444     my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
11445     __pwdcache.pw_name= __pw_namecache;
11446     return &__pwdcache;
11447 }  /* end of my_getpwnam() */
11448 /*}}}*/
11449
11450 /*
11451  * Get information for a particular UIC or UID.
11452  * Called by my_getpwent with uid=-1 to list all users.
11453 */
11454 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11455 struct passwd *
11456 Perl_my_getpwuid(pTHX_ Uid_t uid)
11457 {
11458     const $DESCRIPTOR(name_desc,__pw_namecache);
11459     unsigned short lname;
11460     union uicdef uic;
11461     unsigned long int status;
11462
11463     if (uid == (unsigned int) -1) {
11464       do {
11465         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11466         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11467           set_vaxc_errno(status);
11468           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11469           my_endpwent();
11470           return NULL;
11471         }
11472         else { _ckvmssts(status); }
11473       } while (!valid_uic (uic));
11474     }
11475     else {
11476       uic.uic$l_uic= uid;
11477       if (!uic.uic$v_group)
11478         uic.uic$v_group= PerlProc_getgid();
11479       if (valid_uic(uic))
11480         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11481       else status = SS$_IVIDENT;
11482       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11483           status == RMS$_PRV) {
11484         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11485         return NULL;
11486       }
11487       else { _ckvmssts(status); }
11488     }
11489     __pw_namecache[lname]= '\0';
11490     __mystrtolower(__pw_namecache);
11491
11492     __pwdcache = __passwd_empty;
11493     __pwdcache.pw_name = __pw_namecache;
11494
11495 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11496     The identifier's value is usually the UIC, but it doesn't have to be,
11497     so if we can, we let fillpasswd update this. */
11498     __pwdcache.pw_uid =  uic.uic$l_uic;
11499     __pwdcache.pw_gid =  uic.uic$v_group;
11500
11501     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11502     return &__pwdcache;
11503
11504 }  /* end of my_getpwuid() */
11505 /*}}}*/
11506
11507 /*
11508  * Get information for next user.
11509 */
11510 /*{{{struct passwd *my_getpwent()*/
11511 struct passwd *
11512 Perl_my_getpwent(pTHX)
11513 {
11514     return (my_getpwuid((unsigned int) -1));
11515 }
11516 /*}}}*/
11517
11518 /*
11519  * Finish searching rights database for users.
11520 */
11521 /*{{{void my_endpwent()*/
11522 void
11523 Perl_my_endpwent(pTHX)
11524 {
11525     if (contxt) {
11526       _ckvmssts(sys$finish_rdb(&contxt));
11527       contxt= 0;
11528     }
11529 }
11530 /*}}}*/
11531
11532 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11533  * my_utime(), and flex_stat(), all of which operate on UTC unless
11534  * VMSISH_TIMES is true.
11535  */
11536 /* method used to handle UTC conversions:
11537  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11538  */
11539 static int gmtime_emulation_type;
11540 /* number of secs to add to UTC POSIX-style time to get local time */
11541 static long int utc_offset_secs;
11542
11543 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11544  * in vmsish.h.  #undef them here so we can call the CRTL routines
11545  * directly.
11546  */
11547 #undef gmtime
11548 #undef localtime
11549 #undef time
11550
11551
11552 static time_t toutc_dst(time_t loc) {
11553   struct tm *rsltmp;
11554
11555   if ((rsltmp = localtime(&loc)) == NULL) return -1u;
11556   loc -= utc_offset_secs;
11557   if (rsltmp->tm_isdst) loc -= 3600;
11558   return loc;
11559 }
11560 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11561        ((gmtime_emulation_type || my_time(NULL)), \
11562        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11563        ((secs) - utc_offset_secs))))
11564
11565 static time_t toloc_dst(time_t utc) {
11566   struct tm *rsltmp;
11567
11568   utc += utc_offset_secs;
11569   if ((rsltmp = localtime(&utc)) == NULL) return -1u;
11570   if (rsltmp->tm_isdst) utc += 3600;
11571   return utc;
11572 }
11573 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11574        ((gmtime_emulation_type || my_time(NULL)), \
11575        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11576        ((secs) + utc_offset_secs))))
11577
11578 /* my_time(), my_localtime(), my_gmtime()
11579  * By default traffic in UTC time values, using CRTL gmtime() or
11580  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11581  * Note: We need to use these functions even when the CRTL has working
11582  * UTC support, since they also handle C<use vmsish qw(times);>
11583  *
11584  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11585  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11586  */
11587
11588 /*{{{time_t my_time(time_t *timep)*/
11589 time_t
11590 Perl_my_time(pTHX_ time_t *timep)
11591 {
11592   time_t when;
11593   struct tm *tm_p;
11594
11595   if (gmtime_emulation_type == 0) {
11596     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11597                               /* results of calls to gmtime() and localtime() */
11598                               /* for same &base */
11599
11600     gmtime_emulation_type++;
11601     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11602       char off[LNM$C_NAMLENGTH+1];;
11603
11604       gmtime_emulation_type++;
11605       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11606         gmtime_emulation_type++;
11607         utc_offset_secs = 0;
11608         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11609       }
11610       else { utc_offset_secs = atol(off); }
11611     }
11612     else { /* We've got a working gmtime() */
11613       struct tm gmt, local;
11614
11615       gmt = *tm_p;
11616       tm_p = localtime(&base);
11617       local = *tm_p;
11618       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11619       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11620       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11621       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11622     }
11623   }
11624
11625   when = time(NULL);
11626 # ifdef VMSISH_TIME
11627   if (VMSISH_TIME) when = _toloc(when);
11628 # endif
11629   if (timep != NULL) *timep = when;
11630   return when;
11631
11632 }  /* end of my_time() */
11633 /*}}}*/
11634
11635
11636 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11637 struct tm *
11638 Perl_my_gmtime(pTHX_ const time_t *timep)
11639 {
11640   time_t when;
11641   struct tm *rsltmp;
11642
11643   if (timep == NULL) {
11644     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11645     return NULL;
11646   }
11647   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11648
11649   when = *timep;
11650 # ifdef VMSISH_TIME
11651   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11652 #  endif
11653   return gmtime(&when);
11654 }  /* end of my_gmtime() */
11655 /*}}}*/
11656
11657
11658 /*{{{struct tm *my_localtime(const time_t *timep)*/
11659 struct tm *
11660 Perl_my_localtime(pTHX_ const time_t *timep)
11661 {
11662   time_t when;
11663
11664   if (timep == NULL) {
11665     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11666     return NULL;
11667   }
11668   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11669   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11670
11671   when = *timep;
11672 # ifdef VMSISH_TIME
11673   if (VMSISH_TIME) when = _toutc(when);
11674 # endif
11675   /* CRTL localtime() wants UTC as input, does tz correction itself */
11676   return localtime(&when);
11677 } /*  end of my_localtime() */
11678 /*}}}*/
11679
11680 /* Reset definitions for later calls */
11681 #define gmtime(t)    my_gmtime(t)
11682 #define localtime(t) my_localtime(t)
11683 #define time(t)      my_time(t)
11684
11685
11686 /* my_utime - update modification/access time of a file
11687  *
11688  * Only the UTC translation is home-grown. The rest is handled by the
11689  * CRTL utime(), which will take into account the relevant feature
11690  * logicals and ODS-5 volume characteristics for true access times.
11691  *
11692  */
11693
11694 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11695  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11696  * in 100 ns intervals.
11697  */
11698 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11699
11700 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11701 int
11702 Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11703 {
11704   struct utimbuf utc_utimes, *utc_utimesp;
11705
11706   if (utimes != NULL) {
11707     utc_utimes.actime = utimes->actime;
11708     utc_utimes.modtime = utimes->modtime;
11709 # ifdef VMSISH_TIME
11710     /* If input was local; convert to UTC for sys svc */
11711     if (VMSISH_TIME) {
11712       utc_utimes.actime = _toutc(utimes->actime);
11713       utc_utimes.modtime = _toutc(utimes->modtime);
11714     }
11715 # endif
11716     utc_utimesp = &utc_utimes;
11717   }
11718   else {
11719     utc_utimesp = NULL;
11720   }
11721
11722   return utime(file, utc_utimesp);
11723
11724 }  /* end of my_utime() */
11725 /*}}}*/
11726
11727 /*
11728  * flex_stat, flex_lstat, flex_fstat
11729  * basic stat, but gets it right when asked to stat
11730  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11731  */
11732
11733 #ifndef _USE_STD_STAT
11734 /* encode_dev packs a VMS device name string into an integer to allow
11735  * simple comparisons. This can be used, for example, to check whether two
11736  * files are located on the same device, by comparing their encoded device
11737  * names. Even a string comparison would not do, because stat() reuses the
11738  * device name buffer for each call; so without encode_dev, it would be
11739  * necessary to save the buffer and use strcmp (this would mean a number of
11740  * changes to the standard Perl code, to say nothing of what a Perl script
11741  * would have to do.
11742  *
11743  * The device lock id, if it exists, should be unique (unless perhaps compared
11744  * with lock ids transferred from other nodes). We have a lock id if the disk is
11745  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11746  * device names. Thus we use the lock id in preference, and only if that isn't
11747  * available, do we try to pack the device name into an integer (flagged by
11748  * the sign bit (LOCKID_MASK) being set).
11749  *
11750  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11751  * name and its encoded form, but it seems very unlikely that we will find
11752  * two files on different disks that share the same encoded device names,
11753  * and even more remote that they will share the same file id (if the test
11754  * is to check for the same file).
11755  *
11756  * A better method might be to use sys$device_scan on the first call, and to
11757  * search for the device, returning an index into the cached array.
11758  * The number returned would be more intelligible.
11759  * This is probably not worth it, and anyway would take quite a bit longer
11760  * on the first call.
11761  */
11762 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11763 static mydev_t
11764 encode_dev (pTHX_ const char *dev)
11765 {
11766   int i;
11767   unsigned long int f;
11768   mydev_t enc;
11769   char c;
11770   const char *q;
11771
11772   if (!dev || !dev[0]) return 0;
11773
11774 #if LOCKID_MASK
11775   {
11776     struct dsc$descriptor_s dev_desc;
11777     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11778
11779     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11780        can try that first. */
11781     dev_desc.dsc$w_length =  strlen (dev);
11782     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11783     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11784     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11785     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11786     if (!$VMS_STATUS_SUCCESS(status)) {
11787       switch (status) {
11788         case SS$_NOSUCHDEV:
11789           SETERRNO(ENODEV, status);
11790           return 0;
11791         default:
11792           _ckvmssts(status);
11793       }
11794     }
11795     if (lockid) return (lockid & ~LOCKID_MASK);
11796   }
11797 #endif
11798
11799   /* Otherwise we try to encode the device name */
11800   enc = 0;
11801   f = 1;
11802   i = 0;
11803   for (q = dev + strlen(dev); q--; q >= dev) {
11804     if (*q == ':')
11805         break;
11806     if (isdigit (*q))
11807       c= (*q) - '0';
11808     else if (isALPHA_A(toUPPER_A(*q)))
11809       c= toupper (*q) - 'A' + (char)10;
11810     else
11811       continue; /* Skip '$'s */
11812     i++;
11813     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11814     if (i>1) f *= 36;
11815     enc += f * (unsigned long int) c;
11816   }
11817   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11818
11819 }  /* end of encode_dev() */
11820 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11821         device_no = encode_dev(aTHX_ devname)
11822 #else
11823 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11824         device_no = new_dev_no
11825 #endif
11826
11827 static int
11828 is_null_device(const char *name)
11829 {
11830   if (decc_bug_devnull != 0) {
11831     if (strBEGINs(name, "/dev/null"))
11832       return 1;
11833   }
11834     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11835        The underscore prefix, controller letter, and unit number are
11836        independently optional; for our purposes, the colon punctuation
11837        is not.  The colon can be trailed by optional directory and/or
11838        filename, but two consecutive colons indicates a nodename rather
11839        than a device.  [pr]  */
11840   if (*name == '_') ++name;
11841   if (toLOWER_L1(*name++) != 'n') return 0;
11842   if (toLOWER_L1(*name++) != 'l') return 0;
11843   if (toLOWER_L1(*name) == 'a') ++name;
11844   if (*name == '0') ++name;
11845   return (*name++ == ':') && (*name != ':');
11846 }
11847
11848 static int
11849 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
11850
11851 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11852
11853 static I32
11854 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective, const char *fname, int opts)
11855 {
11856   char usrname[L_cuserid];
11857   struct dsc$descriptor_s usrdsc =
11858          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11859   char *vmsname = NULL, *fileified = NULL;
11860   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11861   unsigned short int retlen, trnlnm_iter_count;
11862   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11863   union prvdef curprv;
11864   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11865          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11866          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11867   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11868          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11869          {0,0,0,0}};
11870   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11871          {0,0,0,0}};
11872   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11873   Stat_t st;
11874   static int profile_context = -1;
11875
11876   if (!fname || !*fname) return FALSE;
11877
11878   /* Make sure we expand logical names, since sys$check_access doesn't */
11879   fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
11880   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11881   if (!strpbrk(fname,"/]>:")) {
11882       my_strlcpy(fileified, fname, VMS_MAXRSS);
11883       trnlnm_iter_count = 0;
11884       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11885         trnlnm_iter_count++;
11886         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11887       }
11888       fname = fileified;
11889   }
11890
11891   vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
11892   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11893   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11894     /* Don't know if already in VMS format, so make sure */
11895     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11896       PerlMem_free(fileified);
11897       PerlMem_free(vmsname);
11898       return FALSE;
11899     }
11900   }
11901   else {
11902     my_strlcpy(vmsname, fname, VMS_MAXRSS);
11903   }
11904
11905   /* sys$check_access needs a file spec, not a directory spec.
11906    * flex_stat now will handle a null thread context during startup.
11907    */
11908
11909   retlen = namdsc.dsc$w_length = strlen(vmsname);
11910   if (vmsname[retlen-1] == ']'
11911       || vmsname[retlen-1] == '>'
11912       || vmsname[retlen-1] == ':'
11913       || (!flex_stat_int(vmsname, &st, 1) &&
11914           S_ISDIR(st.st_mode))) {
11915
11916       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
11917         PerlMem_free(fileified);
11918         PerlMem_free(vmsname);
11919         return FALSE;
11920       }
11921       fname = fileified;
11922   }
11923   else {
11924       fname = vmsname;
11925   }
11926
11927   retlen = namdsc.dsc$w_length = strlen(fname);
11928   namdsc.dsc$a_pointer = (char *)fname;
11929
11930   switch (bit) {
11931     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11932       access = ARM$M_EXECUTE;
11933       flags = CHP$M_READ;
11934       break;
11935     case S_IRUSR: case S_IRGRP: case S_IROTH:
11936       access = ARM$M_READ;
11937       flags = CHP$M_READ | CHP$M_USEREADALL;
11938       break;
11939     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11940       access = ARM$M_WRITE;
11941       flags = CHP$M_READ | CHP$M_WRITE;
11942       break;
11943     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11944       access = ARM$M_DELETE;
11945       flags = CHP$M_READ | CHP$M_WRITE;
11946       break;
11947     default:
11948       if (fileified != NULL)
11949         PerlMem_free(fileified);
11950       if (vmsname != NULL)
11951         PerlMem_free(vmsname);
11952       return FALSE;
11953   }
11954
11955   /* Before we call $check_access, create a user profile with the current
11956    * process privs since otherwise it just uses the default privs from the
11957    * UAF and might give false positives or negatives.  This only works on
11958    * VMS versions v6.0 and later since that's when sys$create_user_profile
11959    * became available.
11960    */
11961
11962   /* get current process privs and username */
11963   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11964   _ckvmssts_noperl(iosb[0]);
11965
11966   /* find out the space required for the profile */
11967   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11968                                     &usrprodsc.dsc$w_length,&profile_context));
11969
11970   /* allocate space for the profile and get it filled in */
11971   usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
11972   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11973   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11974                                     &usrprodsc.dsc$w_length,&profile_context));
11975
11976   /* use the profile to check access to the file; free profile & analyze results */
11977   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11978   PerlMem_free(usrprodsc.dsc$a_pointer);
11979   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11980
11981   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11982       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11983       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11984     set_vaxc_errno(retsts);
11985     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11986     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11987     else set_errno(ENOENT);
11988     if (fileified != NULL)
11989       PerlMem_free(fileified);
11990     if (vmsname != NULL)
11991       PerlMem_free(vmsname);
11992     return FALSE;
11993   }
11994   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11995     if (fileified != NULL)
11996       PerlMem_free(fileified);
11997     if (vmsname != NULL)
11998       PerlMem_free(vmsname);
11999     return TRUE;
12000   }
12001   _ckvmssts_noperl(retsts);
12002
12003   if (fileified != NULL)
12004     PerlMem_free(fileified);
12005   if (vmsname != NULL)
12006     PerlMem_free(vmsname);
12007   return FALSE;  /* Should never get here */
12008
12009 }
12010
12011 /* Do the permissions in *statbufp allow some operation? */
12012 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12013  * subset of the applicable information.
12014  */
12015 bool
12016 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12017 {
12018   return cando_by_name_int
12019         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12020 }  /* end of cando() */
12021 /*}}}*/
12022
12023
12024 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12025 I32
12026 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12027 {
12028    return cando_by_name_int(bit, effective, fname, 0);
12029
12030 }  /* end of cando_by_name() */
12031 /*}}}*/
12032
12033
12034 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12035 int
12036 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12037 {
12038   dSAVE_ERRNO; /* fstat may set this even on success */
12039   if (!fstat(fd, &statbufp->crtl_stat)) {
12040     char *cptr;
12041     char *vms_filename;
12042     vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
12043     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12044
12045     /* Save name for cando by name in VMS format */
12046     cptr = getname(fd, vms_filename, 1);
12047
12048     /* This should not happen, but just in case */
12049     if (cptr == NULL) {
12050         statbufp->st_devnam[0] = 0;
12051     }
12052     else {
12053         /* Make sure that the saved name fits in 255 characters */
12054         cptr = int_rmsexpand_vms
12055                        (vms_filename,
12056                         statbufp->st_devnam,
12057                         0);
12058         if (cptr == NULL)
12059             statbufp->st_devnam[0] = 0;
12060     }
12061     PerlMem_free(vms_filename);
12062
12063     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12064     VMS_DEVICE_ENCODE
12065         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12066
12067 #   ifdef VMSISH_TIME
12068     if (VMSISH_TIME) {
12069       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12070       statbufp->st_atime = _toloc(statbufp->st_atime);
12071       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12072     }
12073 #   endif
12074     RESTORE_ERRNO;
12075     return 0;
12076   }
12077   return -1;
12078
12079 }  /* end of flex_fstat() */
12080 /*}}}*/
12081
12082 static int
12083 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12084 {
12085     char *temp_fspec = NULL;
12086     char *fileified = NULL;
12087     const char *save_spec;
12088     char *ret_spec;
12089     int retval = -1;
12090     char efs_hack = 0;
12091     char already_fileified = 0;
12092     dSAVEDERRNO;
12093
12094     if (!fspec) {
12095         errno = EINVAL;
12096         return retval;
12097     }
12098
12099     if (decc_bug_devnull != 0) {
12100       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12101         memset(statbufp,0,sizeof *statbufp);
12102         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12103         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12104         statbufp->st_uid = 0x00010001;
12105         statbufp->st_gid = 0x0001;
12106         time((time_t *)&statbufp->st_mtime);
12107         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12108         return 0;
12109       }
12110     }
12111
12112     SAVE_ERRNO;
12113
12114 #if __CRTL_VER >= 80200000
12115   /*
12116    * If we are in POSIX filespec mode, accept the filename as is.
12117    */
12118   if (!DECC_POSIX_COMPLIANT_PATHNAMES) {
12119 #endif
12120
12121     /* Try for a simple stat first.  If fspec contains a filename without
12122      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12123      * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
12124      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12125      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12126      * the file with null type, specify this by calling flex_stat() with
12127      * a '.' at the end of fspec.
12128      */
12129
12130     if (lstat_flag == 0)
12131         retval = stat(fspec, &statbufp->crtl_stat);
12132     else
12133         retval = lstat(fspec, &statbufp->crtl_stat);
12134
12135     if (!retval) {
12136         save_spec = fspec;
12137     }
12138     else {
12139         /* In the odd case where we have write but not read access
12140          * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12141          */
12142         fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12143         if (fileified == NULL)
12144               _ckvmssts_noperl(SS$_INSFMEM);
12145
12146         ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12147         if (ret_spec != NULL) {
12148             if (lstat_flag == 0)
12149                 retval = stat(fileified, &statbufp->crtl_stat);
12150             else
12151                 retval = lstat(fileified, &statbufp->crtl_stat);
12152             save_spec = fileified;
12153             already_fileified = 1;
12154         }
12155     }
12156
12157     if (retval && vms_bug_stat_filename) {
12158
12159         temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
12160         if (temp_fspec == NULL)
12161             _ckvmssts_noperl(SS$_INSFMEM);
12162
12163         /* We should try again as a vmsified file specification. */
12164
12165         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12166         if (ret_spec != NULL) {
12167             if (lstat_flag == 0)
12168                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12169             else
12170                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12171             save_spec = temp_fspec;
12172         }
12173     }
12174
12175     if (retval) {
12176         /* Last chance - allow multiple dots without EFS CHARSET */
12177         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12178          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12179          * enable it if it isn't already.
12180          */
12181         if (!DECC_EFS_CHARSET && (efs_charset_index > 0))
12182             decc$feature_set_value(efs_charset_index, 1, 1);
12183         if (lstat_flag == 0)
12184             retval = stat(fspec, &statbufp->crtl_stat);
12185         else
12186             retval = lstat(fspec, &statbufp->crtl_stat);
12187         save_spec = fspec;
12188         if (!DECC_EFS_CHARSET && (efs_charset_index > 0)) {
12189             decc$feature_set_value(efs_charset_index, 1, 0);
12190             efs_hack = 1;
12191         }
12192     }
12193
12194 #if __CRTL_VER >= 80200000
12195   } else {
12196     if (lstat_flag == 0)
12197       retval = stat(temp_fspec, &statbufp->crtl_stat);
12198     else
12199       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12200       save_spec = temp_fspec;
12201   }
12202 #endif
12203
12204   /* As you were... */
12205   if (!DECC_EFS_CHARSET)
12206     decc$feature_set_value(efs_charset_index,1,0);
12207
12208     if (!retval) {
12209       char *cptr;
12210       int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12211
12212       /* If this is an lstat, do not follow the link */
12213       if (lstat_flag)
12214         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12215
12216       /* If we used the efs_hack above, we must also use it here for */
12217       /* perl_cando to work */
12218       if (efs_hack && (efs_charset_index > 0)) {
12219           decc$feature_set_value(efs_charset_index, 1, 1);
12220       }
12221
12222       /* If we've got a directory, save a fileified, expanded version of it
12223        * in st_devnam.  If not a directory, just an expanded version.
12224        */
12225       if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
12226           fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
12227           if (fileified == NULL)
12228               _ckvmssts_noperl(SS$_INSFMEM);
12229
12230           cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12231           if (cptr != NULL)
12232               save_spec = fileified;
12233       }
12234
12235       cptr = int_rmsexpand(save_spec,
12236                            statbufp->st_devnam,
12237                            NULL,
12238                            rmsex_flags,
12239                            0,
12240                            0);
12241
12242       if (efs_hack && (efs_charset_index > 0)) {
12243           decc$feature_set_value(efs_charset_index, 1, 0);
12244       }
12245
12246       /* Fix me: If this is NULL then stat found a file, and we could */
12247       /* not convert the specification to VMS - Should never happen */
12248       if (cptr == NULL)
12249         statbufp->st_devnam[0] = 0;
12250
12251       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12252       VMS_DEVICE_ENCODE
12253         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12254 #     ifdef VMSISH_TIME
12255       if (VMSISH_TIME) {
12256         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12257         statbufp->st_atime = _toloc(statbufp->st_atime);
12258         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12259       }
12260 #     endif
12261     }
12262     /* If we were successful, leave errno where we found it */
12263     if (retval == 0) RESTORE_ERRNO;
12264     if (temp_fspec)
12265         PerlMem_free(temp_fspec);
12266     if (fileified)
12267         PerlMem_free(fileified);
12268     return retval;
12269
12270 }  /* end of flex_stat_int() */
12271
12272
12273 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12274 int
12275 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12276 {
12277    return flex_stat_int(fspec, statbufp, 0);
12278 }
12279 /*}}}*/
12280
12281 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12282 int
12283 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12284 {
12285    return flex_stat_int(fspec, statbufp, 1);
12286 }
12287 /*}}}*/
12288
12289
12290 /*  rmscopy - copy a file using VMS RMS routines
12291  *
12292  *  Copies contents and attributes of spec_in to spec_out, except owner
12293  *  and protection information.  Name and type of spec_in are used as
12294  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12295  *  should try to propagate timestamps from the input file to the output file.
12296  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12297  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12298  *  propagated to the output file at creation iff the output file specification
12299  *  did not contain an explicit name or type, and the revision date is always
12300  *  updated at the end of the copy operation.  If it is greater than 0, then
12301  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12302  *  other than the revision date should be propagated, and bit 1 indicates
12303  *  that the revision date should be propagated.
12304  *
12305  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12306  *
12307  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12308  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12309  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12310  * as part of the Perl standard distribution under the terms of the
12311  * GNU General Public License or the Perl Artistic License.  Copies
12312  * of each may be found in the Perl standard distribution.
12313  */ /* FIXME */
12314 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12315 int
12316 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12317 {
12318     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12319          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12320     unsigned long int sts;
12321     int dna_len;
12322     struct FAB fab_in, fab_out;
12323     struct RAB rab_in, rab_out;
12324     rms_setup_nam(nam);
12325     rms_setup_nam(nam_out);
12326     struct XABDAT xabdat;
12327     struct XABFHC xabfhc;
12328     struct XABRDT xabrdt;
12329     struct XABSUM xabsum;
12330
12331     vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
12332     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12333     vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
12334     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12335     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12336         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12337       PerlMem_free(vmsin);
12338       PerlMem_free(vmsout);
12339       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12340       return 0;
12341     }
12342
12343     esa = (char *)PerlMem_malloc(VMS_MAXRSS);
12344     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12345     esal = NULL;
12346 #if defined(NAML$C_MAXRSS)
12347     esal = (char *)PerlMem_malloc(VMS_MAXRSS);
12348     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12349 #endif
12350     fab_in = cc$rms_fab;
12351     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12352     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12353     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12354     fab_in.fab$l_fop = FAB$M_SQO;
12355     rms_bind_fab_nam(fab_in, nam);
12356     fab_in.fab$l_xab = (void *) &xabdat;
12357
12358     rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
12359     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12360     rsal = NULL;
12361 #if defined(NAML$C_MAXRSS)
12362     rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
12363     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12364 #endif
12365     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12366     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12367     rms_nam_esl(nam) = 0;
12368     rms_nam_rsl(nam) = 0;
12369     rms_nam_esll(nam) = 0;
12370     rms_nam_rsll(nam) = 0;
12371 #ifdef NAM$M_NO_SHORT_UPCASE
12372     if (DECC_EFS_CASE_PRESERVE)
12373         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12374 #endif
12375
12376     xabdat = cc$rms_xabdat;        /* To get creation date */
12377     xabdat.xab$l_nxt = (void *) &xabfhc;
12378
12379     xabfhc = cc$rms_xabfhc;        /* To get record length */
12380     xabfhc.xab$l_nxt = (void *) &xabsum;
12381
12382     xabsum = cc$rms_xabsum;        /* To get key and area information */
12383
12384     if (!((sts = sys$open(&fab_in)) & 1)) {
12385       PerlMem_free(vmsin);
12386       PerlMem_free(vmsout);
12387       PerlMem_free(esa);
12388       if (esal != NULL)
12389         PerlMem_free(esal);
12390       PerlMem_free(rsa);
12391       if (rsal != NULL)
12392         PerlMem_free(rsal);
12393       set_vaxc_errno(sts);
12394       switch (sts) {
12395         case RMS$_FNF: case RMS$_DNF:
12396           set_errno(ENOENT); break;
12397         case RMS$_DIR:
12398           set_errno(ENOTDIR); break;
12399         case RMS$_DEV:
12400           set_errno(ENODEV); break;
12401         case RMS$_SYN:
12402           set_errno(EINVAL); break;
12403         case RMS$_PRV:
12404           set_errno(EACCES); break;
12405         default:
12406           set_errno(EVMSERR);
12407       }
12408       return 0;
12409     }
12410
12411     nam_out = nam;
12412     fab_out = fab_in;
12413     fab_out.fab$w_ifi = 0;
12414     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12415     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12416     fab_out.fab$l_fop = FAB$M_SQO;
12417     rms_bind_fab_nam(fab_out, nam_out);
12418     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12419     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12420     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12421     esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12422     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12423     rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
12424     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12425     esal_out = NULL;
12426     rsal_out = NULL;
12427 #if defined(NAML$C_MAXRSS)
12428     esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12429     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12430     rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
12431     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12432 #endif
12433     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12434     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12435
12436     if (preserve_dates == 0) {  /* Act like DCL COPY */
12437       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12438       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12439       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12440         PerlMem_free(vmsin);
12441         PerlMem_free(vmsout);
12442         PerlMem_free(esa);
12443         if (esal != NULL)
12444             PerlMem_free(esal);
12445         PerlMem_free(rsa);
12446         if (rsal != NULL)
12447             PerlMem_free(rsal);
12448         PerlMem_free(esa_out);
12449         if (esal_out != NULL)
12450             PerlMem_free(esal_out);
12451         PerlMem_free(rsa_out);
12452         if (rsal_out != NULL)
12453             PerlMem_free(rsal_out);
12454         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12455         set_vaxc_errno(sts);
12456         return 0;
12457       }
12458       fab_out.fab$l_xab = (void *) &xabdat;
12459       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12460         preserve_dates = 1;
12461     }
12462     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12463       preserve_dates =0;      /* bitmask from this point forward   */
12464
12465     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12466     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12467       PerlMem_free(vmsin);
12468       PerlMem_free(vmsout);
12469       PerlMem_free(esa);
12470       if (esal != NULL)
12471           PerlMem_free(esal);
12472       PerlMem_free(rsa);
12473       if (rsal != NULL)
12474           PerlMem_free(rsal);
12475       PerlMem_free(esa_out);
12476       if (esal_out != NULL)
12477           PerlMem_free(esal_out);
12478       PerlMem_free(rsa_out);
12479       if (rsal_out != NULL)
12480           PerlMem_free(rsal_out);
12481       set_vaxc_errno(sts);
12482       switch (sts) {
12483         case RMS$_DNF:
12484           set_errno(ENOENT); break;
12485         case RMS$_DIR:
12486           set_errno(ENOTDIR); break;
12487         case RMS$_DEV:
12488           set_errno(ENODEV); break;
12489         case RMS$_SYN:
12490           set_errno(EINVAL); break;
12491         case RMS$_PRV:
12492           set_errno(EACCES); break;
12493         default:
12494           set_errno(EVMSERR);
12495       }
12496       return 0;
12497     }
12498     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12499     if (preserve_dates & 2) {
12500       /* sys$close() will process xabrdt, not xabdat */
12501       xabrdt = cc$rms_xabrdt;
12502       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12503       fab_out.fab$l_xab = (void *) &xabrdt;
12504     }
12505
12506     ubf = (char *)PerlMem_malloc(32256);
12507     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12508     rab_in = cc$rms_rab;
12509     rab_in.rab$l_fab = &fab_in;
12510     rab_in.rab$l_rop = RAB$M_BIO;
12511     rab_in.rab$l_ubf = ubf;
12512     rab_in.rab$w_usz = 32256;
12513     if (!((sts = sys$connect(&rab_in)) & 1)) {
12514       sys$close(&fab_in); sys$close(&fab_out);
12515       PerlMem_free(vmsin);
12516       PerlMem_free(vmsout);
12517       PerlMem_free(ubf);
12518       PerlMem_free(esa);
12519       if (esal != NULL)
12520           PerlMem_free(esal);
12521       PerlMem_free(rsa);
12522       if (rsal != NULL)
12523           PerlMem_free(rsal);
12524       PerlMem_free(esa_out);
12525       if (esal_out != NULL)
12526           PerlMem_free(esal_out);
12527       PerlMem_free(rsa_out);
12528       if (rsal_out != NULL)
12529           PerlMem_free(rsal_out);
12530       set_errno(EVMSERR); set_vaxc_errno(sts);
12531       return 0;
12532     }
12533
12534     rab_out = cc$rms_rab;
12535     rab_out.rab$l_fab = &fab_out;
12536     rab_out.rab$l_rbf = ubf;
12537     if (!((sts = sys$connect(&rab_out)) & 1)) {
12538       sys$close(&fab_in); sys$close(&fab_out);
12539       PerlMem_free(vmsin);
12540       PerlMem_free(vmsout);
12541       PerlMem_free(ubf);
12542       PerlMem_free(esa);
12543       if (esal != NULL)
12544           PerlMem_free(esal);
12545       PerlMem_free(rsa);
12546       if (rsal != NULL)
12547           PerlMem_free(rsal);
12548       PerlMem_free(esa_out);
12549       if (esal_out != NULL)
12550           PerlMem_free(esal_out);
12551       PerlMem_free(rsa_out);
12552       if (rsal_out != NULL)
12553           PerlMem_free(rsal_out);
12554       set_errno(EVMSERR); set_vaxc_errno(sts);
12555       return 0;
12556     }
12557
12558     while ((sts = sys$read(&rab_in))) {  /* always true  */
12559       if (sts == RMS$_EOF) break;
12560       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12561       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12562         sys$close(&fab_in); sys$close(&fab_out);
12563         PerlMem_free(vmsin);
12564         PerlMem_free(vmsout);
12565         PerlMem_free(ubf);
12566         PerlMem_free(esa);
12567         if (esal != NULL)
12568             PerlMem_free(esal);
12569         PerlMem_free(rsa);
12570         if (rsal != NULL)
12571             PerlMem_free(rsal);
12572         PerlMem_free(esa_out);
12573         if (esal_out != NULL)
12574             PerlMem_free(esal_out);
12575         PerlMem_free(rsa_out);
12576         if (rsal_out != NULL)
12577             PerlMem_free(rsal_out);
12578         set_errno(EVMSERR); set_vaxc_errno(sts);
12579         return 0;
12580       }
12581     }
12582
12583
12584     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12585     sys$close(&fab_in);  sys$close(&fab_out);
12586     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12587
12588     PerlMem_free(vmsin);
12589     PerlMem_free(vmsout);
12590     PerlMem_free(ubf);
12591     PerlMem_free(esa);
12592     if (esal != NULL)
12593         PerlMem_free(esal);
12594     PerlMem_free(rsa);
12595     if (rsal != NULL)
12596         PerlMem_free(rsal);
12597     PerlMem_free(esa_out);
12598     if (esal_out != NULL)
12599         PerlMem_free(esal_out);
12600     PerlMem_free(rsa_out);
12601     if (rsal_out != NULL)
12602         PerlMem_free(rsal_out);
12603
12604     if (!(sts & 1)) {
12605       set_errno(EVMSERR); set_vaxc_errno(sts);
12606       return 0;
12607     }
12608
12609     return 1;
12610
12611 }  /* end of rmscopy() */
12612 /*}}}*/
12613
12614
12615 /***  The following glue provides 'hooks' to make some of the routines
12616  * from this file available from Perl.  These routines are sufficiently
12617  * basic, and are required sufficiently early in the build process,
12618  * that's it's nice to have them available to miniperl as well as the
12619  * full Perl, so they're set up here instead of in an extension.  The
12620  * Perl code which handles importation of these names into a given
12621  * package lives in [.VMS]Filespec.pm in @INC.
12622  */
12623
12624 void
12625 rmsexpand_fromperl(pTHX_ CV *cv)
12626 {
12627   dXSARGS;
12628   char *fspec, *defspec = NULL, *rslt;
12629   STRLEN n_a;
12630   int fs_utf8, dfs_utf8;
12631
12632   fs_utf8 = 0;
12633   dfs_utf8 = 0;
12634   if (!items || items > 2)
12635     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12636   fspec = SvPV(ST(0),n_a);
12637   fs_utf8 = SvUTF8(ST(0));
12638   if (!fspec || !*fspec) XSRETURN_UNDEF;
12639   if (items == 2) {
12640     defspec = SvPV(ST(1),n_a);
12641     dfs_utf8 = SvUTF8(ST(1));
12642   }
12643   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12644   ST(0) = sv_newmortal();
12645   if (rslt != NULL) {
12646     sv_usepvn(ST(0),rslt,strlen(rslt));
12647     if (fs_utf8) {
12648         SvUTF8_on(ST(0));
12649     }
12650   }
12651   XSRETURN(1);
12652 }
12653
12654 void
12655 vmsify_fromperl(pTHX_ CV *cv)
12656 {
12657   dXSARGS;
12658   char *vmsified;
12659   STRLEN n_a;
12660   int utf8_fl;
12661
12662   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12663   utf8_fl = SvUTF8(ST(0));
12664   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12665   ST(0) = sv_newmortal();
12666   if (vmsified != NULL) {
12667     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12668     if (utf8_fl) {
12669         SvUTF8_on(ST(0));
12670     }
12671   }
12672   XSRETURN(1);
12673 }
12674
12675 void
12676 unixify_fromperl(pTHX_ CV *cv)
12677 {
12678   dXSARGS;
12679   char *unixified;
12680   STRLEN n_a;
12681   int utf8_fl;
12682
12683   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12684   utf8_fl = SvUTF8(ST(0));
12685   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12686   ST(0) = sv_newmortal();
12687   if (unixified != NULL) {
12688     sv_usepvn(ST(0),unixified,strlen(unixified));
12689     if (utf8_fl) {
12690         SvUTF8_on(ST(0));
12691     }
12692   }
12693   XSRETURN(1);
12694 }
12695
12696 void
12697 fileify_fromperl(pTHX_ CV *cv)
12698 {
12699   dXSARGS;
12700   char *fileified;
12701   STRLEN n_a;
12702   int utf8_fl;
12703
12704   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12705   utf8_fl = SvUTF8(ST(0));
12706   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12707   ST(0) = sv_newmortal();
12708   if (fileified != NULL) {
12709     sv_usepvn(ST(0),fileified,strlen(fileified));
12710     if (utf8_fl) {
12711         SvUTF8_on(ST(0));
12712     }
12713   }
12714   XSRETURN(1);
12715 }
12716
12717 void
12718 pathify_fromperl(pTHX_ CV *cv)
12719 {
12720   dXSARGS;
12721   char *pathified;
12722   STRLEN n_a;
12723   int utf8_fl;
12724
12725   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12726   utf8_fl = SvUTF8(ST(0));
12727   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12728   ST(0) = sv_newmortal();
12729   if (pathified != NULL) {
12730     sv_usepvn(ST(0),pathified,strlen(pathified));
12731     if (utf8_fl) {
12732         SvUTF8_on(ST(0));
12733     }
12734   }
12735   XSRETURN(1);
12736 }
12737
12738 void
12739 vmspath_fromperl(pTHX_ CV *cv)
12740 {
12741   dXSARGS;
12742   char *vmspath;
12743   STRLEN n_a;
12744   int utf8_fl;
12745
12746   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12747   utf8_fl = SvUTF8(ST(0));
12748   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12749   ST(0) = sv_newmortal();
12750   if (vmspath != NULL) {
12751     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12752     if (utf8_fl) {
12753         SvUTF8_on(ST(0));
12754     }
12755   }
12756   XSRETURN(1);
12757 }
12758
12759 void
12760 unixpath_fromperl(pTHX_ CV *cv)
12761 {
12762   dXSARGS;
12763   char *unixpath;
12764   STRLEN n_a;
12765   int utf8_fl;
12766
12767   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12768   utf8_fl = SvUTF8(ST(0));
12769   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12770   ST(0) = sv_newmortal();
12771   if (unixpath != NULL) {
12772     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12773     if (utf8_fl) {
12774         SvUTF8_on(ST(0));
12775     }
12776   }
12777   XSRETURN(1);
12778 }
12779
12780 void
12781 candelete_fromperl(pTHX_ CV *cv)
12782 {
12783   dXSARGS;
12784   char *fspec, *fsp;
12785   SV *mysv;
12786   IO *io;
12787   STRLEN n_a;
12788
12789   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12790
12791   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12792   Newx(fspec, VMS_MAXRSS, char);
12793   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12794   if (isGV_with_GP(mysv)) {
12795     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12796       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12797       ST(0) = &PL_sv_no;
12798       Safefree(fspec);
12799       XSRETURN(1);
12800     }
12801     fsp = fspec;
12802   }
12803   else {
12804     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12805       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12806       ST(0) = &PL_sv_no;
12807       Safefree(fspec);
12808       XSRETURN(1);
12809     }
12810   }
12811
12812   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12813   Safefree(fspec);
12814   XSRETURN(1);
12815 }
12816
12817 void
12818 rmscopy_fromperl(pTHX_ CV *cv)
12819 {
12820   dXSARGS;
12821   char *inspec, *outspec, *inp, *outp;
12822   int date_flag;
12823   SV *mysv;
12824   IO *io;
12825   STRLEN n_a;
12826
12827   if (items < 2 || items > 3)
12828     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12829
12830   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12831   Newx(inspec, VMS_MAXRSS, char);
12832   if (isGV_with_GP(mysv)) {
12833     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12834       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12835       ST(0) = sv_2mortal(newSViv(0));
12836       Safefree(inspec);
12837       XSRETURN(1);
12838     }
12839     inp = inspec;
12840   }
12841   else {
12842     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12843       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12844       ST(0) = sv_2mortal(newSViv(0));
12845       Safefree(inspec);
12846       XSRETURN(1);
12847     }
12848   }
12849   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12850   Newx(outspec, VMS_MAXRSS, char);
12851   if (isGV_with_GP(mysv)) {
12852     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12853       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12854       ST(0) = sv_2mortal(newSViv(0));
12855       Safefree(inspec);
12856       Safefree(outspec);
12857       XSRETURN(1);
12858     }
12859     outp = outspec;
12860   }
12861   else {
12862     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12863       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12864       ST(0) = sv_2mortal(newSViv(0));
12865       Safefree(inspec);
12866       Safefree(outspec);
12867       XSRETURN(1);
12868     }
12869   }
12870   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12871
12872   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
12873   Safefree(inspec);
12874   Safefree(outspec);
12875   XSRETURN(1);
12876 }
12877
12878 /* The mod2fname is limited to shorter filenames by design, so it should
12879  * not be modified to support longer EFS pathnames
12880  */
12881 void
12882 mod2fname(pTHX_ CV *cv)
12883 {
12884   dXSARGS;
12885   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12886        workbuff[NAM$C_MAXRSS*1 + 1];
12887   SSize_t counter, num_entries;
12888   /* ODS-5 ups this, but we want to be consistent, so... */
12889   int max_name_len = 39;
12890   AV *in_array = (AV *)SvRV(ST(0));
12891
12892   num_entries = av_tindex(in_array);
12893
12894   /* All the names start with PL_. */
12895   strcpy(ultimate_name, "PL_");
12896
12897   /* Clean up our working buffer */
12898   Zero(work_name, sizeof(work_name), char);
12899
12900   /* Run through the entries and build up a working name */
12901   for(counter = 0; counter <= num_entries; counter++) {
12902     /* If it's not the first name then tack on a __ */
12903     if (counter) {
12904       my_strlcat(work_name, "__", sizeof(work_name));
12905     }
12906     my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
12907   }
12908
12909   /* Check to see if we actually have to bother...*/
12910   if (strlen(work_name) + 3 <= max_name_len) {
12911     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12912   } else {
12913     /* It's too darned big, so we need to go strip. We use the same */
12914     /* algorithm as xsubpp does. First, strip out doubled __ */
12915     char *source, *dest, last;
12916     dest = workbuff;
12917     last = 0;
12918     for (source = work_name; *source; source++) {
12919       if (last == *source && last == '_') {
12920         continue;
12921       }
12922       *dest++ = *source;
12923       last = *source;
12924     }
12925     /* Go put it back */
12926     my_strlcpy(work_name, workbuff, sizeof(work_name));
12927     /* Is it still too big? */
12928     if (strlen(work_name) + 3 > max_name_len) {
12929       /* Strip duplicate letters */
12930       last = 0;
12931       dest = workbuff;
12932       for (source = work_name; *source; source++) {
12933         if (last == toUPPER_A(*source)) {
12934         continue;
12935         }
12936         *dest++ = *source;
12937         last = toUPPER_A(*source);
12938       }
12939       my_strlcpy(work_name, workbuff, sizeof(work_name));
12940     }
12941
12942     /* Is it *still* too big? */
12943     if (strlen(work_name) + 3 > max_name_len) {
12944       /* Too bad, we truncate */
12945       work_name[max_name_len - 2] = 0;
12946     }
12947     my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
12948   }
12949
12950   /* Okay, return it */
12951   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12952   XSRETURN(1);
12953 }
12954
12955 void
12956 hushexit_fromperl(pTHX_ CV *cv)
12957 {
12958     dXSARGS;
12959
12960     if (items > 0) {
12961         VMSISH_HUSHED = SvTRUE(ST(0));
12962     }
12963     ST(0) = boolSV(VMSISH_HUSHED);
12964     XSRETURN(1);
12965 }
12966
12967
12968 PerlIO *
12969 Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io)
12970 {
12971     PerlIO *fp;
12972     struct vs_str_st *rslt;
12973     char *vmsspec;
12974     char *rstr;
12975     char *begin, *cp;
12976     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12977     PerlIO *tmpfp;
12978     STRLEN i;
12979     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12980     struct dsc$descriptor_vs rsdsc;
12981     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12982     unsigned long hasver = 0, isunix = 0;
12983     unsigned long int lff_flags = 0;
12984     int rms_sts;
12985     int vms_old_glob = 1;
12986
12987     if (!SvOK(tmpglob)) {
12988         SETERRNO(ENOENT,RMS$_FNF);
12989         return NULL;
12990     }
12991
12992     vms_old_glob = !DECC_FILENAME_UNIX_REPORT;
12993
12994 #ifdef VMS_LONGNAME_SUPPORT
12995     lff_flags = LIB$M_FIL_LONG_NAMES;
12996 #endif
12997     /* The Newx macro will not allow me to assign a smaller array
12998      * to the rslt pointer, so we will assign it to the begin char pointer
12999      * and then copy the value into the rslt pointer.
13000      */
13001     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13002     rslt = (struct vs_str_st *)begin;
13003     rslt->length = 0;
13004     rstr = &rslt->str[0];
13005     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13006     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13007     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13008     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13009
13010     Newx(vmsspec, VMS_MAXRSS, char);
13011
13012         /* We could find out if there's an explicit dev/dir or version
13013            by peeking into lib$find_file's internal context at
13014            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13015            but that's unsupported, so I don't want to do it now and
13016            have it bite someone in the future. */
13017         /* Fix-me: vms_split_path() is the only way to do this, the
13018            existing method will fail with many legal EFS or UNIX specifications
13019          */
13020
13021     cp = SvPV(tmpglob,i);
13022
13023     for (; i; i--) {
13024         if (cp[i] == ';') hasver = 1;
13025         if (cp[i] == '.') {
13026             if (sts) hasver = 1;
13027             else sts = 1;
13028         }
13029         if (cp[i] == '/') {
13030             hasdir = isunix = 1;
13031             break;
13032         }
13033         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13034             hasdir = 1;
13035             break;
13036         }
13037     }
13038
13039     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13040     if ((hasdir == 0) && DECC_FILENAME_UNIX_REPORT) {
13041         isunix = 1;
13042     }
13043
13044     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13045         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13046         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13047         int wildstar = 0;
13048         int wildquery = 0;
13049         int found = 0;
13050         Stat_t st;
13051         int stat_sts;
13052         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13053         if (!stat_sts && S_ISDIR(st.st_mode)) {
13054             char * vms_dir;
13055             const char * fname;
13056             STRLEN fname_len;
13057
13058             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13059             /* path delimiter of ':>]', if so, then the old behavior has */
13060             /* obviously been specifically requested */
13061
13062             fname = SvPVX_const(tmpglob);
13063             fname_len = strlen(fname);
13064             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13065             if (vms_old_glob || (vms_dir != NULL)) {
13066                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13067                                             SvPVX(tmpglob),vmsspec,NULL);
13068                 ok = (wilddsc.dsc$a_pointer != NULL);
13069                 /* maybe passed 'foo' rather than '[.foo]', thus not
13070                    detected above */
13071                 hasdir = 1;
13072             } else {
13073                 /* Operate just on the directory, the special stat/fstat for */
13074                 /* leaves the fileified  specification in the st_devnam */
13075                 /* member. */
13076                 wilddsc.dsc$a_pointer = st.st_devnam;
13077                 ok = 1;
13078             }
13079         }
13080         else {
13081             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13082             ok = (wilddsc.dsc$a_pointer != NULL);
13083         }
13084         if (ok)
13085             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13086
13087         /* If not extended character set, replace ? with % */
13088         /* With extended character set, ? is a wildcard single character */
13089         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13090             if (*cp == '?') {
13091                 wildquery = 1;
13092                 if (!DECC_EFS_CHARSET)
13093                     *cp = '%';
13094             } else if (*cp == '%') {
13095                 wildquery = 1;
13096             } else if (*cp == '*') {
13097                 wildstar = 1;
13098             }
13099         }
13100
13101         if (ok) {
13102             wv_sts = vms_split_path(
13103                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13104                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13105                 &wvs_spec, &wvs_len);
13106         } else {
13107             wn_spec = NULL;
13108             wn_len = 0;
13109             we_spec = NULL;
13110             we_len = 0;
13111         }
13112
13113         sts = SS$_NORMAL;
13114         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13115          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13116          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13117          int valid_find;
13118
13119             valid_find = 0;
13120             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13121                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13122             if (!$VMS_STATUS_SUCCESS(sts))
13123                 break;
13124
13125             /* with varying string, 1st word of buffer contains result length */
13126             rstr[rslt->length] = '\0';
13127
13128              /* Find where all the components are */
13129              v_sts = vms_split_path
13130                        (rstr,
13131                         &v_spec,
13132                         &v_len,
13133                         &r_spec,
13134                         &r_len,
13135                         &d_spec,
13136                         &d_len,
13137                         &n_spec,
13138                         &n_len,
13139                         &e_spec,
13140                         &e_len,
13141                         &vs_spec,
13142                         &vs_len);
13143
13144             /* If no version on input, truncate the version on output */
13145             if (!hasver && (vs_len > 0)) {
13146                 *vs_spec = '\0';
13147                 vs_len = 0;
13148             }
13149
13150             if (isunix) {
13151
13152                 /* In Unix report mode, remove the ".dir;1" from the name */
13153                 /* if it is a real directory */
13154                 if (DECC_FILENAME_UNIX_REPORT && DECC_EFS_CHARSET) {
13155                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13156                         Stat_t statbuf;
13157                         int ret_sts;
13158
13159                         ret_sts = flex_lstat(rstr, &statbuf);
13160                         if ((ret_sts == 0) &&
13161                             S_ISDIR(statbuf.st_mode)) {
13162                             e_len = 0;
13163                             e_spec[0] = 0;
13164                         }
13165                     }
13166                 }
13167
13168                 /* No version & a null extension on UNIX handling */
13169                 if ((e_len == 1) && DECC_READDIR_DROPDOTNOTYPE) {
13170                     e_len = 0;
13171                     *e_spec = '\0';
13172                 }
13173             }
13174
13175             if (!DECC_EFS_CASE_PRESERVE) {
13176                 for (cp = rstr; *cp; cp++) *cp = toLOWER_L1(*cp);
13177             }
13178
13179             /* Find File treats a Null extension as return all extensions */
13180             /* This is contrary to Perl expectations */
13181
13182             if (wildstar || wildquery || vms_old_glob) {
13183                 /* really need to see if the returned file name matched */
13184                 /* but for now will assume that it matches */
13185                 valid_find = 1;
13186             } else {
13187                 /* Exact Match requested */
13188                 /* How are directories handled? - like a file */
13189                 if ((e_len == we_len) && (n_len == wn_len)) {
13190                     int t1;
13191                     t1 = e_len;
13192                     if (t1 > 0)
13193                         t1 = strncmp(e_spec, we_spec, e_len);
13194                     if (t1 == 0) {
13195                        t1 = n_len;
13196                        if (t1 > 0)
13197                            t1 = strncmp(n_spec, we_spec, n_len);
13198                        if (t1 == 0)
13199                            valid_find = 1;
13200                     }
13201                 }
13202             }
13203
13204             if (valid_find) {
13205                 found++;
13206
13207                 if (hasdir) {
13208                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13209                     begin = rstr;
13210                 }
13211                 else {
13212                     /* Start with the name */
13213                     begin = n_spec;
13214                 }
13215                 strcat(begin,"\n");
13216                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13217             }
13218         }
13219         if (cxt) (void)lib$find_file_end(&cxt);
13220
13221         if (!found) {
13222             /* Be POSIXish: return the input pattern when no matches */
13223             my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
13224             strcat(rstr,"\n");
13225             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13226         }
13227
13228         if (ok && sts != RMS$_NMF &&
13229             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13230         if (!ok) {
13231             if (!(sts & 1)) {
13232                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13233             }
13234             PerlIO_close(tmpfp);
13235             fp = NULL;
13236         }
13237         else {
13238             PerlIO_rewind(tmpfp);
13239             IoTYPE(io) = IoTYPE_RDONLY;
13240             IoIFP(io) = fp = tmpfp;
13241             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13242         }
13243     }
13244     Safefree(vmsspec);
13245     Safefree(rslt);
13246     return fp;
13247 }
13248
13249
13250 static char *
13251 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13252                    int *utf8_fl);
13253
13254 void
13255 unixrealpath_fromperl(pTHX_ CV *cv)
13256 {
13257     dXSARGS;
13258     char *fspec, *rslt_spec, *rslt;
13259     STRLEN n_a;
13260
13261     if (!items || items != 1)
13262         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13263
13264     fspec = SvPV(ST(0),n_a);
13265     if (!fspec || !*fspec) XSRETURN_UNDEF;
13266
13267     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13268     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13269
13270     ST(0) = sv_newmortal();
13271     if (rslt != NULL)
13272         sv_usepvn(ST(0),rslt,strlen(rslt));
13273     else
13274         Safefree(rslt_spec);
13275         XSRETURN(1);
13276 }
13277
13278 static char *
13279 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13280                    int *utf8_fl);
13281
13282 void
13283 vmsrealpath_fromperl(pTHX_ CV *cv)
13284 {
13285     dXSARGS;
13286     char *fspec, *rslt_spec, *rslt;
13287     STRLEN n_a;
13288
13289     if (!items || items != 1)
13290         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13291
13292     fspec = SvPV(ST(0),n_a);
13293     if (!fspec || !*fspec) XSRETURN_UNDEF;
13294
13295     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13296     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13297
13298     ST(0) = sv_newmortal();
13299     if (rslt != NULL)
13300         sv_usepvn(ST(0),rslt,strlen(rslt));
13301     else
13302         Safefree(rslt_spec);
13303         XSRETURN(1);
13304 }
13305
13306 #ifdef HAS_SYMLINK
13307 /*
13308  * A thin wrapper around decc$symlink to make sure we follow the
13309  * standard and do not create a symlink with a zero-length name,
13310  * and convert the target to Unix format, as the CRTL can't handle
13311  * targets in VMS format.
13312  */
13313 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13314 int
13315 Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13316 {
13317     int sts;
13318     char * utarget;
13319
13320     if (!link_name || !*link_name) {
13321       SETERRNO(ENOENT, SS$_NOSUCHFILE);
13322       return -1;
13323     }
13324
13325     utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
13326     /* An untranslatable filename should be passed through. */
13327     (void) int_tounixspec(contents, utarget, NULL);
13328     sts = symlink(utarget, link_name);
13329     PerlMem_free(utarget);
13330     return sts;
13331 }
13332 /*}}}*/
13333
13334 #endif /* HAS_SYMLINK */
13335
13336 int do_vms_case_tolerant(void);
13337
13338 void
13339 case_tolerant_process_fromperl(pTHX_ CV *cv)
13340 {
13341   dXSARGS;
13342   ST(0) = boolSV(do_vms_case_tolerant());
13343   XSRETURN(1);
13344 }
13345
13346 #ifdef USE_ITHREADS
13347
13348 void
13349 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13350                           struct interp_intern *dst)
13351 {
13352     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13353
13354     memcpy(dst,src,sizeof(struct interp_intern));
13355 }
13356
13357 #endif
13358
13359 void
13360 Perl_sys_intern_clear(pTHX)
13361 {
13362 }
13363
13364 void
13365 Perl_sys_intern_init(pTHX)
13366 {
13367     unsigned int ix = RAND_MAX;
13368     double x;
13369
13370     VMSISH_HUSHED = 0;
13371
13372     MY_POSIX_EXIT = vms_posix_exit;
13373
13374     x = (float)ix;
13375     MY_INV_RAND_MAX = 1./x;
13376 }
13377
13378 void
13379 init_os_extras(void)
13380 {
13381   dTHX;
13382   char* file = __FILE__;
13383   if (DECC_DISABLE_TO_VMS_LOGNAME_TRANSLATION) {
13384     no_translate_barewords = TRUE;
13385   } else {
13386     no_translate_barewords = FALSE;
13387   }
13388
13389   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13390   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13391   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13392   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13393   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13394   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13395   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13396   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13397   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13398   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13399   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13400   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13401   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13402   newXSproto("VMS::Filespec::case_tolerant_process",
13403       case_tolerant_process_fromperl,file,"");
13404
13405   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13406
13407   return;
13408 }
13409
13410 #if __CRTL_VER == 80200000
13411 /* This missed getting in to the DECC SDK for 8.2 */
13412 char *realpath(const char *file_name, char * resolved_name, ...);
13413 #endif
13414
13415 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13416 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13417  * The perl fallback routine to provide realpath() is not as efficient
13418  * on OpenVMS.
13419  */
13420
13421 #ifdef __cplusplus
13422 extern "C" {
13423 #endif
13424
13425 /* Hack, use old stat() as fastest way of getting ino_t and device */
13426 int decc$stat(const char *name, void * statbuf);
13427 #if __CRTL_VER >= 80200000
13428 int decc$lstat(const char *name, void * statbuf);
13429 #else
13430 #define decc$lstat decc$stat
13431 #endif
13432
13433 #ifdef __cplusplus
13434 }
13435 #endif
13436
13437
13438 /* Realpath is fragile.  In 8.3 it does not work if the feature
13439  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13440  * links are implemented in RMS, not the CRTL. It also can fail if the
13441  * user does not have read/execute access to some of the directories.
13442  * So in order for Do What I Mean mode to work, if realpath() fails,
13443  * fall back to looking up the filename by the device name and FID.
13444  */
13445
13446 int vms_fid_to_name(char * outname, int outlen,
13447                     const char * name, int lstat_flag, mode_t * mode)
13448 {
13449 #pragma message save
13450 #pragma message disable MISALGNDSTRCT
13451 #pragma message disable MISALGNDMEM
13452 #pragma member_alignment save
13453 #pragma nomember_alignment
13454     struct statbuf_t {
13455         char       * st_dev;
13456         unsigned short st_ino[3];
13457         unsigned short old_st_mode;
13458         unsigned long  padl[30];  /* plenty of room */
13459     } statbuf;
13460 #pragma message restore
13461 #pragma member_alignment restore
13462
13463     int sts;
13464     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13465     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13466     char *fileified;
13467     char *temp_fspec;
13468     char *ret_spec;
13469
13470     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13471      * unexpected answers
13472      */
13473
13474     fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
13475     if (fileified == NULL)
13476         _ckvmssts_noperl(SS$_INSFMEM);
13477
13478     temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
13479     if (temp_fspec == NULL)
13480         _ckvmssts_noperl(SS$_INSFMEM);
13481
13482     sts = -1;
13483     /* First need to try as a directory */
13484     ret_spec = int_tovmspath(name, temp_fspec, NULL);
13485     if (ret_spec != NULL) {
13486         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13487         if (ret_spec != NULL) {
13488             if (lstat_flag == 0)
13489                 sts = decc$stat(fileified, &statbuf);
13490             else
13491                 sts = decc$lstat(fileified, &statbuf);
13492         }
13493     }
13494
13495     /* Then as a VMS file spec */
13496     if (sts != 0) {
13497         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13498         if (ret_spec != NULL) {
13499             if (lstat_flag == 0) {
13500                 sts = decc$stat(temp_fspec, &statbuf);
13501             } else {
13502                 sts = decc$lstat(temp_fspec, &statbuf);
13503             }
13504         }
13505     }
13506
13507     if (sts) {
13508         /* Next try - allow multiple dots with out EFS CHARSET */
13509         /* The CRTL stat() falls down hard on multi-dot filenames in unix
13510          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13511          * enable it if it isn't already.
13512          */
13513         if (!DECC_EFS_CHARSET && (efs_charset_index > 0))
13514             decc$feature_set_value(efs_charset_index, 1, 1);
13515         ret_spec = int_tovmspath(name, temp_fspec, NULL);
13516         if (lstat_flag == 0) {
13517             sts = decc$stat(name, &statbuf);
13518         } else {
13519             sts = decc$lstat(name, &statbuf);
13520         }
13521         if (!DECC_EFS_CHARSET && (efs_charset_index > 0))
13522             decc$feature_set_value(efs_charset_index, 1, 0);
13523     }
13524
13525
13526     /* and then because the Perl Unix to VMS conversion is not perfect */
13527     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13528     /* characters from filenames so we need to try it as-is */
13529     if (sts) {
13530         if (lstat_flag == 0) {
13531             sts = decc$stat(name, &statbuf);
13532         } else {
13533             sts = decc$lstat(name, &statbuf);
13534         }
13535     }
13536
13537     if (sts == 0) {
13538         int vms_sts;
13539
13540         dvidsc.dsc$a_pointer=statbuf.st_dev;
13541         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13542
13543         specdsc.dsc$a_pointer = outname;
13544         specdsc.dsc$w_length = outlen-1;
13545
13546         vms_sts = lib$fid_to_name
13547             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13548         if ($VMS_STATUS_SUCCESS(vms_sts)) {
13549             outname[specdsc.dsc$w_length] = 0;
13550
13551             /* Return the mode */
13552             if (mode) {
13553                 *mode = statbuf.old_st_mode;
13554             }
13555         }
13556     }
13557     PerlMem_free(temp_fspec);
13558     PerlMem_free(fileified);
13559     return sts;
13560 }
13561
13562
13563
13564 static char *
13565 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13566                    int *utf8_fl)
13567 {
13568     char * rslt = NULL;
13569
13570 #ifdef HAS_SYMLINK
13571     if (DECC_POSIX_COMPLIANT_PATHNAMES) {
13572         /* realpath currently only works if posix compliant pathnames are
13573          * enabled.  It may start working when they are not, but in that
13574          * case we still want the fallback behavior for backwards compatibility
13575          */
13576         rslt = realpath(filespec, outbuf);
13577     }
13578 #endif
13579
13580     if (rslt == NULL) {
13581         char * vms_spec;
13582         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13583         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13584         mode_t my_mode;
13585
13586         /* Fall back to fid_to_name */
13587
13588         Newx(vms_spec, VMS_MAXRSS + 1, char);
13589
13590         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
13591         if (sts == 0) {
13592
13593
13594             /* Now need to trim the version off */
13595             sts = vms_split_path
13596                   (vms_spec,
13597                    &v_spec,
13598                    &v_len,
13599                    &r_spec,
13600                    &r_len,
13601                    &d_spec,
13602                    &d_len,
13603                    &n_spec,
13604                    &n_len,
13605                    &e_spec,
13606                    &e_len,
13607                    &vs_spec,
13608                    &vs_len);
13609
13610
13611                 if (sts == 0) {
13612                     int haslower = 0;
13613                     const char *cp;
13614
13615                     /* Trim off the version */
13616                     int file_len = v_len + r_len + d_len + n_len + e_len;
13617                     vms_spec[file_len] = 0;
13618
13619                     /* Trim off the .DIR if this is a directory */
13620                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13621                         if (S_ISDIR(my_mode)) {
13622                             e_len = 0;
13623                             e_spec[0] = 0;
13624                         }
13625                     }
13626
13627                     /* Drop NULL extensions on UNIX file specification */
13628                     if ((e_len == 1) && DECC_READDIR_DROPDOTNOTYPE) {
13629                         e_len = 0;
13630                         e_spec[0] = '\0';
13631                     }
13632
13633                     /* The result is expected to be in UNIX format */
13634                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
13635
13636                     /* Downcase if input had any lower case letters and
13637                      * case preservation is not in effect.
13638                      */
13639                     if (!DECC_EFS_CASE_PRESERVE) {
13640                         for (cp = filespec; *cp; cp++)
13641                             if (islower(*cp)) { haslower = 1; break; }
13642
13643                         if (haslower) __mystrtolower(rslt);
13644                     }
13645                 }
13646         } else {
13647
13648             /* Now for some hacks to deal with backwards and forward */
13649             /* compatibility */
13650             if (!DECC_EFS_CHARSET) {
13651
13652                 /* 1. ODS-2 mode wants to do a syntax only translation */
13653                 rslt = int_rmsexpand(filespec, outbuf,
13654                                     NULL, 0, NULL, utf8_fl);
13655
13656             } else {
13657                 if (DECC_FILENAME_UNIX_REPORT) {
13658                     char * dir_name;
13659                     char * vms_dir_name;
13660                     char * file_name;
13661
13662                     /* 2. ODS-5 / UNIX report mode should return a failure */
13663                     /*    if the parent directory also does not exist */
13664                     /*    Otherwise, get the real path for the parent */
13665                     /*    and add the child to it. */
13666
13667                     /* basename / dirname only available for VMS 7.0+ */
13668                     /* So we may need to implement them as common routines */
13669
13670                     Newx(dir_name, VMS_MAXRSS + 1, char);
13671                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13672                     dir_name[0] = '\0';
13673                     file_name = NULL;
13674
13675                     /* First try a VMS parse */
13676                     sts = vms_split_path
13677                           (filespec,
13678                            &v_spec,
13679                            &v_len,
13680                            &r_spec,
13681                            &r_len,
13682                            &d_spec,
13683                            &d_len,
13684                            &n_spec,
13685                            &n_len,
13686                            &e_spec,
13687                            &e_len,
13688                            &vs_spec,
13689                            &vs_len);
13690
13691                     if (sts == 0) {
13692                         /* This is VMS */
13693
13694                         int dir_len = v_len + r_len + d_len + n_len;
13695                         if (dir_len > 0) {
13696                            memcpy(dir_name, filespec, dir_len);
13697                            dir_name[dir_len] = '\0';
13698                            file_name = (char *)&filespec[dir_len + 1];
13699                         }
13700                     } else {
13701                         /* This must be UNIX */
13702                         char * tchar;
13703
13704                         tchar = strrchr(filespec, '/');
13705
13706                         if (tchar != NULL) {
13707                             int dir_len = tchar - filespec;
13708                             memcpy(dir_name, filespec, dir_len);
13709                             dir_name[dir_len] = '\0';
13710                             file_name = (char *) &filespec[dir_len + 1];
13711                         }
13712                     }
13713
13714                     /* Dir name is defaulted */
13715                     if (dir_name[0] == 0) {
13716                         dir_name[0] = '.';
13717                         dir_name[1] = '\0';
13718                     }
13719
13720                     /* Need realpath for the directory */
13721                     sts = vms_fid_to_name(vms_dir_name,
13722                                           VMS_MAXRSS + 1,
13723                                           dir_name, 0, NULL);
13724
13725                     if (sts == 0) {
13726                         /* Now need to pathify it. */
13727                         char *tdir = int_pathify_dirspec(vms_dir_name,
13728                                                          outbuf);
13729
13730                         /* And now add the original filespec to it */
13731                         if (file_name != NULL) {
13732                             my_strlcat(outbuf, file_name, VMS_MAXRSS);
13733                         }
13734                         return outbuf;
13735                     }
13736                     Safefree(vms_dir_name);
13737                     Safefree(dir_name);
13738                 }
13739             }
13740         }
13741         Safefree(vms_spec);
13742     }
13743     return rslt;
13744 }
13745
13746 static char *
13747 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13748                    int *utf8_fl)
13749 {
13750     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13751     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13752
13753     /* Fall back to fid_to_name */
13754
13755     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
13756     if (sts != 0) {
13757         return NULL;
13758     }
13759     else {
13760
13761
13762         /* Now need to trim the version off */
13763         sts = vms_split_path
13764                   (outbuf,
13765                    &v_spec,
13766                    &v_len,
13767                    &r_spec,
13768                    &r_len,
13769                    &d_spec,
13770                    &d_len,
13771                    &n_spec,
13772                    &n_len,
13773                    &e_spec,
13774                    &e_len,
13775                    &vs_spec,
13776                    &vs_len);
13777
13778
13779         if (sts == 0) {
13780             int haslower = 0;
13781             const char *cp;
13782
13783             /* Trim off the version */
13784             int file_len = v_len + r_len + d_len + n_len + e_len;
13785             outbuf[file_len] = 0;
13786
13787             /* Downcase if input had any lower case letters and
13788              * case preservation is not in effect.
13789              */
13790             if (!DECC_EFS_CASE_PRESERVE) {
13791                 for (cp = filespec; *cp; cp++)
13792                     if (islower(*cp)) { haslower = 1; break; }
13793
13794                 if (haslower) __mystrtolower(outbuf);
13795             }
13796         }
13797     }
13798     return outbuf;
13799 }
13800
13801
13802 /*}}}*/
13803 /* External entry points */
13804 char *
13805 Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13806 {
13807     return do_vms_realpath(filespec, outbuf, utf8_fl);
13808 }
13809
13810 char *
13811 Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13812 {
13813     return do_vms_realname(filespec, outbuf, utf8_fl);
13814 }
13815
13816 /* case_tolerant */
13817
13818 /*{{{int do_vms_case_tolerant(void)*/
13819 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13820  * controlled by a process setting.
13821  */
13822 int
13823 do_vms_case_tolerant(void)
13824 {
13825     return vms_process_case_tolerant;
13826 }
13827 /*}}}*/
13828 /* External entry points */
13829 int
13830 Perl_vms_case_tolerant(void)
13831 {
13832     return do_vms_case_tolerant();
13833 }
13834
13835  /* Start of DECC RTL Feature handling */
13836
13837 static int
13838 set_feature_default(const char *name, int value)
13839 {
13840     int status;
13841     int index;
13842     char val_str[10];
13843
13844     /* If the feature has been explicitly disabled in the environment,
13845      * then don't enable it here.
13846      */
13847     if (value > 0) {
13848         status = simple_trnlnm(name, val_str, sizeof(val_str));
13849         if (status) {
13850             val_str[0] = toUPPER_A(val_str[0]);
13851             if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
13852                 return 0;
13853         }
13854     }
13855
13856     index = decc$feature_get_index(name);
13857
13858     status = decc$feature_set_value(index, 1, value);
13859     if (index == -1 || (status == -1)) {
13860       return -1;
13861     }
13862
13863     status = decc$feature_get_value(index, 1);
13864     if (status != value) {
13865       return -1;
13866     }
13867
13868     /* Various things may check for an environment setting
13869      * rather than the feature directly, so set that too.
13870      */
13871     vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13872
13873     return 0;
13874 }
13875
13876
13877 /* C RTL Feature settings */
13878
13879 #if defined(__DECC) || defined(__DECCXX)
13880
13881 #ifdef __cplusplus
13882 extern "C" {
13883 #endif
13884
13885 extern void
13886 vmsperl_set_features(void)
13887 {
13888     int status, initial;
13889     int s;
13890     char val_str[LNM$C_NAMLENGTH+1];
13891 #if defined(JPI$_CASE_LOOKUP_PERM)
13892     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13893     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13894     unsigned long case_perm;
13895     unsigned long case_image;
13896 #endif
13897
13898     /* Allow an exception to bring Perl into the VMS debugger */
13899     vms_debug_on_exception = 0;
13900     status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13901     if (status) {
13902        val_str[0] = toUPPER_A(val_str[0]);
13903        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13904          vms_debug_on_exception = 1;
13905        else
13906          vms_debug_on_exception = 0;
13907     }
13908
13909     /* Debug unix/vms file translation routines */
13910     vms_debug_fileify = 0;
13911     status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
13912     if (status) {
13913         val_str[0] = toUPPER_A(val_str[0]);
13914         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13915             vms_debug_fileify = 1;
13916         else
13917             vms_debug_fileify = 0;
13918     }
13919
13920
13921     /* Historically PERL has been doing vmsify / stat differently than */
13922     /* the CRTL.  In particular, under some conditions the CRTL will   */
13923     /* remove some illegal characters like spaces from filenames       */
13924     /* resulting in some differences.  The stat()/lstat() wrapper has  */
13925     /* been reporting such file names as invalid and fails to stat them */
13926     /* fixing this bug so that stat()/lstat() accept these like the     */
13927     /* CRTL does will result in several tests failing.                  */
13928     /* This should really be fixed, but for now, set up a feature to    */
13929     /* enable it so that the impact can be studied.                     */
13930     vms_bug_stat_filename = 0;
13931     status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
13932     if (status) {
13933         val_str[0] = toUPPER_A(val_str[0]);
13934         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13935             vms_bug_stat_filename = 1;
13936         else
13937             vms_bug_stat_filename = 0;
13938     }
13939
13940
13941     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13942     vms_vtf7_filenames = 0;
13943     status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13944     if (status) {
13945        val_str[0] = toUPPER_A(val_str[0]);
13946        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13947          vms_vtf7_filenames = 1;
13948        else
13949          vms_vtf7_filenames = 0;
13950     }
13951
13952     /* unlink all versions on unlink() or rename() */
13953     vms_unlink_all_versions = 0;
13954     status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13955     if (status) {
13956        val_str[0] = toUPPER_A(val_str[0]);
13957        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13958          vms_unlink_all_versions = 1;
13959        else
13960          vms_unlink_all_versions = 0;
13961     }
13962
13963     /* The path separator in PERL5LIB is '|' unless running under a Unix shell. */
13964     PL_perllib_sep = '|';
13965
13966     /* Detect running under GNV Bash or other UNIX like shell */
13967     gnv_unix_shell = 0;
13968     status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13969     if (status) {
13970          gnv_unix_shell = 1;
13971          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13972          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13973          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13974          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13975          vms_unlink_all_versions = 1;
13976          vms_posix_exit = 1;
13977          /* Reverse default ordering of PERL_ENV_TABLES. */
13978          defenv[0] = &crtlenvdsc;
13979          defenv[1] = &fildevdsc;
13980          PL_perllib_sep = ':';
13981     }
13982     /* Some reasonable defaults that are not CRTL defaults */
13983     set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13984     set_feature_default("DECC$ARGV_PARSE_STYLE", 1);     /* Requires extended parse. */
13985     set_feature_default("DECC$EFS_CHARSET", 1);
13986
13987    /* If POSIX root doesn't exist or nothing has set it explicitly, we disable it,
13988     * which confusingly means enabling the feature.  For some reason only the default
13989     * -- not current -- value can be set, so we cannot use the confusingly-named
13990     * set_feature_default function, which sets the current value.
13991     */
13992     s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13993     disable_posix_root_index = s;
13994
13995     status = simple_trnlnm("SYS$POSIX_ROOT", val_str, LNM$C_NAMLENGTH);
13996     initial = decc$feature_get_value(disable_posix_root_index, __FEATURE_MODE_INIT_STATE);
13997     if (!status || !initial) {
13998         decc$feature_set_value(disable_posix_root_index, 0, 1);
13999     }
14000
14001     /* hacks to see if known bugs are still present for testing */
14002
14003     /* PCP mode requires creating /dev/null special device file */
14004     decc_bug_devnull = 0;
14005     status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14006     if (status) {
14007        val_str[0] = toUPPER_A(val_str[0]);
14008        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14009           decc_bug_devnull = 1;
14010        else
14011           decc_bug_devnull = 0;
14012     }
14013
14014     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14015     disable_to_vms_logname_translation_index = s;
14016
14017     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14018     efs_case_preserve_index = s;
14019
14020     s = decc$feature_get_index("DECC$EFS_CHARSET");
14021     efs_charset_index = s;
14022
14023     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14024     filename_unix_report_index = s;
14025
14026     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14027     filename_unix_only_index = s;
14028
14029     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14030     filename_unix_no_version_index = s;
14031
14032     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14033     readdir_dropdotnotype_index = s;
14034
14035 #if __CRTL_VER >= 80200000
14036     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14037     posix_compliant_pathnames_index = s;
14038 #endif
14039
14040 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND)
14041
14042      /* Report true case tolerance */
14043     /*----------------------------*/
14044     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14045     if (!$VMS_STATUS_SUCCESS(status))
14046         case_perm = PPROP$K_CASE_BLIND;
14047     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14048     if (!$VMS_STATUS_SUCCESS(status))
14049         case_image = PPROP$K_CASE_BLIND;
14050     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14051         (case_image == PPROP$K_CASE_SENSITIVE))
14052         vms_process_case_tolerant = 0;
14053
14054 #endif
14055
14056     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14057     /* for strict backward compatibility */
14058     status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14059     if (status) {
14060        val_str[0] = toUPPER_A(val_str[0]);
14061        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14062          vms_posix_exit = 1;
14063        else
14064          vms_posix_exit = 0;
14065     }
14066 }
14067
14068 /* Use 32-bit pointers because that's what the image activator
14069  * assumes for the LIB$INITIALZE psect.
14070  */
14071 #if __INITIAL_POINTER_SIZE
14072 #pragma pointer_size save
14073 #pragma pointer_size 32
14074 #endif
14075
14076 /* Create a reference to the LIB$INITIALIZE function. */
14077 extern void LIB$INITIALIZE(void);
14078 extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14079
14080 /* Create an array of pointers to the init functions in the special
14081  * LIB$INITIALIZE section. In our case, the array only has one entry.
14082  */
14083 #pragma extern_model save
14084 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
14085 extern void (* const vmsperl_unused_global_2[])() =
14086 {
14087    vmsperl_set_features,
14088 };
14089 #pragma extern_model restore
14090
14091 #if __INITIAL_POINTER_SIZE
14092 #pragma pointer_size restore
14093 #endif
14094
14095 #ifdef __cplusplus
14096 }
14097 #endif
14098
14099 #endif /* defined(__DECC) || defined(__DECCXX) */
14100 /*  End of vms.c */