vms/vms.c

   1 /*    vms.c
   2  *
   3  *    VMS-specific routines for perl5
   4  *
   5  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
   6  *    2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
   7  *
   8  *    You may distribute under the terms of either the GNU General Public
   9  *    License or the Artistic License, as specified in the README file.
  10  *
  11  *    Please see Changes*.* or the Perl Repository Browser for revision history.
  12  */
  13
  14 /*
  15  *   Yet small as was their hunted band
  16  *   still fell and fearless was each hand,
  17  *   and strong deeds they wrought yet oft,
  18  *   and loved the woods, whose ways more soft
  19  *   them seemed than thralls of that black throne
  20  *   to live and languish in halls of stone.
  21  *        "The Lay of Leithian", Canto II, lines 135-40
  22  *
  23  *     [p.162 of _The Lays of Beleriand_]
  24  */
  25
  26 #include <acedef.h>
  27 #include <acldef.h>
  28 #include <armdef.h>
  29 #include <atrdef.h>
  30 #include <chpdef.h>
  31 #include <clidef.h>
  32 #include <climsgdef.h>
  33 #include <dcdef.h>
  34 #include <descrip.h>
  35 #include <devdef.h>
  36 #include <dvidef.h>
  37 #include <fibdef.h>
  38 #include <float.h>
  39 #include <fscndef.h>
  40 #include <iodef.h>
  41 #include <jpidef.h>
  42 #include <kgbdef.h>
  43 #include <libclidef.h>
  44 #include <libdef.h>
  45 #include <lib$routines.h>
  46 #include <lnmdef.h>
  47 #include <msgdef.h>
  48 #include <ossdef.h>
  49 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  50 #include <ppropdef.h>
  51 #endif
  52 #include <prvdef.h>
  53 #include <psldef.h>
  54 #include <rms.h>
  55 #include <shrdef.h>
  56 #include <ssdef.h>
  57 #include <starlet.h>
  58 #include <strdef.h>
  59 #include <str$routines.h>
  60 #include <syidef.h>
  61 #include <uaidef.h>
  62 #include <uicdef.h>
  63 #include <stsdef.h>
  64 #include <rmsdef.h>
  65 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  66 #include <efndef.h>
  67 #define NO_EFN EFN$C_ENF
  68 #else
  69 #define NO_EFN 0;
  70 #endif
  71
  72 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  73 int   decc$feature_get_index(const char *name);
  74 char* decc$feature_get_name(int index);
  75 int   decc$feature_get_value(int index, int mode);
  76 int   decc$feature_set_value(int index, int mode, int value);
  77 #else
  78 #include <unixlib.h>
  79 #endif
  80
  81 #pragma member_alignment save
  82 #pragma nomember_alignment longword
  83 struct item_list_3 {
  84         unsigned short len;
  85         unsigned short code;
  86         void * bufadr;
  87         unsigned short * retadr;
  88 };
  89 #pragma member_alignment restore
  90
  91 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  92
  93 static int set_feature_default(const char *name, int value)
  94 {
  95     int status;
  96     int index;
  97
  98     index = decc$feature_get_index(name);
  99
 100     status = decc$feature_set_value(index, 1, value);
 101     if (index == -1 || (status == -1)) {
 102       return -1;
 103     }
 104
 105     status = decc$feature_get_value(index, 1);
 106     if (status != value) {
 107       return -1;
 108     }
 109
 110 return 0;
 111 }
 112 #endif
 113
 114 /* Older versions of ssdef.h don't have these */
 115 #ifndef SS$_INVFILFOROP
 116 #  define SS$_INVFILFOROP 3930
 117 #endif
 118 #ifndef SS$_NOSUCHOBJECT
 119 #  define SS$_NOSUCHOBJECT 2696
 120 #endif
 121
 122 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 123 #define PERLIO_NOT_STDIO 0
 124
 125 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 126  * code below needs to get to the underlying CRTL routines. */
 127 #define DONT_MASK_RTL_CALLS
 128 #include "EXTERN.h"
 129 #include "perl.h"
 130 #include "XSUB.h"
 131 /* Anticipating future expansion in lexical warnings . . . */
 132 #ifndef WARN_INTERNAL
 133 #  define WARN_INTERNAL WARN_MISC
 134 #endif
 135
 136 #ifdef VMS_LONGNAME_SUPPORT
 137 #include <libfildef.h>
 138 #endif
 139
 140 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 141 #  define RTL_USES_UTC 1
 142 #endif
 143
 144 #if !defined(__VAX) && __CRTL_VER >= 80200000
 145 #ifdef lstat
 146 #undef lstat
 147 #endif
 148 #else
 149 #ifdef lstat
 150 #undef lstat
 151 #endif
 152 #define lstat(_x, _y) stat(_x, _y)
 153 #endif
 154
 155 /* Routine to create a decterm for use with the Perl debugger */
 156 /* No headers, this information was found in the Programming Concepts Manual */
 157
 158 static int (*decw_term_port)
 159    (const struct dsc$descriptor_s * display,
 160     const struct dsc$descriptor_s * setup_file,
 161     const struct dsc$descriptor_s * customization,
 162     struct dsc$descriptor_s * result_device_name,
 163     unsigned short * result_device_name_length,
 164     void * controller,
 165     void * char_buffer,
 166     void * char_change_buffer) = 0;
 167
 168 /* gcc's header files don't #define direct access macros
 169  * corresponding to VAXC's variant structs */
 170 #ifdef __GNUC__
 171 #  define uic$v_format uic$r_uic_form.uic$v_format
 172 #  define uic$v_group uic$r_uic_form.uic$v_group
 173 #  define uic$v_member uic$r_uic_form.uic$v_member
 174 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 175 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 176 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 177 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 178 #endif
 179
 180 #if defined(NEED_AN_H_ERRNO)
 181 dEXT int h_errno;
 182 #endif
 183
 184 #ifdef __DECC
 185 #pragma message disable pragma
 186 #pragma member_alignment save
 187 #pragma nomember_alignment longword
 188 #pragma message save
 189 #pragma message disable misalgndmem
 190 #endif
 191 struct itmlst_3 {
 192   unsigned short int buflen;
 193   unsigned short int itmcode;
 194   void *bufadr;
 195   unsigned short int *retlen;
 196 };
 197
 198 struct filescan_itmlst_2 {
 199     unsigned short length;
 200     unsigned short itmcode;
 201     char * component;
 202 };
 203
 204 struct vs_str_st {
 205     unsigned short length;
 206     char str[65536];
 207 };
 208
 209 #ifdef __DECC
 210 #pragma message restore
 211 #pragma member_alignment restore
 212 #endif
 213
 214 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 215 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 216 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 217 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 218 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 219 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 220 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 221 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 222 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 223 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 224 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 225 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 226
 227 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 228 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 229 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 230 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 231
 232 static char *  int_rmsexpand_vms(
 233     const char * filespec, char * outbuf, unsigned opts);
 234 static char * int_rmsexpand_tovms(
 235     const char * filespec, char * outbuf, unsigned opts);
 236 static char *int_tovmsspec
 237    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 238 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 239 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 240 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 241
 242 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 243 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 244
 245 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 246  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 247  * the Perl facility.
 248  */
 249 #define PERL_LNM_MAX_ITER 10
 250
 251   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 252 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 253 #define MAX_DCL_SYMBOL          (8192)
 254 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 255 #else
 256 #define MAX_DCL_SYMBOL          (1024)
 257 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 258 #endif
 259
 260 static char *__mystrtolower(char *str)
 261 {
 262   if (str) for (; *str; ++str) *str= tolower(*str);
 263   return str;
 264 }
 265
 266 static struct dsc$descriptor_s fildevdsc =
 267   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 268 static struct dsc$descriptor_s crtlenvdsc =
 269   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 270 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 271 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 272 static struct dsc$descriptor_s **env_tables = defenv;
 273 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 274
 275 /* True if we shouldn't treat barewords as logicals during directory */
 276 /* munching */
 277 static int no_translate_barewords;
 278
 279 #ifndef RTL_USES_UTC
 280 static int tz_updated = 1;
 281 #endif
 282
 283 /* DECC Features that may need to affect how Perl interprets
 284  * displays filename information
 285  */
 286 static int decc_disable_to_vms_logname_translation = 1;
 287 static int decc_disable_posix_root = 1;
 288 int decc_efs_case_preserve = 0;
 289 static int decc_efs_charset = 0;
 290 static int decc_efs_charset_index = -1;
 291 static int decc_filename_unix_no_version = 0;
 292 static int decc_filename_unix_only = 0;
 293 int decc_filename_unix_report = 0;
 294 int decc_posix_compliant_pathnames = 0;
 295 int decc_readdir_dropdotnotype = 0;
 296 static int vms_process_case_tolerant = 1;
 297 int vms_vtf7_filenames = 0;
 298 int gnv_unix_shell = 0;
 299 static int vms_unlink_all_versions = 0;
 300 static int vms_posix_exit = 0;
 301
 302 /* bug workarounds if needed */
 303 int decc_bug_devnull = 1;
 304 int decc_dir_barename = 0;
 305 int vms_bug_stat_filename = 0;
 306
 307 static int vms_debug_on_exception = 0;
 308 static int vms_debug_fileify = 0;
 309
 310 /* Simple logical name translation */
 311 static int simple_trnlnm
 312    (const char * logname,
 313     char * value,
 314     int value_len)
 315 {
 316     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 317     const unsigned long attr = LNM$M_CASE_BLIND;
 318     struct dsc$descriptor_s name_dsc;
 319     int status;
 320     unsigned short result;
 321     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 322                                 {0, 0, 0, 0}};
 323
 324     name_dsc.dsc$w_length = strlen(logname);
 325     name_dsc.dsc$a_pointer = (char *)logname;
 326     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 327     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 328
 329     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 330
 331     if ($VMS_STATUS_SUCCESS(status)) {
 332
 333          /* Null terminate and return the string */
 334         /*--------------------------------------*/
 335         value[result] = 0;
 336         return result;
 337     }
 338
 339     return 0;
 340 }
 341
 342
 343 /* Is this a UNIX file specification?
 344  *   No longer a simple check with EFS file specs
 345  *   For now, not a full check, but need to
 346  *   handle POSIX ^UP^ specifications
 347  *   Fixing to handle ^/ cases would require
 348  *   changes to many other conversion routines.
 349  */
 350
 351 static int is_unix_filespec(const char *path)
 352 {
 353 int ret_val;
 354 const char * pch1;
 355
 356     ret_val = 0;
 357     if (strncmp(path,"\"^UP^",5) != 0) {
 358         pch1 = strchr(path, '/');
 359         if (pch1 != NULL)
 360             ret_val = 1;
 361         else {
 362
 363             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 364             if (decc_filename_unix_report || decc_filename_unix_only) {
 365             if (strcmp(path,".") == 0)
 366                 ret_val = 1;
 367             }
 368         }
 369     }
 370     return ret_val;
 371 }
 372
 373 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 374  */
 375
 376 static void ucs2_to_vtf7
 377    (char *outspec,
 378     unsigned long ucs2_char,
 379     int * output_cnt)
 380 {
 381 unsigned char * ucs_ptr;
 382 int hex;
 383
 384     ucs_ptr = (unsigned char *)&ucs2_char;
 385
 386     outspec[0] = '^';
 387     outspec[1] = 'U';
 388     hex = (ucs_ptr[1] >> 4) & 0xf;
 389     if (hex < 0xA)
 390         outspec[2] = hex + '0';
 391     else
 392         outspec[2] = (hex - 9) + 'A';
 393     hex = ucs_ptr[1] & 0xF;
 394     if (hex < 0xA)
 395         outspec[3] = hex + '0';
 396     else {
 397         outspec[3] = (hex - 9) + 'A';
 398     }
 399     hex = (ucs_ptr[0] >> 4) & 0xf;
 400     if (hex < 0xA)
 401         outspec[4] = hex + '0';
 402     else
 403         outspec[4] = (hex - 9) + 'A';
 404     hex = ucs_ptr[1] & 0xF;
 405     if (hex < 0xA)
 406         outspec[5] = hex + '0';
 407     else {
 408         outspec[5] = (hex - 9) + 'A';
 409     }
 410     *output_cnt = 6;
 411 }
 412
 413
 414 /* This handles the conversion of a UNIX extended character set to a ^
 415  * escaped VMS character.
 416  * in a UNIX file specification.
 417  *
 418  * The output count variable contains the number of characters added
 419  * to the output string.
 420  *
 421  * The return value is the number of characters read from the input string
 422  */
 423 static int copy_expand_unix_filename_escape
 424   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 425 {
 426 int count;
 427 int utf8_flag;
 428
 429     utf8_flag = 0;
 430     if (utf8_fl)
 431       utf8_flag = *utf8_fl;
 432
 433     count = 0;
 434     *output_cnt = 0;
 435     if (*inspec >= 0x80) {
 436         if (utf8_fl && vms_vtf7_filenames) {
 437         unsigned long ucs_char;
 438
 439             ucs_char = 0;
 440
 441             if ((*inspec & 0xE0) == 0xC0) {
 442                 /* 2 byte Unicode */
 443                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 444                 if (ucs_char >= 0x80) {
 445                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 446                     return 2;
 447                 }
 448             } else if ((*inspec & 0xF0) == 0xE0) {
 449                 /* 3 byte Unicode */
 450                 ucs_char = ((inspec[0] & 0xF) << 12) +
 451                    ((inspec[1] & 0x3f) << 6) +
 452                    (inspec[2] & 0x3f);
 453                 if (ucs_char >= 0x800) {
 454                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 455                     return 3;
 456                 }
 457
 458 #if 0 /* I do not see longer sequences supported by OpenVMS */
 459       /* Maybe some one can fix this later */
 460             } else if ((*inspec & 0xF8) == 0xF0) {
 461                 /* 4 byte Unicode */
 462                 /* UCS-4 to UCS-2 */
 463             } else if ((*inspec & 0xFC) == 0xF8) {
 464                 /* 5 byte Unicode */
 465                 /* UCS-4 to UCS-2 */
 466             } else if ((*inspec & 0xFE) == 0xFC) {
 467                 /* 6 byte Unicode */
 468                 /* UCS-4 to UCS-2 */
 469 #endif
 470             }
 471         }
 472
 473         /* High bit set, but not a Unicode character! */
 474
 475         /* Non printing DECMCS or ISO Latin-1 character? */
 476         if (*inspec <= 0x9F) {
 477         int hex;
 478             outspec[0] = '^';
 479             outspec++;
 480             hex = (*inspec >> 4) & 0xF;
 481             if (hex < 0xA)
 482                 outspec[1] = hex + '0';
 483             else {
 484                 outspec[1] = (hex - 9) + 'A';
 485             }
 486             hex = *inspec & 0xF;
 487             if (hex < 0xA)
 488                 outspec[2] = hex + '0';
 489             else {
 490                 outspec[2] = (hex - 9) + 'A';
 491             }
 492             *output_cnt = 3;
 493             return 1;
 494         } else if (*inspec == 0xA0) {
 495             outspec[0] = '^';
 496             outspec[1] = 'A';
 497             outspec[2] = '0';
 498             *output_cnt = 3;
 499             return 1;
 500         } else if (*inspec == 0xFF) {
 501             outspec[0] = '^';
 502             outspec[1] = 'F';
 503             outspec[2] = 'F';
 504             *output_cnt = 3;
 505             return 1;
 506         }
 507         *outspec = *inspec;
 508         *output_cnt = 1;
 509         return 1;
 510     }
 511
 512     /* Is this a macro that needs to be passed through?
 513      * Macros start with $( and an alpha character, followed
 514      * by a string of alpha numeric characters ending with a )
 515      * If this does not match, then encode it as ODS-5.
 516      */
 517     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 518     int tcnt;
 519
 520         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 521             tcnt = 3;
 522             outspec[0] = inspec[0];
 523             outspec[1] = inspec[1];
 524             outspec[2] = inspec[2];
 525
 526             while(isalnum(inspec[tcnt]) ||
 527                   (inspec[2] == '.') || (inspec[2] == '_')) {
 528                 outspec[tcnt] = inspec[tcnt];
 529                 tcnt++;
 530             }
 531             if (inspec[tcnt] == ')') {
 532                 outspec[tcnt] = inspec[tcnt];
 533                 tcnt++;
 534                 *output_cnt = tcnt;
 535                 return tcnt;
 536             }
 537         }
 538     }
 539
 540     switch (*inspec) {
 541     case 0x7f:
 542         outspec[0] = '^';
 543         outspec[1] = '7';
 544         outspec[2] = 'F';
 545         *output_cnt = 3;
 546         return 1;
 547         break;
 548     case '?':
 549         if (decc_efs_charset == 0)
 550           outspec[0] = '%';
 551         else
 552           outspec[0] = '?';
 553         *output_cnt = 1;
 554         return 1;
 555         break;
 556     case '.':
 557     case '~':
 558     case '!':
 559     case '#':
 560     case '&':
 561     case '\'':
 562     case '`':
 563     case '(':
 564     case ')':
 565     case '+':
 566     case '@':
 567     case '{':
 568     case '}':
 569     case ',':
 570     case ';':
 571     case '[':
 572     case ']':
 573     case '%':
 574     case '^':
 575     case '\\':
 576         /* Don't escape again if following character is
 577          * already something we escape.
 578          */
 579         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 580             *outspec = *inspec;
 581             *output_cnt = 1;
 582             return 1;
 583             break;
 584         }
 585         /* But otherwise fall through and escape it. */
 586     case '=':
 587         /* Assume that this is to be escaped */
 588         outspec[0] = '^';
 589         outspec[1] = *inspec;
 590         *output_cnt = 2;
 591         return 1;
 592         break;
 593     case ' ': /* space */
 594         /* Assume that this is to be escaped */
 595         outspec[0] = '^';
 596         outspec[1] = '_';
 597         *output_cnt = 2;
 598         return 1;
 599         break;
 600     default:
 601         *outspec = *inspec;
 602         *output_cnt = 1;
 603         return 1;
 604         break;
 605     }
 606 }
 607
 608
 609 /* This handles the expansion of a '^' prefix to the proper character
 610  * in a UNIX file specification.
 611  *
 612  * The output count variable contains the number of characters added
 613  * to the output string.
 614  *
 615  * The return value is the number of characters read from the input
 616  * string
 617  */
 618 static int copy_expand_vms_filename_escape
 619   (char *outspec, const char *inspec, int *output_cnt)
 620 {
 621 int count;
 622 int scnt;
 623
 624     count = 0;
 625     *output_cnt = 0;
 626     if (*inspec == '^') {
 627         inspec++;
 628         switch (*inspec) {
 629         /* Spaces and non-trailing dots should just be passed through,
 630          * but eat the escape character.
 631          */
 632         case '.':
 633             *outspec = *inspec;
 634             count += 2;
 635             (*output_cnt)++;
 636             break;
 637         case '_': /* space */
 638             *outspec = ' ';
 639             count += 2;
 640             (*output_cnt)++;
 641             break;
 642         case '^':
 643             /* Hmm.  Better leave the escape escaped. */
 644             outspec[0] = '^';
 645             outspec[1] = '^';
 646             count += 2;
 647             (*output_cnt) += 2;
 648             break;
 649         case 'U': /* Unicode - FIX-ME this is wrong. */
 650             inspec++;
 651             count++;
 652             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 653             if (scnt == 4) {
 654                 unsigned int c1, c2;
 655                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 656                 outspec[0] = c1 & 0xff;
 657                 outspec[1] = c2 & 0xff;
 658                 if (scnt > 1) {
 659                     (*output_cnt) += 2;
 660                     count += 4;
 661                 }
 662             }
 663             else {
 664                 /* Error - do best we can to continue */
 665                 *outspec = 'U';
 666                 outspec++;
 667                 (*output_cnt++);
 668                 *outspec = *inspec;
 669                 count++;
 670                 (*output_cnt++);
 671             }
 672             break;
 673         default:
 674             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 675             if (scnt == 2) {
 676                 /* Hex encoded */
 677                 unsigned int c1;
 678                 scnt = sscanf(inspec, "%2x", &c1);
 679                 outspec[0] = c1 & 0xff;
 680                 if (scnt > 0) {
 681                     (*output_cnt++);
 682                     count += 2;
 683                 }
 684             }
 685             else {
 686                 *outspec = *inspec;
 687                 count++;
 688                 (*output_cnt++);
 689             }
 690         }
 691     }
 692     else {
 693         *outspec = *inspec;
 694         count++;
 695         (*output_cnt)++;
 696     }
 697     return count;
 698 }
 699
 700 /* vms_split_path - Verify that the input file specification is a
 701  * VMS format file specification, and provide pointers to the components of
 702  * it.  With EFS format filenames, this is virtually the only way to
 703  * parse a VMS path specification into components.
 704  *
 705  * If the sum of the components do not add up to the length of the
 706  * string, then the passed file specification is probably a UNIX style
 707  * path.
 708  */
 709 static int vms_split_path
 710    (const char * path,
 711     char * * volume,
 712     int * vol_len,
 713     char * * root,
 714     int * root_len,
 715     char * * dir,
 716     int * dir_len,
 717     char * * name,
 718     int * name_len,
 719     char * * ext,
 720     int * ext_len,
 721     char * * version,
 722     int * ver_len)
 723 {
 724 struct dsc$descriptor path_desc;
 725 int status;
 726 unsigned long flags;
 727 int ret_stat;
 728 struct filescan_itmlst_2 item_list[9];
 729 const int filespec = 0;
 730 const int nodespec = 1;
 731 const int devspec = 2;
 732 const int rootspec = 3;
 733 const int dirspec = 4;
 734 const int namespec = 5;
 735 const int typespec = 6;
 736 const int verspec = 7;
 737
 738     /* Assume the worst for an easy exit */
 739     ret_stat = -1;
 740     *volume = NULL;
 741     *vol_len = 0;
 742     *root = NULL;
 743     *root_len = 0;
 744     *dir = NULL;
 745     *name = NULL;
 746     *name_len = 0;
 747     *ext = NULL;
 748     *ext_len = 0;
 749     *version = NULL;
 750     *ver_len = 0;
 751
 752     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 753     path_desc.dsc$w_length = strlen(path);
 754     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 755     path_desc.dsc$b_class = DSC$K_CLASS_S;
 756
 757     /* Get the total length, if it is shorter than the string passed
 758      * then this was probably not a VMS formatted file specification
 759      */
 760     item_list[filespec].itmcode = FSCN$_FILESPEC;
 761     item_list[filespec].length = 0;
 762     item_list[filespec].component = NULL;
 763
 764     /* If the node is present, then it gets considered as part of the
 765      * volume name to hopefully make things simple.
 766      */
 767     item_list[nodespec].itmcode = FSCN$_NODE;
 768     item_list[nodespec].length = 0;
 769     item_list[nodespec].component = NULL;
 770
 771     item_list[devspec].itmcode = FSCN$_DEVICE;
 772     item_list[devspec].length = 0;
 773     item_list[devspec].component = NULL;
 774
 775     /* root is a special case,  adding it to either the directory or
 776      * the device components will probably complicate things for the
 777      * callers of this routine, so leave it separate.
 778      */
 779     item_list[rootspec].itmcode = FSCN$_ROOT;
 780     item_list[rootspec].length = 0;
 781     item_list[rootspec].component = NULL;
 782
 783     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 784     item_list[dirspec].length = 0;
 785     item_list[dirspec].component = NULL;
 786
 787     item_list[namespec].itmcode = FSCN$_NAME;
 788     item_list[namespec].length = 0;
 789     item_list[namespec].component = NULL;
 790
 791     item_list[typespec].itmcode = FSCN$_TYPE;
 792     item_list[typespec].length = 0;
 793     item_list[typespec].component = NULL;
 794
 795     item_list[verspec].itmcode = FSCN$_VERSION;
 796     item_list[verspec].length = 0;
 797     item_list[verspec].component = NULL;
 798
 799     item_list[8].itmcode = 0;
 800     item_list[8].length = 0;
 801     item_list[8].component = NULL;
 802
 803     status = sys$filescan
 804        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 805         &flags, NULL, NULL);
 806     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 807
 808     /* If we parsed it successfully these two lengths should be the same */
 809     if (path_desc.dsc$w_length != item_list[filespec].length)
 810         return ret_stat;
 811
 812     /* If we got here, then it is a VMS file specification */
 813     ret_stat = 0;
 814
 815     /* set the volume name */
 816     if (item_list[nodespec].length > 0) {
 817         *volume = item_list[nodespec].component;
 818         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 819     }
 820     else {
 821         *volume = item_list[devspec].component;
 822         *vol_len = item_list[devspec].length;
 823     }
 824
 825     *root = item_list[rootspec].component;
 826     *root_len = item_list[rootspec].length;
 827
 828     *dir = item_list[dirspec].component;
 829     *dir_len = item_list[dirspec].length;
 830
 831     /* Now fun with versions and EFS file specifications
 832      * The parser can not tell the difference when a "." is a version
 833      * delimiter or a part of the file specification.
 834      */
 835     if ((decc_efs_charset) &&
 836         (item_list[verspec].length > 0) &&
 837         (item_list[verspec].component[0] == '.')) {
 838         *name = item_list[namespec].component;
 839         *name_len = item_list[namespec].length + item_list[typespec].length;
 840         *ext = item_list[verspec].component;
 841         *ext_len = item_list[verspec].length;
 842         *version = NULL;
 843         *ver_len = 0;
 844     }
 845     else {
 846         *name = item_list[namespec].component;
 847         *name_len = item_list[namespec].length;
 848         *ext = item_list[typespec].component;
 849         *ext_len = item_list[typespec].length;
 850         *version = item_list[verspec].component;
 851         *ver_len = item_list[verspec].length;
 852     }
 853     return ret_stat;
 854 }
 855
 856 /* Routine to determine if the file specification ends with .dir */
 857 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 858
 859     /* e_len must be 4, and version must be <= 2 characters */
 860     if (e_len != 4 || vs_len > 2)
 861         return 0;
 862
 863     /* If a version number is present, it needs to be one */
 864     if ((vs_len == 2) && (vs_spec[1] != '1'))
 865         return 0;
 866
 867     /* Look for the DIR on the extension */
 868     if (vms_process_case_tolerant) {
 869         if ((toupper(e_spec[1]) == 'D') &&
 870             (toupper(e_spec[2]) == 'I') &&
 871             (toupper(e_spec[3]) == 'R')) {
 872             return 1;
 873         }
 874     } else {
 875         /* Directory extensions are supposed to be in upper case only */
 876         /* I would not be surprised if this rule can not be enforced */
 877         /* if and when someone fully debugs the case sensitive mode */
 878         if ((e_spec[1] == 'D') &&
 879             (e_spec[2] == 'I') &&
 880             (e_spec[3] == 'R')) {
 881             return 1;
 882         }
 883     }
 884     return 0;
 885 }
 886
 887
 888 /* my_maxidx
 889  * Routine to retrieve the maximum equivalence index for an input
 890  * logical name.  Some calls to this routine have no knowledge if
 891  * the variable is a logical or not.  So on error we return a max
 892  * index of zero.
 893  */
 894 /*{{{int my_maxidx(const char *lnm) */
 895 static int
 896 my_maxidx(const char *lnm)
 897 {
 898     int status;
 899     int midx;
 900     int attr = LNM$M_CASE_BLIND;
 901     struct dsc$descriptor lnmdsc;
 902     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 903                                 {0, 0, 0, 0}};
 904
 905     lnmdsc.dsc$w_length = strlen(lnm);
 906     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 907     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 908     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 909
 910     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 911     if ((status & 1) == 0)
 912        midx = 0;
 913
 914     return (midx);
 915 }
 916 /*}}}*/
 917
 918 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 919 int
 920 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 921   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 922 {
 923     const char *cp1;
 924     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 925     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 926     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 927     int midx;
 928     unsigned char acmode;
 929     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 930                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 931     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 932                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 933                                  {0, 0, 0, 0}};
 934     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 935 #if defined(PERL_IMPLICIT_CONTEXT)
 936     pTHX = NULL;
 937     if (PL_curinterp) {
 938       aTHX = PERL_GET_INTERP;
 939     } else {
 940       aTHX = NULL;
 941     }
 942 #endif
 943
 944     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 945       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 946     }
 947     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 948       *cp2 = _toupper(*cp1);
 949       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 950         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 951         return 0;
 952       }
 953     }
 954     lnmdsc.dsc$w_length = cp1 - lnm;
 955     lnmdsc.dsc$a_pointer = uplnm;
 956     uplnm[lnmdsc.dsc$w_length] = '\0';
 957     secure = flags & PERL__TRNENV_SECURE;
 958     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 959     if (!tabvec || !*tabvec) tabvec = env_tables;
 960
 961     for (curtab = 0; tabvec[curtab]; curtab++) {
 962       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 963         if (!ivenv && !secure) {
 964           char *eq;
 965           int i;
 966           if (!environ) {
 967             ivenv = 1;
 968 #if defined(PERL_IMPLICIT_CONTEXT)
 969             if (aTHX == NULL) {
 970                 fprintf(stderr,
 971                     "Can't read CRTL environ\n");
 972             } else
 973 #endif
 974                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
 975             continue;
 976           }
 977           retsts = SS$_NOLOGNAM;
 978           for (i = 0; environ[i]; i++) {
 979             if ((eq = strchr(environ[i],'=')) &&
 980                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 981                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 982               eq++;
 983               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 984               if (!eqvlen) continue;
 985               retsts = SS$_NORMAL;
 986               break;
 987             }
 988           }
 989           if (retsts != SS$_NOLOGNAM) break;
 990         }
 991       }
 992       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 993                !str$case_blind_compare(&tmpdsc,&clisym)) {
 994         if (!ivsym && !secure) {
 995           unsigned short int deflen = LNM$C_NAMLENGTH;
 996           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 997           /* dynamic dsc to accommodate possible long value */
 998           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
 999           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1000           if (retsts & 1) {
1001             if (eqvlen > MAX_DCL_SYMBOL) {
1002               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1003               eqvlen = MAX_DCL_SYMBOL;
1004               /* Special hack--we might be called before the interpreter's */
1005               /* fully initialized, in which case either thr or PL_curcop */
1006               /* might be bogus. We have to check, since ckWARN needs them */
1007               /* both to be valid if running threaded */
1008 #if defined(PERL_IMPLICIT_CONTEXT)
1009               if (aTHX == NULL) {
1010                   fprintf(stderr,
1011                      "Value of CLI symbol \"%s\" too long",lnm);
1012               } else
1013 #endif
1014                 if (ckWARN(WARN_MISC)) {
1015                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1016                 }
1017             }
1018             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1019           }
1020           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1021           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1022           if (retsts == LIB$_NOSUCHSYM) continue;
1023           break;
1024         }
1025       }
1026       else if (!ivlnm) {
1027         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1028           midx = my_maxidx(lnm);
1029           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1030             lnmlst[1].bufadr = cp2;
1031             eqvlen = 0;
1032             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1033             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1034             if (retsts == SS$_NOLOGNAM) break;
1035             /* PPFs have a prefix */
1036             if (
1037 #if INTSIZE == 4
1038                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1039 #endif
1040                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1041                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1042                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1043                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1044                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1045               memmove(eqv,eqv+4,eqvlen-4);
1046               eqvlen -= 4;
1047             }
1048             cp2 += eqvlen;
1049             *cp2 = '\0';
1050           }
1051           if ((retsts == SS$_IVLOGNAM) ||
1052               (retsts == SS$_NOLOGNAM)) { continue; }
1053         }
1054         else {
1055           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1056           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1057           if (retsts == SS$_NOLOGNAM) continue;
1058           eqv[eqvlen] = '\0';
1059         }
1060         eqvlen = strlen(eqv);
1061         break;
1062       }
1063     }
1064     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1065     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1066              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1067              retsts == SS$_NOLOGNAM) {
1068       set_errno(EINVAL);  set_vaxc_errno(retsts);
1069     }
1070     else _ckvmssts_noperl(retsts);
1071     return 0;
1072 }  /* end of vmstrnenv */
1073 /*}}}*/
1074
1075 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1076 /* Define as a function so we can access statics. */
1077 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1078 {
1079     int flags = 0;
1080
1081 #if defined(PERL_IMPLICIT_CONTEXT)
1082     if (aTHX != NULL)
1083 #endif
1084 #ifdef SECURE_INTERNAL_GETENV
1085         flags = (PL_curinterp ? PL_tainting : will_taint) ?
1086                  PERL__TRNENV_SECURE : 0;
1087 #endif
1088
1089     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1090 }
1091 /*}}}*/
1092
1093 /* my_getenv
1094  * Note: Uses Perl temp to store result so char * can be returned to
1095  * caller; this pointer will be invalidated at next Perl statement
1096  * transition.
1097  * We define this as a function rather than a macro in terms of my_getenv_len()
1098  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1099  * allocate SVs).
1100  */
1101 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1102 char *
1103 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1104 {
1105     const char *cp1;
1106     static char *__my_getenv_eqv = NULL;
1107     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1108     unsigned long int idx = 0;
1109     int success, secure, saverr, savvmserr;
1110     int midx, flags;
1111     SV *tmpsv;
1112
1113     midx = my_maxidx(lnm) + 1;
1114
1115     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1116       /* Set up a temporary buffer for the return value; Perl will
1117        * clean it up at the next statement transition */
1118       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1119       if (!tmpsv) return NULL;
1120       eqv = SvPVX(tmpsv);
1121     }
1122     else {
1123       /* Assume no interpreter ==> single thread */
1124       if (__my_getenv_eqv != NULL) {
1125         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1126       }
1127       else {
1128         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1129       }
1130       eqv = __my_getenv_eqv;
1131     }
1132
1133     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1134     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1135       int len;
1136       getcwd(eqv,LNM$C_NAMLENGTH);
1137
1138       len = strlen(eqv);
1139
1140       /* Get rid of "000000/ in rooted filespecs */
1141       if (len > 7) {
1142         char * zeros;
1143         zeros = strstr(eqv, "/000000/");
1144         if (zeros != NULL) {
1145           int mlen;
1146           mlen = len - (zeros - eqv) - 7;
1147           memmove(zeros, &zeros[7], mlen);
1148           len = len - 7;
1149           eqv[len] = '\0';
1150         }
1151       }
1152       return eqv;
1153     }
1154     else {
1155       /* Impose security constraints only if tainting */
1156       if (sys) {
1157         /* Impose security constraints only if tainting */
1158         secure = PL_curinterp ? PL_tainting : will_taint;
1159         saverr = errno;  savvmserr = vaxc$errno;
1160       }
1161       else {
1162         secure = 0;
1163       }
1164
1165       flags =
1166 #ifdef SECURE_INTERNAL_GETENV
1167               secure ? PERL__TRNENV_SECURE : 0
1168 #else
1169               0
1170 #endif
1171       ;
1172
1173       /* For the getenv interface we combine all the equivalence names
1174        * of a search list logical into one value to acquire a maximum
1175        * value length of 255*128 (assuming %ENV is using logicals).
1176        */
1177       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1178
1179       /* If the name contains a semicolon-delimited index, parse it
1180        * off and make sure we only retrieve the equivalence name for
1181        * that index.  */
1182       if ((cp2 = strchr(lnm,';')) != NULL) {
1183         strcpy(uplnm,lnm);
1184         uplnm[cp2-lnm] = '\0';
1185         idx = strtoul(cp2+1,NULL,0);
1186         lnm = uplnm;
1187         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1188       }
1189
1190       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1191
1192       /* Discard NOLOGNAM on internal calls since we're often looking
1193        * for an optional name, and this "error" often shows up as the
1194        * (bogus) exit status for a die() call later on.  */
1195       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1196       return success ? eqv : NULL;
1197     }
1198
1199 }  /* end of my_getenv() */
1200 /*}}}*/
1201
1202
1203 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1204 char *
1205 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1206 {
1207     const char *cp1;
1208     char *buf, *cp2;
1209     unsigned long idx = 0;
1210     int midx, flags;
1211     static char *__my_getenv_len_eqv = NULL;
1212     int secure, saverr, savvmserr;
1213     SV *tmpsv;
1214
1215     midx = my_maxidx(lnm) + 1;
1216
1217     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1218       /* Set up a temporary buffer for the return value; Perl will
1219        * clean it up at the next statement transition */
1220       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1221       if (!tmpsv) return NULL;
1222       buf = SvPVX(tmpsv);
1223     }
1224     else {
1225       /* Assume no interpreter ==> single thread */
1226       if (__my_getenv_len_eqv != NULL) {
1227         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1228       }
1229       else {
1230         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1231       }
1232       buf = __my_getenv_len_eqv;
1233     }
1234
1235     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1236     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1237     char * zeros;
1238
1239       getcwd(buf,LNM$C_NAMLENGTH);
1240       *len = strlen(buf);
1241
1242       /* Get rid of "000000/ in rooted filespecs */
1243       if (*len > 7) {
1244       zeros = strstr(buf, "/000000/");
1245       if (zeros != NULL) {
1246         int mlen;
1247         mlen = *len - (zeros - buf) - 7;
1248         memmove(zeros, &zeros[7], mlen);
1249         *len = *len - 7;
1250         buf[*len] = '\0';
1251         }
1252       }
1253       return buf;
1254     }
1255     else {
1256       if (sys) {
1257         /* Impose security constraints only if tainting */
1258         secure = PL_curinterp ? PL_tainting : will_taint;
1259         saverr = errno;  savvmserr = vaxc$errno;
1260       }
1261       else {
1262         secure = 0;
1263       }
1264
1265       flags =
1266 #ifdef SECURE_INTERNAL_GETENV
1267               secure ? PERL__TRNENV_SECURE : 0
1268 #else
1269               0
1270 #endif
1271       ;
1272
1273       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1274
1275       if ((cp2 = strchr(lnm,';')) != NULL) {
1276         strcpy(buf,lnm);
1277         buf[cp2-lnm] = '\0';
1278         idx = strtoul(cp2+1,NULL,0);
1279         lnm = buf;
1280         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1281       }
1282
1283       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1284
1285       /* Get rid of "000000/ in rooted filespecs */
1286       if (*len > 7) {
1287       char * zeros;
1288         zeros = strstr(buf, "/000000/");
1289         if (zeros != NULL) {
1290           int mlen;
1291           mlen = *len - (zeros - buf) - 7;
1292           memmove(zeros, &zeros[7], mlen);
1293           *len = *len - 7;
1294           buf[*len] = '\0';
1295         }
1296       }
1297
1298       /* Discard NOLOGNAM on internal calls since we're often looking
1299        * for an optional name, and this "error" often shows up as the
1300        * (bogus) exit status for a die() call later on.  */
1301       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1302       return *len ? buf : NULL;
1303     }
1304
1305 }  /* end of my_getenv_len() */
1306 /*}}}*/
1307
1308 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1309
1310 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1311
1312 /*{{{ void prime_env_iter() */
1313 void
1314 prime_env_iter(void)
1315 /* Fill the %ENV associative array with all logical names we can
1316  * find, in preparation for iterating over it.
1317  */
1318 {
1319   static int primed = 0;
1320   HV *seenhv = NULL, *envhv;
1321   SV *sv = NULL;
1322   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1323   unsigned short int chan;
1324 #ifndef CLI$M_TRUSTED
1325 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1326 #endif
1327   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1328   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
1329   long int i;
1330   bool have_sym = FALSE, have_lnm = FALSE;
1331   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1332   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1333   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1334   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1335   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1336 #if defined(PERL_IMPLICIT_CONTEXT)
1337   pTHX;
1338 #endif
1339 #if defined(USE_ITHREADS)
1340   static perl_mutex primenv_mutex;
1341   MUTEX_INIT(&primenv_mutex);
1342 #endif
1343
1344 #if defined(PERL_IMPLICIT_CONTEXT)
1345     /* We jump through these hoops because we can be called at */
1346     /* platform-specific initialization time, which is before anything is */
1347     /* set up--we can't even do a plain dTHX since that relies on the */
1348     /* interpreter structure to be initialized */
1349     if (PL_curinterp) {
1350       aTHX = PERL_GET_INTERP;
1351     } else {
1352       /* we never get here because the NULL pointer will cause the */
1353       /* several of the routines called by this routine to access violate */
1354
1355       /* This routine is only called by hv.c/hv_iterinit which has a */
1356       /* context, so the real fix may be to pass it through instead of */
1357       /* the hoops above */
1358       aTHX = NULL;
1359     }
1360 #endif
1361
1362   if (primed || !PL_envgv) return;
1363   MUTEX_LOCK(&primenv_mutex);
1364   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1365   envhv = GvHVn(PL_envgv);
1366   /* Perform a dummy fetch as an lval to insure that the hash table is
1367    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1368   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1369
1370   for (i = 0; env_tables[i]; i++) {
1371      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1372          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1373      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1374   }
1375   if (have_sym || have_lnm) {
1376     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1377     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1378     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1379     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1380   }
1381
1382   for (i--; i >= 0; i--) {
1383     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1384       char *start;
1385       int j;
1386       for (j = 0; environ[j]; j++) {
1387         if (!(start = strchr(environ[j],'='))) {
1388           if (ckWARN(WARN_INTERNAL))
1389             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1390         }
1391         else {
1392           start++;
1393           sv = newSVpv(start,0);
1394           SvTAINTED_on(sv);
1395           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1396         }
1397       }
1398       continue;
1399     }
1400     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1401              !str$case_blind_compare(&tmpdsc,&clisym)) {
1402       strcpy(cmd,"Show Symbol/Global *");
1403       cmddsc.dsc$w_length = 20;
1404       if (env_tables[i]->dsc$w_length == 12 &&
1405           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1406           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1407       flags = defflags | CLI$M_NOLOGNAM;
1408     }
1409     else {
1410       strcpy(cmd,"Show Logical *");
1411       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1412         strcat(cmd," /Table=");
1413         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1414         cmddsc.dsc$w_length = strlen(cmd);
1415       }
1416       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1417       flags = defflags | CLI$M_NOCLISYM;
1418     }
1419
1420     /* Create a new subprocess to execute each command, to exclude the
1421      * remote possibility that someone could subvert a mbx or file used
1422      * to write multiple commands to a single subprocess.
1423      */
1424     do {
1425       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1426                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1427       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1428       defflags &= ~CLI$M_TRUSTED;
1429     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1430     _ckvmssts(retsts);
1431     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1432     if (seenhv) SvREFCNT_dec(seenhv);
1433     seenhv = newHV();
1434     while (1) {
1435       char *cp1, *cp2, *key;
1436       unsigned long int sts, iosb[2], retlen, keylen;
1437       register U32 hash;
1438
1439       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1440       if (sts & 1) sts = iosb[0] & 0xffff;
1441       if (sts == SS$_ENDOFFILE) {
1442         int wakect = 0;
1443         while (substs == 0) { sys$hiber(); wakect++;}
1444         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1445         _ckvmssts(substs);
1446         break;
1447       }
1448       _ckvmssts(sts);
1449       retlen = iosb[0] >> 16;
1450       if (!retlen) continue;  /* blank line */
1451       buf[retlen] = '\0';
1452       if (iosb[1] != subpid) {
1453         if (iosb[1]) {
1454           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1455         }
1456         continue;
1457       }
1458       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1459         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1460
1461       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1462       if (*cp1 == '(' || /* Logical name table name */
1463           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1464       if (*cp1 == '"') cp1++;
1465       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1466       key = cp1;  keylen = cp2 - cp1;
1467       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1468       while (*cp2 && *cp2 != '=') cp2++;
1469       while (*cp2 && *cp2 == '=') cp2++;
1470       while (*cp2 && *cp2 == ' ') cp2++;
1471       if (*cp2 == '"') {  /* String translation; may embed "" */
1472         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1473         cp2++;  cp1--; /* Skip "" surrounding translation */
1474       }
1475       else {  /* Numeric translation */
1476         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1477         cp1--;  /* stop on last non-space char */
1478       }
1479       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1480         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1481         continue;
1482       }
1483       PERL_HASH(hash,key,keylen);
1484
1485       if (cp1 == cp2 && *cp2 == '.') {
1486         /* A single dot usually means an unprintable character, such as a null
1487          * to indicate a zero-length value.  Get the actual value to make sure.
1488          */
1489         char lnm[LNM$C_NAMLENGTH+1];
1490         char eqv[MAX_DCL_SYMBOL+1];
1491         int trnlen;
1492         strncpy(lnm, key, keylen);
1493         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1494         sv = newSVpvn(eqv, strlen(eqv));
1495       }
1496       else {
1497         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1498       }
1499
1500       SvTAINTED_on(sv);
1501       hv_store(envhv,key,keylen,sv,hash);
1502       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1503     }
1504     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1505       /* get the PPFs for this process, not the subprocess */
1506       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1507       char eqv[LNM$C_NAMLENGTH+1];
1508       int trnlen, i;
1509       for (i = 0; ppfs[i]; i++) {
1510         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1511         sv = newSVpv(eqv,trnlen);
1512         SvTAINTED_on(sv);
1513         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1514       }
1515     }
1516   }
1517   primed = 1;
1518   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1519   if (buf) Safefree(buf);
1520   if (seenhv) SvREFCNT_dec(seenhv);
1521   MUTEX_UNLOCK(&primenv_mutex);
1522   return;
1523
1524 }  /* end of prime_env_iter */
1525 /*}}}*/
1526
1527
1528 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1529 /* Define or delete an element in the same "environment" as
1530  * vmstrnenv().  If an element is to be deleted, it's removed from
1531  * the first place it's found.  If it's to be set, it's set in the
1532  * place designated by the first element of the table vector.
1533  * Like setenv() returns 0 for success, non-zero on error.
1534  */
1535 int
1536 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1537 {
1538     const char *cp1;
1539     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1540     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1541     int nseg = 0, j;
1542     unsigned long int retsts, usermode = PSL$C_USER;
1543     struct itmlst_3 *ile, *ilist;
1544     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1545                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1546                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1547     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1548     $DESCRIPTOR(local,"_LOCAL");
1549
1550     if (!lnm) {
1551         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1552         return SS$_IVLOGNAM;
1553     }
1554
1555     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1556       *cp2 = _toupper(*cp1);
1557       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1558         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1559         return SS$_IVLOGNAM;
1560       }
1561     }
1562     lnmdsc.dsc$w_length = cp1 - lnm;
1563     if (!tabvec || !*tabvec) tabvec = env_tables;
1564
1565     if (!eqv) {  /* we're deleting n element */
1566       for (curtab = 0; tabvec[curtab]; curtab++) {
1567         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1568         int i;
1569           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1570             if ((cp1 = strchr(environ[i],'=')) &&
1571                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1572                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1573 #ifdef HAS_SETENV
1574               return setenv(lnm,"",1) ? vaxc$errno : 0;
1575             }
1576           }
1577           ivenv = 1; retsts = SS$_NOLOGNAM;
1578 #else
1579               if (ckWARN(WARN_INTERNAL))
1580                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1581               ivenv = 1; retsts = SS$_NOSUCHPGM;
1582               break;
1583             }
1584           }
1585 #endif
1586         }
1587         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1588                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1589           unsigned int symtype;
1590           if (tabvec[curtab]->dsc$w_length == 12 &&
1591               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1592               !str$case_blind_compare(&tmpdsc,&local))
1593             symtype = LIB$K_CLI_LOCAL_SYM;
1594           else symtype = LIB$K_CLI_GLOBAL_SYM;
1595           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1596           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1597           if (retsts == LIB$_NOSUCHSYM) continue;
1598           break;
1599         }
1600         else if (!ivlnm) {
1601           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1602           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1603           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1604           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1605           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1606         }
1607       }
1608     }
1609     else {  /* we're defining a value */
1610       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1611 #ifdef HAS_SETENV
1612         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1613 #else
1614         if (ckWARN(WARN_INTERNAL))
1615           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1616         retsts = SS$_NOSUCHPGM;
1617 #endif
1618       }
1619       else {
1620         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1621         eqvdsc.dsc$w_length  = strlen(eqv);
1622         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1623             !str$case_blind_compare(&tmpdsc,&clisym)) {
1624           unsigned int symtype;
1625           if (tabvec[0]->dsc$w_length == 12 &&
1626               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1627                !str$case_blind_compare(&tmpdsc,&local))
1628             symtype = LIB$K_CLI_LOCAL_SYM;
1629           else symtype = LIB$K_CLI_GLOBAL_SYM;
1630           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1631         }
1632         else {
1633           if (!*eqv) eqvdsc.dsc$w_length = 1;
1634           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1635
1636             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1637             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1638               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1639                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1640               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1641               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1642             }
1643
1644             Newx(ilist,nseg+1,struct itmlst_3);
1645             ile = ilist;
1646             if (!ile) {
1647               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1648               return SS$_INSFMEM;
1649             }
1650             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1651
1652             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1653               ile->itmcode = LNM$_STRING;
1654               ile->bufadr = c;
1655               if ((j+1) == nseg) {
1656                 ile->buflen = strlen(c);
1657                 /* in case we are truncating one that's too long */
1658                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1659               }
1660               else {
1661                 ile->buflen = LNM$C_NAMLENGTH;
1662               }
1663             }
1664
1665             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1666             Safefree (ilist);
1667           }
1668           else {
1669             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1670           }
1671         }
1672       }
1673     }
1674     if (!(retsts & 1)) {
1675       switch (retsts) {
1676         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1677         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1678           set_errno(EVMSERR); break;
1679         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1680         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1681           set_errno(EINVAL); break;
1682         case SS$_NOPRIV:
1683           set_errno(EACCES); break;
1684         default:
1685           _ckvmssts(retsts);
1686           set_errno(EVMSERR);
1687        }
1688        set_vaxc_errno(retsts);
1689        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1690     }
1691     else {
1692       /* We reset error values on success because Perl does an hv_fetch()
1693        * before each hv_store(), and if the thing we're setting didn't
1694        * previously exist, we've got a leftover error message.  (Of course,
1695        * this fails in the face of
1696        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1697        * in that the error reported in $! isn't spurious,
1698        * but it's right more often than not.)
1699        */
1700       set_errno(0); set_vaxc_errno(retsts);
1701       return 0;
1702     }
1703
1704 }  /* end of vmssetenv() */
1705 /*}}}*/
1706
1707 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1708 /* This has to be a function since there's a prototype for it in proto.h */
1709 void
1710 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1711 {
1712     if (lnm && *lnm) {
1713       int len = strlen(lnm);
1714       if  (len == 7) {
1715         char uplnm[8];
1716         int i;
1717         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1718         if (!strcmp(uplnm,"DEFAULT")) {
1719           if (eqv && *eqv) my_chdir(eqv);
1720           return;
1721         }
1722     }
1723 #ifndef RTL_USES_UTC
1724     if (len == 6 || len == 2) {
1725       char uplnm[7];
1726       int i;
1727       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1728       uplnm[len] = '\0';
1729       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1730       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1731     }
1732 #endif
1733   }
1734   (void) vmssetenv(lnm,eqv,NULL);
1735 }
1736 /*}}}*/
1737
1738 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1739 /*  vmssetuserlnm
1740  *  sets a user-mode logical in the process logical name table
1741  *  used for redirection of sys$error
1742  *
1743  *  Fix-me: The pTHX is not needed for this routine, however doio.c
1744  *          is calling it with one instead of using a macro.
1745  *          A macro needs to be added to vmsish.h and doio.c updated to use it.
1746  *
1747  */
1748 void
1749 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1750 {
1751     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1752     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1753     unsigned long int iss, attr = LNM$M_CONFINE;
1754     unsigned char acmode = PSL$C_USER;
1755     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1756                                  {0, 0, 0, 0}};
1757     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1758     d_name.dsc$w_length = strlen(name);
1759
1760     lnmlst[0].buflen = strlen(eqv);
1761     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1762
1763     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1764     if (!(iss&1)) lib$signal(iss);
1765 }
1766 /*}}}*/
1767
1768
1769 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1770 /* my_crypt - VMS password hashing
1771  * my_crypt() provides an interface compatible with the Unix crypt()
1772  * C library function, and uses sys$hash_password() to perform VMS
1773  * password hashing.  The quadword hashed password value is returned
1774  * as a NUL-terminated 8 character string.  my_crypt() does not change
1775  * the case of its string arguments; in order to match the behavior
1776  * of LOGINOUT et al., alphabetic characters in both arguments must
1777  *  be upcased by the caller.
1778  *
1779  * - fix me to call ACM services when available
1780  */
1781 char *
1782 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1783 {
1784 #   ifndef UAI$C_PREFERRED_ALGORITHM
1785 #     define UAI$C_PREFERRED_ALGORITHM 127
1786 #   endif
1787     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1788     unsigned short int salt = 0;
1789     unsigned long int sts;
1790     struct const_dsc {
1791         unsigned short int dsc$w_length;
1792         unsigned char      dsc$b_type;
1793         unsigned char      dsc$b_class;
1794         const char *       dsc$a_pointer;
1795     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1796        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1797     struct itmlst_3 uailst[3] = {
1798         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1799         { sizeof salt, UAI$_SALT,    &salt, 0},
1800         { 0,           0,            NULL,  NULL}};
1801     static char hash[9];
1802
1803     usrdsc.dsc$w_length = strlen(usrname);
1804     usrdsc.dsc$a_pointer = usrname;
1805     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1806       switch (sts) {
1807         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1808           set_errno(EACCES);
1809           break;
1810         case RMS$_RNF:
1811           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1812           break;
1813         default:
1814           set_errno(EVMSERR);
1815       }
1816       set_vaxc_errno(sts);
1817       if (sts != RMS$_RNF) return NULL;
1818     }
1819
1820     txtdsc.dsc$w_length = strlen(textpasswd);
1821     txtdsc.dsc$a_pointer = textpasswd;
1822     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1823       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1824     }
1825
1826     return (char *) hash;
1827
1828 }  /* end of my_crypt() */
1829 /*}}}*/
1830
1831
1832 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1833 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1834 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1835
1836 /* fixup barenames that are directories for internal use.
1837  * There have been problems with the consistent handling of UNIX
1838  * style directory names when routines are presented with a name that
1839  * has no directory delimiters at all.  So this routine will eventually
1840  * fix the issue.
1841  */
1842 static char * fixup_bare_dirnames(const char * name)
1843 {
1844   if (decc_disable_to_vms_logname_translation) {
1845 /* fix me */
1846   }
1847   return NULL;
1848 }
1849
1850 /* 8.3, remove() is now broken on symbolic links */
1851 static int rms_erase(const char * vmsname);
1852
1853
1854 /* mp_do_kill_file
1855  * A little hack to get around a bug in some implementation of remove()
1856  * that do not know how to delete a directory
1857  *
1858  * Delete any file to which user has control access, regardless of whether
1859  * delete access is explicitly allowed.
1860  * Limitations: User must have write access to parent directory.
1861  *              Does not block signals or ASTs; if interrupted in midstream
1862  *              may leave file with an altered ACL.
1863  * HANDLE WITH CARE!
1864  */
1865 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1866 static int
1867 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1868 {
1869     char *vmsname;
1870     char *rslt;
1871     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1872     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1873     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1874     struct myacedef {
1875       unsigned char myace$b_length;
1876       unsigned char myace$b_type;
1877       unsigned short int myace$w_flags;
1878       unsigned long int myace$l_access;
1879       unsigned long int myace$l_ident;
1880     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1881                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1882       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1883      struct itmlst_3
1884        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1885                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1886        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1887        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1888        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1889        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1890
1891     /* Expand the input spec using RMS, since the CRTL remove() and
1892      * system services won't do this by themselves, so we may miss
1893      * a file "hiding" behind a logical name or search list. */
1894     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1895     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1896
1897     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1898     if (rslt == NULL) {
1899         PerlMem_free(vmsname);
1900         return -1;
1901       }
1902
1903     /* Erase the file */
1904     rmsts = rms_erase(vmsname);
1905
1906     /* Did it succeed */
1907     if ($VMS_STATUS_SUCCESS(rmsts)) {
1908         PerlMem_free(vmsname);
1909         return 0;
1910       }
1911
1912     /* If not, can changing protections help? */
1913     if (rmsts != RMS$_PRV) {
1914       set_vaxc_errno(rmsts);
1915       PerlMem_free(vmsname);
1916       return -1;
1917     }
1918
1919     /* No, so we get our own UIC to use as a rights identifier,
1920      * and the insert an ACE at the head of the ACL which allows us
1921      * to delete the file.
1922      */
1923     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1924     fildsc.dsc$w_length = strlen(vmsname);
1925     fildsc.dsc$a_pointer = vmsname;
1926     cxt = 0;
1927     newace.myace$l_ident = oldace.myace$l_ident;
1928     rmsts = -1;
1929     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1930       switch (aclsts) {
1931         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1932           set_errno(ENOENT); break;
1933         case RMS$_DIR:
1934           set_errno(ENOTDIR); break;
1935         case RMS$_DEV:
1936           set_errno(ENODEV); break;
1937         case RMS$_SYN: case SS$_INVFILFOROP:
1938           set_errno(EINVAL); break;
1939         case RMS$_PRV:
1940           set_errno(EACCES); break;
1941         default:
1942           _ckvmssts_noperl(aclsts);
1943       }
1944       set_vaxc_errno(aclsts);
1945       PerlMem_free(vmsname);
1946       return -1;
1947     }
1948     /* Grab any existing ACEs with this identifier in case we fail */
1949     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1950     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1951                     || fndsts == SS$_NOMOREACE ) {
1952       /* Add the new ACE . . . */
1953       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1954         goto yourroom;
1955
1956       rmsts = rms_erase(vmsname);
1957       if ($VMS_STATUS_SUCCESS(rmsts)) {
1958         rmsts = 0;
1959         }
1960         else {
1961         rmsts = -1;
1962         /* We blew it - dir with files in it, no write priv for
1963          * parent directory, etc.  Put things back the way they were. */
1964         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1965           goto yourroom;
1966         if (fndsts & 1) {
1967           addlst[0].bufadr = &oldace;
1968           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1969             goto yourroom;
1970         }
1971       }
1972     }
1973
1974     yourroom:
1975     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1976     /* We just deleted it, so of course it's not there.  Some versions of
1977      * VMS seem to return success on the unlock operation anyhow (after all
1978      * the unlock is successful), but others don't.
1979      */
1980     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1981     if (aclsts & 1) aclsts = fndsts;
1982     if (!(aclsts & 1)) {
1983       set_errno(EVMSERR);
1984       set_vaxc_errno(aclsts);
1985     }
1986
1987     PerlMem_free(vmsname);
1988     return rmsts;
1989
1990 }  /* end of kill_file() */
1991 /*}}}*/
1992
1993
1994 /*{{{int do_rmdir(char *name)*/
1995 int
1996 Perl_do_rmdir(pTHX_ const char *name)
1997 {
1998     char * dirfile;
1999     int retval;
2000     Stat_t st;
2001
2002     /* lstat returns a VMS fileified specification of the name */
2003     /* that is looked up, and also lets verifies that this is a directory */
2004
2005     retval = flex_lstat(name, &st);
2006     if (retval != 0) {
2007         char * ret_spec;
2008
2009         /* Due to a historical feature, flex_stat/lstat can not see some */
2010         /* Unix format file names that the rest of the CRTL can see */
2011         /* Fixing that feature will cause some perl tests to fail */
2012         /* So try this one more time. */
2013
2014         retval = lstat(name, &st.crtl_stat);
2015         if (retval != 0)
2016             return -1;
2017
2018         /* force it to a file spec for the kill file to work. */
2019         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
2020         if (ret_spec == NULL) {
2021             errno = EIO;
2022             return -1;
2023         }
2024     }
2025
2026     if (!S_ISDIR(st.st_mode)) {
2027         errno = ENOTDIR;
2028         retval = -1;
2029     }
2030     else {
2031         dirfile = st.st_devnam;
2032
2033         /* It may be possible for flex_stat to find a file and vmsify() to */
2034         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
2035         /* with that case, so fail it */
2036         if (dirfile[0] == 0) {
2037             errno = EIO;
2038             return -1;
2039         }
2040
2041         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2042     }
2043
2044     return retval;
2045
2046 }  /* end of do_rmdir */
2047 /*}}}*/
2048
2049 /* kill_file
2050  * Delete any file to which user has control access, regardless of whether
2051  * delete access is explicitly allowed.
2052  * Limitations: User must have write access to parent directory.
2053  *              Does not block signals or ASTs; if interrupted in midstream
2054  *              may leave file with an altered ACL.
2055  * HANDLE WITH CARE!
2056  */
2057 /*{{{int kill_file(char *name)*/
2058 int
2059 Perl_kill_file(pTHX_ const char *name)
2060 {
2061     char * vmsfile;
2062     Stat_t st;
2063     int rmsts;
2064
2065     /* Convert the filename to VMS format and see if it is a directory */
2066     /* flex_lstat returns a vmsified file specification */
2067     rmsts = flex_lstat(name, &st);
2068     if (rmsts != 0) {
2069
2070         /* Due to a historical feature, flex_stat/lstat can not see some */
2071         /* Unix format file names that the rest of the CRTL can see when */
2072         /* ODS-2 file specifications are in use. */
2073         /* Fixing that feature will cause some perl tests to fail */
2074         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2075         st.st_mode = 0;
2076         vmsfile = (char *) name; /* cast ok */
2077
2078     } else {
2079         vmsfile = st.st_devnam;
2080         if (vmsfile[0] == 0) {
2081             /* It may be possible for flex_stat to find a file and vmsify() */
2082             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2083             /* deal with that case, so fail it */
2084             errno = EIO;
2085             return -1;
2086         }
2087     }
2088
2089     /* Remove() is allowed to delete directories, according to the X/Open
2090      * specifications.
2091      * This may need special handling to work with the ACL hacks.
2092      */
2093     if (S_ISDIR(st.st_mode)) {
2094         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2095         return rmsts;
2096     }
2097
2098     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2099
2100     /* Need to delete all versions ? */
2101     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2102         int i = 0;
2103
2104         /* Just use lstat() here as do not need st_dev */
2105         /* and we know that the file is in VMS format or that */
2106         /* because of a historical bug, flex_stat can not see the file */
2107         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2108             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2109             if (rmsts != 0)
2110                 break;
2111             i++;
2112
2113             /* Make sure that we do not loop forever */
2114             if (i > 32767) {
2115                 errno = EIO;
2116                 rmsts = -1;
2117                 break;
2118             }
2119         }
2120     }
2121
2122     return rmsts;
2123
2124 }  /* end of kill_file() */
2125 /*}}}*/
2126
2127
2128 /*{{{int my_mkdir(char *,Mode_t)*/
2129 int
2130 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2131 {
2132   STRLEN dirlen = strlen(dir);
2133
2134   /* zero length string sometimes gives ACCVIO */
2135   if (dirlen == 0) return -1;
2136
2137   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2138    * null file name/type.  However, it's commonplace under Unix,
2139    * so we'll allow it for a gain in portability.
2140    */
2141   if (dir[dirlen-1] == '/') {
2142     char *newdir = savepvn(dir,dirlen-1);
2143     int ret = mkdir(newdir,mode);
2144     Safefree(newdir);
2145     return ret;
2146   }
2147   else return mkdir(dir,mode);
2148 }  /* end of my_mkdir */
2149 /*}}}*/
2150
2151 /*{{{int my_chdir(char *)*/
2152 int
2153 Perl_my_chdir(pTHX_ const char *dir)
2154 {
2155   STRLEN dirlen = strlen(dir);
2156
2157   /* zero length string sometimes gives ACCVIO */
2158   if (dirlen == 0) return -1;
2159   const char *dir1;
2160
2161   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2162    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2163    * so that existing scripts do not need to be changed.
2164    */
2165   dir1 = dir;
2166   while ((dirlen > 0) && (*dir1 == ' ')) {
2167     dir1++;
2168     dirlen--;
2169   }
2170
2171   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2172    * that implies
2173    * null file name/type.  However, it's commonplace under Unix,
2174    * so we'll allow it for a gain in portability.
2175    *
2176    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2177    */
2178   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2179       char *newdir;
2180       int ret;
2181       newdir = PerlMem_malloc(dirlen);
2182       if (newdir ==NULL)
2183           _ckvmssts_noperl(SS$_INSFMEM);
2184       strncpy(newdir, dir1, dirlen-1);
2185       newdir[dirlen-1] = '\0';
2186       ret = chdir(newdir);
2187       PerlMem_free(newdir);
2188       return ret;
2189   }
2190   else return chdir(dir1);
2191 }  /* end of my_chdir */
2192 /*}}}*/
2193
2194
2195 /*{{{int my_chmod(char *, mode_t)*/
2196 int
2197 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2198 {
2199   Stat_t st;
2200   int ret = -1;
2201   char * changefile;
2202   STRLEN speclen = strlen(file_spec);
2203
2204   /* zero length string sometimes gives ACCVIO */
2205   if (speclen == 0) return -1;
2206
2207   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2208    * that implies null file name/type.  However, it's commonplace under Unix,
2209    * so we'll allow it for a gain in portability.
2210    *
2211    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2212    * in VMS file.dir notation.
2213    */
2214   changefile = (char *) file_spec; /* cast ok */
2215   ret = flex_lstat(file_spec, &st);
2216   if (ret != 0) {
2217
2218         /* Due to a historical feature, flex_stat/lstat can not see some */
2219         /* Unix format file names that the rest of the CRTL can see when */
2220         /* ODS-2 file specifications are in use. */
2221         /* Fixing that feature will cause some perl tests to fail */
2222         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2223         st.st_mode = 0;
2224
2225   } else {
2226       /* It may be possible to get here with nothing in st_devname */
2227       /* chmod still may work though */
2228       if (st.st_devnam[0] != 0) {
2229           changefile = st.st_devnam;
2230       }
2231   }
2232   ret = chmod(changefile, mode);
2233   return ret;
2234 }  /* end of my_chmod */
2235 /*}}}*/
2236
2237
2238 /*{{{FILE *my_tmpfile()*/
2239 FILE *
2240 my_tmpfile(void)
2241 {
2242   FILE *fp;
2243   char *cp;
2244
2245   if ((fp = tmpfile())) return fp;
2246
2247   cp = PerlMem_malloc(L_tmpnam+24);
2248   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2249
2250   if (decc_filename_unix_only == 0)
2251     strcpy(cp,"Sys$Scratch:");
2252   else
2253     strcpy(cp,"/tmp/");
2254   tmpnam(cp+strlen(cp));
2255   strcat(cp,".Perltmp");
2256   fp = fopen(cp,"w+","fop=dlt");
2257   PerlMem_free(cp);
2258   return fp;
2259 }
2260 /*}}}*/
2261
2262
2263 #ifndef HOMEGROWN_POSIX_SIGNALS
2264 /*
2265  * The C RTL's sigaction fails to check for invalid signal numbers so we
2266  * help it out a bit.  The docs are correct, but the actual routine doesn't
2267  * do what the docs say it will.
2268  */
2269 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2270 int
2271 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2272                    struct sigaction* oact)
2273 {
2274   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2275         SETERRNO(EINVAL, SS$_INVARG);
2276         return -1;
2277   }
2278   return sigaction(sig, act, oact);
2279 }
2280 /*}}}*/
2281 #endif
2282
2283 #ifdef KILL_BY_SIGPRC
2284 #include <errnodef.h>
2285
2286 /* We implement our own kill() using the undocumented system service
2287    sys$sigprc for one of two reasons:
2288
2289    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2290    target process to do a sys$exit, which usually can't be handled
2291    gracefully...certainly not by Perl and the %SIG{} mechanism.
2292
2293    2.) If the kill() in the CRTL can't be called from a signal
2294    handler without disappearing into the ether, i.e., the signal
2295    it purportedly sends is never trapped. Still true as of VMS 7.3.
2296
2297    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2298    in the target process rather than calling sys$exit.
2299
2300    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2301    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2302    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2303    with condition codes C$_SIG0+nsig*8, catching the exception on the
2304    target process and resignaling with appropriate arguments.
2305
2306    But we don't have that VMS 7.0+ exception handler, so if you
2307    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2308
2309    Also note that SIGTERM is listed in the docs as being "unimplemented",
2310    yet always seems to be signaled with a VMS condition code of 4 (and
2311    correctly handled for that code).  So we hardwire it in.
2312
2313    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2314    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2315    than signalling with an unrecognized (and unhandled by CRTL) code.
2316 */
2317
2318 #define _MY_SIG_MAX 28
2319
2320 static unsigned int
2321 Perl_sig_to_vmscondition_int(int sig)
2322 {
2323     static unsigned int sig_code[_MY_SIG_MAX+1] =
2324     {
2325         0,                  /*  0 ZERO     */
2326         SS$_HANGUP,         /*  1 SIGHUP   */
2327         SS$_CONTROLC,       /*  2 SIGINT   */
2328         SS$_CONTROLY,       /*  3 SIGQUIT  */
2329         SS$_RADRMOD,        /*  4 SIGILL   */
2330         SS$_BREAK,          /*  5 SIGTRAP  */
2331         SS$_OPCCUS,         /*  6 SIGABRT  */
2332         SS$_COMPAT,         /*  7 SIGEMT   */
2333 #ifdef __VAX
2334         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2335 #else
2336         SS$_HPARITH,        /*  8 SIGFPE AXP */
2337 #endif
2338         SS$_ABORT,          /*  9 SIGKILL  */
2339         SS$_ACCVIO,         /* 10 SIGBUS   */
2340         SS$_ACCVIO,         /* 11 SIGSEGV  */
2341         SS$_BADPARAM,       /* 12 SIGSYS   */
2342         SS$_NOMBX,          /* 13 SIGPIPE  */
2343         SS$_ASTFLT,         /* 14 SIGALRM  */
2344         4,                  /* 15 SIGTERM  */
2345         0,                  /* 16 SIGUSR1  */
2346         0,                  /* 17 SIGUSR2  */
2347         0,                  /* 18 */
2348         0,                  /* 19 */
2349         0,                  /* 20 SIGCHLD  */
2350         0,                  /* 21 SIGCONT  */
2351         0,                  /* 22 SIGSTOP  */
2352         0,                  /* 23 SIGTSTP  */
2353         0,                  /* 24 SIGTTIN  */
2354         0,                  /* 25 SIGTTOU  */
2355         0,                  /* 26 */
2356         0,                  /* 27 */
2357         0                   /* 28 SIGWINCH  */
2358     };
2359
2360 #if __VMS_VER >= 60200000
2361     static int initted = 0;
2362     if (!initted) {
2363         initted = 1;
2364         sig_code[16] = C$_SIGUSR1;
2365         sig_code[17] = C$_SIGUSR2;
2366 #if __CRTL_VER >= 70000000
2367         sig_code[20] = C$_SIGCHLD;
2368 #endif
2369 #if __CRTL_VER >= 70300000
2370         sig_code[28] = C$_SIGWINCH;
2371 #endif
2372     }
2373 #endif
2374
2375     if (sig < _SIG_MIN) return 0;
2376     if (sig > _MY_SIG_MAX) return 0;
2377     return sig_code[sig];
2378 }
2379
2380 unsigned int
2381 Perl_sig_to_vmscondition(int sig)
2382 {
2383 #ifdef SS$_DEBUG
2384     if (vms_debug_on_exception != 0)
2385         lib$signal(SS$_DEBUG);
2386 #endif
2387     return Perl_sig_to_vmscondition_int(sig);
2388 }
2389
2390
2391 int
2392 Perl_my_kill(int pid, int sig)
2393 {
2394     int iss;
2395     unsigned int code;
2396 #define sys$sigprc SYS$SIGPRC
2397     int sys$sigprc(unsigned int *pidadr,
2398                      struct dsc$descriptor_s *prcname,
2399                      unsigned int code);
2400
2401      /* sig 0 means validate the PID */
2402     /*------------------------------*/
2403     if (sig == 0) {
2404         const unsigned long int jpicode = JPI$_PID;
2405         pid_t ret_pid;
2406         int status;
2407         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2408         if ($VMS_STATUS_SUCCESS(status))
2409            return 0;
2410         switch (status) {
2411         case SS$_NOSUCHNODE:
2412         case SS$_UNREACHABLE:
2413         case SS$_NONEXPR:
2414            errno = ESRCH;
2415            break;
2416         case SS$_NOPRIV:
2417            errno = EPERM;
2418            break;
2419         default:
2420            errno = EVMSERR;
2421         }
2422         vaxc$errno=status;
2423         return -1;
2424     }
2425
2426     code = Perl_sig_to_vmscondition_int(sig);
2427
2428     if (!code) {
2429         SETERRNO(EINVAL, SS$_BADPARAM);
2430         return -1;
2431     }
2432
2433     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2434      * signals are to be sent to multiple processes.
2435      *  pid = 0 - all processes in group except ones that the system exempts
2436      *  pid = -1 - all processes except ones that the system exempts
2437      *  pid = -n - all processes in group (abs(n)) except ...
2438      * For now, just report as not supported.
2439      */
2440
2441     if (pid <= 0) {
2442         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2443         return -1;
2444     }
2445
2446     iss = sys$sigprc((unsigned int *)&pid,0,code);
2447     if (iss&1) return 0;
2448
2449     switch (iss) {
2450       case SS$_NOPRIV:
2451         set_errno(EPERM);  break;
2452       case SS$_NONEXPR:
2453       case SS$_NOSUCHNODE:
2454       case SS$_UNREACHABLE:
2455         set_errno(ESRCH);  break;
2456       case SS$_INSFMEM:
2457         set_errno(ENOMEM); break;
2458       default:
2459         _ckvmssts_noperl(iss);
2460         set_errno(EVMSERR);
2461     }
2462     set_vaxc_errno(iss);
2463
2464     return -1;
2465 }
2466 #endif
2467
2468 /* Routine to convert a VMS status code to a UNIX status code.
2469 ** More tricky than it appears because of conflicting conventions with
2470 ** existing code.
2471 **
2472 ** VMS status codes are a bit mask, with the least significant bit set for
2473 ** success.
2474 **
2475 ** Special UNIX status of EVMSERR indicates that no translation is currently
2476 ** available, and programs should check the VMS status code.
2477 **
2478 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2479 ** decoding.
2480 */
2481
2482 #ifndef C_FACILITY_NO
2483 #define C_FACILITY_NO 0x350000
2484 #endif
2485 #ifndef DCL_IVVERB
2486 #define DCL_IVVERB 0x38090
2487 #endif
2488
2489 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2490 {
2491 int facility;
2492 int fac_sp;
2493 int msg_no;
2494 int msg_status;
2495 int unix_status;
2496
2497   /* Assume the best or the worst */
2498   if (vms_status & STS$M_SUCCESS)
2499     unix_status = 0;
2500   else
2501     unix_status = EVMSERR;
2502
2503   msg_status = vms_status & ~STS$M_CONTROL;
2504
2505   facility = vms_status & STS$M_FAC_NO;
2506   fac_sp = vms_status & STS$M_FAC_SP;
2507   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2508
2509   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2510     switch(msg_no) {
2511     case SS$_NORMAL:
2512         unix_status = 0;
2513         break;
2514     case SS$_ACCVIO:
2515         unix_status = EFAULT;
2516         break;
2517     case SS$_DEVOFFLINE:
2518         unix_status = EBUSY;
2519         break;
2520     case SS$_CLEARED:
2521         unix_status = ENOTCONN;
2522         break;
2523     case SS$_IVCHAN:
2524     case SS$_IVLOGNAM:
2525     case SS$_BADPARAM:
2526     case SS$_IVLOGTAB:
2527     case SS$_NOLOGNAM:
2528     case SS$_NOLOGTAB:
2529     case SS$_INVFILFOROP:
2530     case SS$_INVARG:
2531     case SS$_NOSUCHID:
2532     case SS$_IVIDENT:
2533         unix_status = EINVAL;
2534         break;
2535     case SS$_UNSUPPORTED:
2536         unix_status = ENOTSUP;
2537         break;
2538     case SS$_FILACCERR:
2539     case SS$_NOGRPPRV:
2540     case SS$_NOSYSPRV:
2541         unix_status = EACCES;
2542         break;
2543     case SS$_DEVICEFULL:
2544         unix_status = ENOSPC;
2545         break;
2546     case SS$_NOSUCHDEV:
2547         unix_status = ENODEV;
2548         break;
2549     case SS$_NOSUCHFILE:
2550     case SS$_NOSUCHOBJECT:
2551         unix_status = ENOENT;
2552         break;
2553     case SS$_ABORT:                                 /* Fatal case */
2554     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2555     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2556         unix_status = EINTR;
2557         break;
2558     case SS$_BUFFEROVF:
2559         unix_status = E2BIG;
2560         break;
2561     case SS$_INSFMEM:
2562         unix_status = ENOMEM;
2563         break;
2564     case SS$_NOPRIV:
2565         unix_status = EPERM;
2566         break;
2567     case SS$_NOSUCHNODE:
2568     case SS$_UNREACHABLE:
2569         unix_status = ESRCH;
2570         break;
2571     case SS$_NONEXPR:
2572         unix_status = ECHILD;
2573         break;
2574     default:
2575         if ((facility == 0) && (msg_no < 8)) {
2576           /* These are not real VMS status codes so assume that they are
2577           ** already UNIX status codes
2578           */
2579           unix_status = msg_no;
2580           break;
2581         }
2582     }
2583   }
2584   else {
2585     /* Translate a POSIX exit code to a UNIX exit code */
2586     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2587         unix_status = (msg_no & 0x07F8) >> 3;
2588     }
2589     else {
2590
2591          /* Documented traditional behavior for handling VMS child exits */
2592         /*--------------------------------------------------------------*/
2593         if (child_flag != 0) {
2594
2595              /* Success / Informational return 0 */
2596             /*----------------------------------*/
2597             if (msg_no & STS$K_SUCCESS)
2598                 return 0;
2599
2600              /* Warning returns 1 */
2601             /*-------------------*/
2602             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2603                 return 1;
2604
2605              /* Everything else pass through the severity bits */
2606             /*------------------------------------------------*/
2607             return (msg_no & STS$M_SEVERITY);
2608         }
2609
2610          /* Normal VMS status to ERRNO mapping attempt */
2611         /*--------------------------------------------*/
2612         switch(msg_status) {
2613         /* case RMS$_EOF: */ /* End of File */
2614         case RMS$_FNF:  /* File Not Found */
2615         case RMS$_DNF:  /* Dir Not Found */
2616                 unix_status = ENOENT;
2617                 break;
2618         case RMS$_RNF:  /* Record Not Found */
2619                 unix_status = ESRCH;
2620                 break;
2621         case RMS$_DIR:
2622                 unix_status = ENOTDIR;
2623                 break;
2624         case RMS$_DEV:
2625                 unix_status = ENODEV;
2626                 break;
2627         case RMS$_IFI:
2628         case RMS$_FAC:
2629         case RMS$_ISI:
2630                 unix_status = EBADF;
2631                 break;
2632         case RMS$_FEX:
2633                 unix_status = EEXIST;
2634                 break;
2635         case RMS$_SYN:
2636         case RMS$_FNM:
2637         case LIB$_INVSTRDES:
2638         case LIB$_INVARG:
2639         case LIB$_NOSUCHSYM:
2640         case LIB$_INVSYMNAM:
2641         case DCL_IVVERB:
2642                 unix_status = EINVAL;
2643                 break;
2644         case CLI$_BUFOVF:
2645         case RMS$_RTB:
2646         case CLI$_TKNOVF:
2647         case CLI$_RSLOVF:
2648                 unix_status = E2BIG;
2649                 break;
2650         case RMS$_PRV:  /* No privilege */
2651         case RMS$_ACC:  /* ACP file access failed */
2652         case RMS$_WLK:  /* Device write locked */
2653                 unix_status = EACCES;
2654                 break;
2655         case RMS$_MKD:  /* Failed to mark for delete */
2656                 unix_status = EPERM;
2657                 break;
2658         /* case RMS$_NMF: */  /* No more files */
2659         }
2660     }
2661   }
2662
2663   return unix_status;
2664 }
2665
2666 /* Try to guess at what VMS error status should go with a UNIX errno
2667  * value.  This is hard to do as there could be many possible VMS
2668  * error statuses that caused the errno value to be set.
2669  */
2670
2671 int Perl_unix_status_to_vms(int unix_status)
2672 {
2673 int test_unix_status;
2674
2675      /* Trivial cases first */
2676     /*---------------------*/
2677     if (unix_status == EVMSERR)
2678         return vaxc$errno;
2679
2680      /* Is vaxc$errno sane? */
2681     /*---------------------*/
2682     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2683     if (test_unix_status == unix_status)
2684         return vaxc$errno;
2685
2686      /* If way out of range, must be VMS code already */
2687     /*-----------------------------------------------*/
2688     if (unix_status > EVMSERR)
2689         return unix_status;
2690
2691      /* If out of range, punt */
2692     /*-----------------------*/
2693     if (unix_status > __ERRNO_MAX)
2694         return SS$_ABORT;
2695
2696
2697      /* Ok, now we have to do it the hard way. */
2698     /*----------------------------------------*/
2699     switch(unix_status) {
2700     case 0:     return SS$_NORMAL;
2701     case EPERM: return SS$_NOPRIV;
2702     case ENOENT: return SS$_NOSUCHOBJECT;
2703     case ESRCH: return SS$_UNREACHABLE;
2704     case EINTR: return SS$_ABORT;
2705     /* case EIO: */
2706     /* case ENXIO:  */
2707     case E2BIG: return SS$_BUFFEROVF;
2708     /* case ENOEXEC */
2709     case EBADF: return RMS$_IFI;
2710     case ECHILD: return SS$_NONEXPR;
2711     /* case EAGAIN */
2712     case ENOMEM: return SS$_INSFMEM;
2713     case EACCES: return SS$_FILACCERR;
2714     case EFAULT: return SS$_ACCVIO;
2715     /* case ENOTBLK */
2716     case EBUSY: return SS$_DEVOFFLINE;
2717     case EEXIST: return RMS$_FEX;
2718     /* case EXDEV */
2719     case ENODEV: return SS$_NOSUCHDEV;
2720     case ENOTDIR: return RMS$_DIR;
2721     /* case EISDIR */
2722     case EINVAL: return SS$_INVARG;
2723     /* case ENFILE */
2724     /* case EMFILE */
2725     /* case ENOTTY */
2726     /* case ETXTBSY */
2727     /* case EFBIG */
2728     case ENOSPC: return SS$_DEVICEFULL;
2729     case ESPIPE: return LIB$_INVARG;
2730     /* case EROFS: */
2731     /* case EMLINK: */
2732     /* case EPIPE: */
2733     /* case EDOM */
2734     case ERANGE: return LIB$_INVARG;
2735     /* case EWOULDBLOCK */
2736     /* case EINPROGRESS */
2737     /* case EALREADY */
2738     /* case ENOTSOCK */
2739     /* case EDESTADDRREQ */
2740     /* case EMSGSIZE */
2741     /* case EPROTOTYPE */
2742     /* case ENOPROTOOPT */
2743     /* case EPROTONOSUPPORT */
2744     /* case ESOCKTNOSUPPORT */
2745     /* case EOPNOTSUPP */
2746     /* case EPFNOSUPPORT */
2747     /* case EAFNOSUPPORT */
2748     /* case EADDRINUSE */
2749     /* case EADDRNOTAVAIL */
2750     /* case ENETDOWN */
2751     /* case ENETUNREACH */
2752     /* case ENETRESET */
2753     /* case ECONNABORTED */
2754     /* case ECONNRESET */
2755     /* case ENOBUFS */
2756     /* case EISCONN */
2757     case ENOTCONN: return SS$_CLEARED;
2758     /* case ESHUTDOWN */
2759     /* case ETOOMANYREFS */
2760     /* case ETIMEDOUT */
2761     /* case ECONNREFUSED */
2762     /* case ELOOP */
2763     /* case ENAMETOOLONG */
2764     /* case EHOSTDOWN */
2765     /* case EHOSTUNREACH */
2766     /* case ENOTEMPTY */
2767     /* case EPROCLIM */
2768     /* case EUSERS  */
2769     /* case EDQUOT  */
2770     /* case ENOMSG  */
2771     /* case EIDRM */
2772     /* case EALIGN */
2773     /* case ESTALE */
2774     /* case EREMOTE */
2775     /* case ENOLCK */
2776     /* case ENOSYS */
2777     /* case EFTYPE */
2778     /* case ECANCELED */
2779     /* case EFAIL */
2780     /* case EINPROG */
2781     case ENOTSUP:
2782         return SS$_UNSUPPORTED;
2783     /* case EDEADLK */
2784     /* case ENWAIT */
2785     /* case EILSEQ */
2786     /* case EBADCAT */
2787     /* case EBADMSG */
2788     /* case EABANDONED */
2789     default:
2790         return SS$_ABORT; /* punt */
2791     }
2792 }
2793
2794
2795 /* default piping mailbox size */
2796 #ifdef __VAX
2797 #  define PERL_BUFSIZ        512
2798 #else
2799 #  define PERL_BUFSIZ        8192
2800 #endif
2801
2802
2803 static void
2804 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2805 {
2806   unsigned long int mbxbufsiz;
2807   static unsigned long int syssize = 0;
2808   unsigned long int dviitm = DVI$_DEVNAM;
2809   char csize[LNM$C_NAMLENGTH+1];
2810   int sts;
2811
2812   if (!syssize) {
2813     unsigned long syiitm = SYI$_MAXBUF;
2814     /*
2815      * Get the SYSGEN parameter MAXBUF
2816      *
2817      * If the logical 'PERL_MBX_SIZE' is defined
2818      * use the value of the logical instead of PERL_BUFSIZ, but
2819      * keep the size between 128 and MAXBUF.
2820      *
2821      */
2822     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2823   }
2824
2825   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2826       mbxbufsiz = atoi(csize);
2827   } else {
2828       mbxbufsiz = PERL_BUFSIZ;
2829   }
2830   if (mbxbufsiz < 128) mbxbufsiz = 128;
2831   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2832
2833   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2834
2835   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2836   _ckvmssts_noperl(sts);
2837   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2838
2839 }  /* end of create_mbx() */
2840
2841
2842 /*{{{  my_popen and my_pclose*/
2843
2844 typedef struct _iosb           IOSB;
2845 typedef struct _iosb*         pIOSB;
2846 typedef struct _pipe           Pipe;
2847 typedef struct _pipe*         pPipe;
2848 typedef struct pipe_details    Info;
2849 typedef struct pipe_details*  pInfo;
2850 typedef struct _srqp            RQE;
2851 typedef struct _srqp*          pRQE;
2852 typedef struct _tochildbuf      CBuf;
2853 typedef struct _tochildbuf*    pCBuf;
2854
2855 struct _iosb {
2856     unsigned short status;
2857     unsigned short count;
2858     unsigned long  dvispec;
2859 };
2860
2861 #pragma member_alignment save
2862 #pragma nomember_alignment quadword
2863 struct _srqp {          /* VMS self-relative queue entry */
2864     unsigned long qptr[2];
2865 };
2866 #pragma member_alignment restore
2867 static RQE  RQE_ZERO = {0,0};
2868
2869 struct _tochildbuf {
2870     RQE             q;
2871     int             eof;
2872     unsigned short  size;
2873     char            *buf;
2874 };
2875
2876 struct _pipe {
2877     RQE            free;
2878     RQE            wait;
2879     int            fd_out;
2880     unsigned short chan_in;
2881     unsigned short chan_out;
2882     char          *buf;
2883     unsigned int   bufsize;
2884     IOSB           iosb;
2885     IOSB           iosb2;
2886     int           *pipe_done;
2887     int            retry;
2888     int            type;
2889     int            shut_on_empty;
2890     int            need_wake;
2891     pPipe         *home;
2892     pInfo          info;
2893     pCBuf          curr;
2894     pCBuf          curr2;
2895 #if defined(PERL_IMPLICIT_CONTEXT)
2896     void            *thx;           /* Either a thread or an interpreter */
2897                                     /* pointer, depending on how we're built */
2898 #endif
2899 };
2900
2901
2902 struct pipe_details
2903 {
2904     pInfo           next;
2905     PerlIO *fp;  /* file pointer to pipe mailbox */
2906     int useFILE; /* using stdio, not perlio */
2907     int pid;   /* PID of subprocess */
2908     int mode;  /* == 'r' if pipe open for reading */
2909     int done;  /* subprocess has completed */
2910     int waiting; /* waiting for completion/closure */
2911     int             closing;        /* my_pclose is closing this pipe */
2912     unsigned long   completion;     /* termination status of subprocess */
2913     pPipe           in;             /* pipe in to sub */
2914     pPipe           out;            /* pipe out of sub */
2915     pPipe           err;            /* pipe of sub's sys$error */
2916     int             in_done;        /* true when in pipe finished */
2917     int             out_done;
2918     int             err_done;
2919     unsigned short  xchan;          /* channel to debug xterm */
2920     unsigned short  xchan_valid;    /* channel is assigned */
2921 };
2922
2923 struct exit_control_block
2924 {
2925     struct exit_control_block *flink;
2926     unsigned long int   (*exit_routine)();
2927     unsigned long int arg_count;
2928     unsigned long int *status_address;
2929     unsigned long int exit_status;
2930 };
2931
2932 typedef struct _closed_pipes    Xpipe;
2933 typedef struct _closed_pipes*  pXpipe;
2934
2935 struct _closed_pipes {
2936     int             pid;            /* PID of subprocess */
2937     unsigned long   completion;     /* termination status of subprocess */
2938 };
2939 #define NKEEPCLOSED 50
2940 static Xpipe closed_list[NKEEPCLOSED];
2941 static int   closed_index = 0;
2942 static int   closed_num = 0;
2943
2944 #define RETRY_DELAY     "0 ::0.20"
2945 #define MAX_RETRY              50
2946
2947 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2948 static unsigned long mypid;
2949 static unsigned long delaytime[2];
2950
2951 static pInfo open_pipes = NULL;
2952 static $DESCRIPTOR(nl_desc, "NL:");
2953
2954 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2955
2956
2957
2958 static unsigned long int
2959 pipe_exit_routine()
2960 {
2961     pInfo info;
2962     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2963     int sts, did_stuff, j;
2964
2965    /*
2966     * Flush any pending i/o, but since we are in process run-down, be
2967     * careful about referencing PerlIO structures that may already have
2968     * been deallocated.  We may not even have an interpreter anymore.
2969     */
2970     info = open_pipes;
2971     while (info) {
2972         if (info->fp) {
2973 #if defined(PERL_IMPLICIT_CONTEXT)
2974            /* We need to use the Perl context of the thread that created */
2975            /* the pipe. */
2976            pTHX;
2977            if (info->err)
2978                aTHX = info->err->thx;
2979            else if (info->out)
2980                aTHX = info->out->thx;
2981            else if (info->in)
2982                aTHX = info->in->thx;
2983 #endif
2984            if (!info->useFILE
2985 #if defined(USE_ITHREADS)
2986              && my_perl
2987 #endif
2988 #ifdef USE_PERLIO
2989              && PL_perlio_fd_refcnt
2990 #endif
2991               )
2992                PerlIO_flush(info->fp);
2993            else
2994                fflush((FILE *)info->fp);
2995         }
2996         info = info->next;
2997     }
2998
2999     /*
3000      next we try sending an EOF...ignore if doesn't work, make sure we
3001      don't hang
3002     */
3003     did_stuff = 0;
3004     info = open_pipes;
3005
3006     while (info) {
3007       _ckvmssts_noperl(sys$setast(0));
3008       if (info->in && !info->in->shut_on_empty) {
3009         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3010                                  0, 0, 0, 0, 0, 0));
3011         info->waiting = 1;
3012         did_stuff = 1;
3013       }
3014       _ckvmssts_noperl(sys$setast(1));
3015       info = info->next;
3016     }
3017
3018     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3019
3020     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3021         int nwait = 0;
3022
3023         info = open_pipes;
3024         while (info) {
3025           _ckvmssts_noperl(sys$setast(0));
3026           if (info->waiting && info->done)
3027                 info->waiting = 0;
3028           nwait += info->waiting;
3029           _ckvmssts_noperl(sys$setast(1));
3030           info = info->next;
3031         }
3032         if (!nwait) break;
3033         sleep(1);
3034     }
3035
3036     did_stuff = 0;
3037     info = open_pipes;
3038     while (info) {
3039       _ckvmssts_noperl(sys$setast(0));
3040       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3041         sts = sys$forcex(&info->pid,0,&abort);
3042         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3043         did_stuff = 1;
3044       }
3045       _ckvmssts_noperl(sys$setast(1));
3046       info = info->next;
3047     }
3048
3049     /* again, wait for effect */
3050
3051     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3052         int nwait = 0;
3053
3054         info = open_pipes;
3055         while (info) {
3056           _ckvmssts_noperl(sys$setast(0));
3057           if (info->waiting && info->done)
3058                 info->waiting = 0;
3059           nwait += info->waiting;
3060           _ckvmssts_noperl(sys$setast(1));
3061           info = info->next;
3062         }
3063         if (!nwait) break;
3064         sleep(1);
3065     }
3066
3067     info = open_pipes;
3068     while (info) {
3069       _ckvmssts_noperl(sys$setast(0));
3070       if (!info->done) {  /* We tried to be nice . . . */
3071         sts = sys$delprc(&info->pid,0);
3072         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3073         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3074       }
3075       _ckvmssts_noperl(sys$setast(1));
3076       info = info->next;
3077     }
3078
3079     while(open_pipes) {
3080
3081 #if defined(PERL_IMPLICIT_CONTEXT)
3082       /* We need to use the Perl context of the thread that created */
3083       /* the pipe. */
3084       pTHX;
3085       if (open_pipes->err)
3086           aTHX = open_pipes->err->thx;
3087       else if (open_pipes->out)
3088           aTHX = open_pipes->out->thx;
3089       else if (open_pipes->in)
3090           aTHX = open_pipes->in->thx;
3091 #endif
3092       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3093       else if (!(sts & 1)) retsts = sts;
3094     }
3095     return retsts;
3096 }
3097
3098 static struct exit_control_block pipe_exitblock =
3099        {(struct exit_control_block *) 0,
3100         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3101
3102 static void pipe_mbxtofd_ast(pPipe p);
3103 static void pipe_tochild1_ast(pPipe p);
3104 static void pipe_tochild2_ast(pPipe p);
3105
3106 static void
3107 popen_completion_ast(pInfo info)
3108 {
3109   pInfo i = open_pipes;
3110   int iss;
3111
3112   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3113   closed_list[closed_index].pid = info->pid;
3114   closed_list[closed_index].completion = info->completion;
3115   closed_index++;
3116   if (closed_index == NKEEPCLOSED)
3117     closed_index = 0;
3118   closed_num++;
3119
3120   while (i) {
3121     if (i == info) break;
3122     i = i->next;
3123   }
3124   if (!i) return;       /* unlinked, probably freed too */
3125
3126   info->done = TRUE;
3127
3128 /*
3129     Writing to subprocess ...
3130             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3131
3132             chan_out may be waiting for "done" flag, or hung waiting
3133             for i/o completion to child...cancel the i/o.  This will
3134             put it into "snarf mode" (done but no EOF yet) that discards
3135             input.
3136
3137     Output from subprocess (stdout, stderr) needs to be flushed and
3138     shut down.   We try sending an EOF, but if the mbx is full the pipe
3139     routine should still catch the "shut_on_empty" flag, telling it to
3140     use immediate-style reads so that "mbx empty" -> EOF.
3141
3142
3143 */
3144   if (info->in && !info->in_done) {               /* only for mode=w */
3145         if (info->in->shut_on_empty && info->in->need_wake) {
3146             info->in->need_wake = FALSE;
3147             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3148         } else {
3149             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3150         }
3151   }
3152
3153   if (info->out && !info->out_done) {             /* were we also piping output? */
3154       info->out->shut_on_empty = TRUE;
3155       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3156       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3157       _ckvmssts_noperl(iss);
3158   }
3159
3160   if (info->err && !info->err_done) {        /* we were piping stderr */
3161         info->err->shut_on_empty = TRUE;
3162         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3163         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3164         _ckvmssts_noperl(iss);
3165   }
3166   _ckvmssts_noperl(sys$setef(pipe_ef));
3167
3168 }
3169
3170 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3171 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3172
3173 /*
3174     we actually differ from vmstrnenv since we use this to
3175     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3176     are pointing to the same thing
3177 */
3178
3179 static unsigned short
3180 popen_translate(pTHX_ char *logical, char *result)
3181 {
3182     int iss;
3183     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3184     $DESCRIPTOR(d_log,"");
3185     struct _il3 {
3186         unsigned short length;
3187         unsigned short code;
3188         char *         buffer_addr;
3189         unsigned short *retlenaddr;
3190     } itmlst[2];
3191     unsigned short l, ifi;
3192
3193     d_log.dsc$a_pointer = logical;
3194     d_log.dsc$w_length  = strlen(logical);
3195
3196     itmlst[0].code = LNM$_STRING;
3197     itmlst[0].length = 255;
3198     itmlst[0].buffer_addr = result;
3199     itmlst[0].retlenaddr = &l;
3200
3201     itmlst[1].code = 0;
3202     itmlst[1].length = 0;
3203     itmlst[1].buffer_addr = 0;
3204     itmlst[1].retlenaddr = 0;
3205
3206     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3207     if (iss == SS$_NOLOGNAM) {
3208         iss = SS$_NORMAL;
3209         l = 0;
3210     }
3211     if (!(iss&1)) lib$signal(iss);
3212     result[l] = '\0';
3213 /*
3214     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3215     strip it off and return the ifi, if any
3216 */
3217     ifi  = 0;
3218     if (result[0] == 0x1b && result[1] == 0x00) {
3219         memmove(&ifi,result+2,2);
3220         strcpy(result,result+4);
3221     }
3222     return ifi;     /* this is the RMS internal file id */
3223 }
3224
3225 static void pipe_infromchild_ast(pPipe p);
3226
3227 /*
3228     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3229     inside an AST routine without worrying about reentrancy and which Perl
3230     memory allocator is being used.
3231
3232     We read data and queue up the buffers, then spit them out one at a
3233     time to the output mailbox when the output mailbox is ready for one.
3234
3235 */
3236 #define INITIAL_TOCHILDQUEUE  2
3237
3238 static pPipe
3239 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3240 {
3241     pPipe p;
3242     pCBuf b;
3243     char mbx1[64], mbx2[64];
3244     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3245                                       DSC$K_CLASS_S, mbx1},
3246                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3247                                       DSC$K_CLASS_S, mbx2};
3248     unsigned int dviitm = DVI$_DEVBUFSIZ;
3249     int j, n;
3250
3251     n = sizeof(Pipe);
3252     _ckvmssts_noperl(lib$get_vm(&n, &p));
3253
3254     create_mbx(&p->chan_in , &d_mbx1);
3255     create_mbx(&p->chan_out, &d_mbx2);
3256     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3257
3258     p->buf           = 0;
3259     p->shut_on_empty = FALSE;
3260     p->need_wake     = FALSE;
3261     p->type          = 0;
3262     p->retry         = 0;
3263     p->iosb.status   = SS$_NORMAL;
3264     p->iosb2.status  = SS$_NORMAL;
3265     p->free          = RQE_ZERO;
3266     p->wait          = RQE_ZERO;
3267     p->curr          = 0;
3268     p->curr2         = 0;
3269     p->info          = 0;
3270 #ifdef PERL_IMPLICIT_CONTEXT
3271     p->thx           = aTHX;
3272 #endif
3273
3274     n = sizeof(CBuf) + p->bufsize;
3275
3276     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3277         _ckvmssts_noperl(lib$get_vm(&n, &b));
3278         b->buf = (char *) b + sizeof(CBuf);
3279         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3280     }
3281
3282     pipe_tochild2_ast(p);
3283     pipe_tochild1_ast(p);
3284     strcpy(wmbx, mbx1);
3285     strcpy(rmbx, mbx2);
3286     return p;
3287 }
3288
3289 /*  reads the MBX Perl is writing, and queues */
3290
3291 static void
3292 pipe_tochild1_ast(pPipe p)
3293 {
3294     pCBuf b = p->curr;
3295     int iss = p->iosb.status;
3296     int eof = (iss == SS$_ENDOFFILE);
3297     int sts;
3298 #ifdef PERL_IMPLICIT_CONTEXT
3299     pTHX = p->thx;
3300 #endif
3301
3302     if (p->retry) {
3303         if (eof) {
3304             p->shut_on_empty = TRUE;
3305             b->eof     = TRUE;
3306             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3307         } else  {
3308             _ckvmssts_noperl(iss);
3309         }
3310
3311         b->eof  = eof;
3312         b->size = p->iosb.count;
3313         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3314         if (p->need_wake) {
3315             p->need_wake = FALSE;
3316             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3317         }
3318     } else {
3319         p->retry = 1;   /* initial call */
3320     }
3321
3322     if (eof) {                  /* flush the free queue, return when done */
3323         int n = sizeof(CBuf) + p->bufsize;
3324         while (1) {
3325             iss = lib$remqti(&p->free, &b);
3326             if (iss == LIB$_QUEWASEMP) return;
3327             _ckvmssts_noperl(iss);
3328             _ckvmssts_noperl(lib$free_vm(&n, &b));
3329         }
3330     }
3331
3332     iss = lib$remqti(&p->free, &b);
3333     if (iss == LIB$_QUEWASEMP) {
3334         int n = sizeof(CBuf) + p->bufsize;
3335         _ckvmssts_noperl(lib$get_vm(&n, &b));
3336         b->buf = (char *) b + sizeof(CBuf);
3337     } else {
3338        _ckvmssts_noperl(iss);
3339     }
3340
3341     p->curr = b;
3342     iss = sys$qio(0,p->chan_in,
3343              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3344              &p->iosb,
3345              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3346     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3347     _ckvmssts_noperl(iss);
3348 }
3349
3350
3351 /* writes queued buffers to output, waits for each to complete before
3352    doing the next */
3353
3354 static void
3355 pipe_tochild2_ast(pPipe p)
3356 {
3357     pCBuf b = p->curr2;
3358     int iss = p->iosb2.status;
3359     int n = sizeof(CBuf) + p->bufsize;
3360     int done = (p->info && p->info->done) ||
3361               iss == SS$_CANCEL || iss == SS$_ABORT;
3362 #if defined(PERL_IMPLICIT_CONTEXT)
3363     pTHX = p->thx;
3364 #endif
3365
3366     do {
3367         if (p->type) {         /* type=1 has old buffer, dispose */
3368             if (p->shut_on_empty) {
3369                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3370             } else {
3371                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3372             }
3373             p->type = 0;
3374         }
3375
3376         iss = lib$remqti(&p->wait, &b);
3377         if (iss == LIB$_QUEWASEMP) {
3378             if (p->shut_on_empty) {
3379                 if (done) {
3380                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3381                     *p->pipe_done = TRUE;
3382                     _ckvmssts_noperl(sys$setef(pipe_ef));
3383                 } else {
3384                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3385                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3386                 }
3387                 return;
3388             }
3389             p->need_wake = TRUE;
3390             return;
3391         }
3392         _ckvmssts_noperl(iss);
3393         p->type = 1;
3394     } while (done);
3395
3396
3397     p->curr2 = b;
3398     if (b->eof) {
3399         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3400             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3401     } else {
3402         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3403             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3404     }
3405
3406     return;
3407
3408 }
3409
3410
3411 static pPipe
3412 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3413 {
3414     pPipe p;
3415     char mbx1[64], mbx2[64];
3416     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3417                                       DSC$K_CLASS_S, mbx1},
3418                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3419                                       DSC$K_CLASS_S, mbx2};
3420     unsigned int dviitm = DVI$_DEVBUFSIZ;
3421
3422     int n = sizeof(Pipe);
3423     _ckvmssts_noperl(lib$get_vm(&n, &p));
3424     create_mbx(&p->chan_in , &d_mbx1);
3425     create_mbx(&p->chan_out, &d_mbx2);
3426
3427     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3428     n = p->bufsize * sizeof(char);
3429     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3430     p->shut_on_empty = FALSE;
3431     p->info   = 0;
3432     p->type   = 0;
3433     p->iosb.status = SS$_NORMAL;
3434 #if defined(PERL_IMPLICIT_CONTEXT)
3435     p->thx = aTHX;
3436 #endif
3437     pipe_infromchild_ast(p);
3438
3439     strcpy(wmbx, mbx1);
3440     strcpy(rmbx, mbx2);
3441     return p;
3442 }
3443
3444 static void
3445 pipe_infromchild_ast(pPipe p)
3446 {
3447     int iss = p->iosb.status;
3448     int eof = (iss == SS$_ENDOFFILE);
3449     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3450     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3451 #if defined(PERL_IMPLICIT_CONTEXT)
3452     pTHX = p->thx;
3453 #endif
3454
3455     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3456         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3457         p->chan_out = 0;
3458     }
3459
3460     /* read completed:
3461             input shutdown if EOF from self (done or shut_on_empty)
3462             output shutdown if closing flag set (my_pclose)
3463             send data/eof from child or eof from self
3464             otherwise, re-read (snarf of data from child)
3465     */
3466
3467     if (p->type == 1) {
3468         p->type = 0;
3469         if (myeof && p->chan_in) {                  /* input shutdown */
3470             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3471             p->chan_in = 0;
3472         }
3473
3474         if (p->chan_out) {
3475             if (myeof || kideof) {      /* pass EOF to parent */
3476                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3477                                          pipe_infromchild_ast, p,
3478                                          0, 0, 0, 0, 0, 0));
3479                 return;
3480             } else if (eof) {       /* eat EOF --- fall through to read*/
3481
3482             } else {                /* transmit data */
3483                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3484                                          pipe_infromchild_ast,p,
3485                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3486                 return;
3487             }
3488         }
3489     }
3490
3491     /*  everything shut? flag as done */
3492
3493     if (!p->chan_in && !p->chan_out) {
3494         *p->pipe_done = TRUE;
3495         _ckvmssts_noperl(sys$setef(pipe_ef));
3496         return;
3497     }
3498
3499     /* write completed (or read, if snarfing from child)
3500             if still have input active,
3501                queue read...immediate mode if shut_on_empty so we get EOF if empty
3502             otherwise,
3503                check if Perl reading, generate EOFs as needed
3504     */
3505
3506     if (p->type == 0) {
3507         p->type = 1;
3508         if (p->chan_in) {
3509             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3510                           pipe_infromchild_ast,p,
3511                           p->buf, p->bufsize, 0, 0, 0, 0);
3512             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3513             _ckvmssts_noperl(iss);
3514         } else {           /* send EOFs for extra reads */
3515             p->iosb.status = SS$_ENDOFFILE;
3516             p->iosb.dvispec = 0;
3517             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3518                                      0, 0, 0,
3519                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3520         }
3521     }
3522 }
3523
3524 static pPipe
3525 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3526 {
3527     pPipe p;
3528     char mbx[64];
3529     unsigned long dviitm = DVI$_DEVBUFSIZ;
3530     struct stat s;
3531     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3532                                       DSC$K_CLASS_S, mbx};
3533     int n = sizeof(Pipe);
3534
3535     /* things like terminals and mbx's don't need this filter */
3536     if (fd && fstat(fd,&s) == 0) {
3537         unsigned long devchar;
3538         char device[65];
3539         unsigned short dev_len;
3540         struct dsc$descriptor_s d_dev;
3541         char * cptr;
3542         struct item_list_3 items[3];
3543         int status;
3544         unsigned short dvi_iosb[4];
3545
3546         cptr = getname(fd, out, 1);
3547         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3548         d_dev.dsc$a_pointer = out;
3549         d_dev.dsc$w_length = strlen(out);
3550         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3551         d_dev.dsc$b_class = DSC$K_CLASS_S;
3552
3553         items[0].len = 4;
3554         items[0].code = DVI$_DEVCHAR;
3555         items[0].bufadr = &devchar;
3556         items[0].retadr = NULL;
3557         items[1].len = 64;
3558         items[1].code = DVI$_FULLDEVNAM;
3559         items[1].bufadr = device;
3560         items[1].retadr = &dev_len;
3561         items[2].len = 0;
3562         items[2].code = 0;
3563
3564         status = sys$getdviw
3565                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3566         _ckvmssts_noperl(status);
3567         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3568             device[dev_len] = 0;
3569
3570             if (!(devchar & DEV$M_DIR)) {
3571                 strcpy(out, device);
3572                 return 0;
3573             }
3574         }
3575     }
3576
3577     _ckvmssts_noperl(lib$get_vm(&n, &p));
3578     p->fd_out = dup(fd);
3579     create_mbx(&p->chan_in, &d_mbx);
3580     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3581     n = (p->bufsize+1) * sizeof(char);
3582     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3583     p->shut_on_empty = FALSE;
3584     p->retry = 0;
3585     p->info  = 0;
3586     strcpy(out, mbx);
3587
3588     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3589                              pipe_mbxtofd_ast, p,
3590                              p->buf, p->bufsize, 0, 0, 0, 0));
3591
3592     return p;
3593 }
3594
3595 static void
3596 pipe_mbxtofd_ast(pPipe p)
3597 {
3598     int iss = p->iosb.status;
3599     int done = p->info->done;
3600     int iss2;
3601     int eof = (iss == SS$_ENDOFFILE);
3602     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3603     int err = !(iss&1) && !eof;
3604 #if defined(PERL_IMPLICIT_CONTEXT)
3605     pTHX = p->thx;
3606 #endif
3607
3608     if (done && myeof) {               /* end piping */
3609         close(p->fd_out);
3610         sys$dassgn(p->chan_in);
3611         *p->pipe_done = TRUE;
3612         _ckvmssts_noperl(sys$setef(pipe_ef));
3613         return;
3614     }
3615
3616     if (!err && !eof) {             /* good data to send to file */
3617         p->buf[p->iosb.count] = '\n';
3618         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3619         if (iss2 < 0) {
3620             p->retry++;
3621             if (p->retry < MAX_RETRY) {
3622                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3623                 return;
3624             }
3625         }
3626         p->retry = 0;
3627     } else if (err) {
3628         _ckvmssts_noperl(iss);
3629     }
3630
3631
3632     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3633           pipe_mbxtofd_ast, p,
3634           p->buf, p->bufsize, 0, 0, 0, 0);
3635     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3636     _ckvmssts_noperl(iss);
3637 }
3638
3639
3640 typedef struct _pipeloc     PLOC;
3641 typedef struct _pipeloc*   pPLOC;
3642
3643 struct _pipeloc {
3644     pPLOC   next;
3645     char    dir[NAM$C_MAXRSS+1];
3646 };
3647 static pPLOC  head_PLOC = 0;
3648
3649 void
3650 free_pipelocs(pTHX_ void *head)
3651 {
3652     pPLOC p, pnext;
3653     pPLOC *pHead = (pPLOC *)head;
3654
3655     p = *pHead;
3656     while (p) {
3657         pnext = p->next;
3658         PerlMem_free(p);
3659         p = pnext;
3660     }
3661     *pHead = 0;
3662 }
3663
3664 static void
3665 store_pipelocs(pTHX)
3666 {
3667     int    i;
3668     pPLOC  p;
3669     AV    *av = 0;
3670     SV    *dirsv;
3671     char  *dir, *x;
3672     char  *unixdir;
3673     char  temp[NAM$C_MAXRSS+1];
3674     STRLEN n_a;
3675
3676     if (head_PLOC)
3677         free_pipelocs(aTHX_ &head_PLOC);
3678
3679 /*  the . directory from @INC comes last */
3680
3681     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3682     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3683     p->next = head_PLOC;
3684     head_PLOC = p;
3685     strcpy(p->dir,"./");
3686
3687 /*  get the directory from $^X */
3688
3689     unixdir = PerlMem_malloc(VMS_MAXRSS);
3690     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3691
3692 #ifdef PERL_IMPLICIT_CONTEXT
3693     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3694 #else
3695     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3696 #endif
3697         strcpy(temp, PL_origargv[0]);
3698         x = strrchr(temp,']');
3699         if (x == NULL) {
3700         x = strrchr(temp,'>');
3701           if (x == NULL) {
3702             /* It could be a UNIX path */
3703             x = strrchr(temp,'/');
3704           }
3705         }
3706         if (x)
3707           x[1] = '\0';
3708         else {
3709           /* Got a bare name, so use default directory */
3710           temp[0] = '.';
3711           temp[1] = '\0';
3712         }
3713
3714         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3715             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3716             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3717             p->next = head_PLOC;
3718             head_PLOC = p;
3719             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3720             p->dir[NAM$C_MAXRSS] = '\0';
3721         }
3722     }
3723
3724 /*  reverse order of @INC entries, skip "." since entered above */
3725
3726 #ifdef PERL_IMPLICIT_CONTEXT
3727     if (aTHX)
3728 #endif
3729     if (PL_incgv) av = GvAVn(PL_incgv);
3730
3731     for (i = 0; av && i <= AvFILL(av); i++) {
3732         dirsv = *av_fetch(av,i,TRUE);
3733
3734         if (SvROK(dirsv)) continue;
3735         dir = SvPVx(dirsv,n_a);
3736         if (strcmp(dir,".") == 0) continue;
3737         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3738             continue;
3739
3740         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3741         p->next = head_PLOC;
3742         head_PLOC = p;
3743         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3744         p->dir[NAM$C_MAXRSS] = '\0';
3745     }
3746
3747 /* most likely spot (ARCHLIB) put first in the list */
3748
3749 #ifdef ARCHLIB_EXP
3750     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3751         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3752         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3753         p->next = head_PLOC;
3754         head_PLOC = p;
3755         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3756         p->dir[NAM$C_MAXRSS] = '\0';
3757     }
3758 #endif
3759     PerlMem_free(unixdir);
3760 }
3761
3762 static I32
3763 Perl_cando_by_name_int
3764    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3765 #if !defined(PERL_IMPLICIT_CONTEXT)
3766 #define cando_by_name_int               Perl_cando_by_name_int
3767 #else
3768 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3769 #endif
3770
3771 static char *
3772 find_vmspipe(pTHX)
3773 {
3774     static int   vmspipe_file_status = 0;
3775     static char  vmspipe_file[NAM$C_MAXRSS+1];
3776
3777     /* already found? Check and use ... need read+execute permission */
3778
3779     if (vmspipe_file_status == 1) {
3780         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3781          && cando_by_name_int
3782            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3783             return vmspipe_file;
3784         }
3785         vmspipe_file_status = 0;
3786     }
3787
3788     /* scan through stored @INC, $^X */
3789
3790     if (vmspipe_file_status == 0) {
3791         char file[NAM$C_MAXRSS+1];
3792         pPLOC  p = head_PLOC;
3793
3794         while (p) {
3795             char * exp_res;
3796             int dirlen;
3797             strcpy(file, p->dir);
3798             dirlen = strlen(file);
3799             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3800             file[NAM$C_MAXRSS] = '\0';
3801             p = p->next;
3802
3803             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3804             if (!exp_res) continue;
3805
3806             if (cando_by_name_int
3807                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3808              && cando_by_name_int
3809                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3810                 vmspipe_file_status = 1;
3811                 return vmspipe_file;
3812             }
3813         }
3814         vmspipe_file_status = -1;   /* failed, use tempfiles */
3815     }
3816
3817     return 0;
3818 }
3819
3820 static FILE *
3821 vmspipe_tempfile(pTHX)
3822 {
3823     char file[NAM$C_MAXRSS+1];
3824     FILE *fp;
3825     static int index = 0;
3826     Stat_t s0, s1;
3827     int cmp_result;
3828
3829     /* create a tempfile */
3830
3831     /* we can't go from   W, shr=get to  R, shr=get without
3832        an intermediate vulnerable state, so don't bother trying...
3833
3834        and lib$spawn doesn't shr=put, so have to close the write
3835
3836        So... match up the creation date/time and the FID to
3837        make sure we're dealing with the same file
3838
3839     */
3840
3841     index++;
3842     if (!decc_filename_unix_only) {
3843       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3844       fp = fopen(file,"w");
3845       if (!fp) {
3846         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3847         fp = fopen(file,"w");
3848         if (!fp) {
3849             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3850             fp = fopen(file,"w");
3851         }
3852       }
3853      }
3854      else {
3855       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3856       fp = fopen(file,"w");
3857       if (!fp) {
3858         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3859         fp = fopen(file,"w");
3860         if (!fp) {
3861           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3862           fp = fopen(file,"w");
3863         }
3864       }
3865     }
3866     if (!fp) return 0;  /* we're hosed */
3867
3868     fprintf(fp,"$! 'f$verify(0)'\n");
3869     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3870     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3871     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3872     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3873     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3874     fprintf(fp,"$ perl_del    = \"delete\"\n");
3875     fprintf(fp,"$ pif         = \"if\"\n");
3876     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3877     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3878     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3879     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3880     fprintf(fp,"$!  --- build command line to get max possible length\n");
3881     fprintf(fp,"$c=perl_popen_cmd0\n");
3882     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3883     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3884     fprintf(fp,"$x=perl_popen_cmd3\n");
3885     fprintf(fp,"$c=c+x\n");
3886     fprintf(fp,"$ perl_on\n");
3887     fprintf(fp,"$ 'c'\n");
3888     fprintf(fp,"$ perl_status = $STATUS\n");
3889     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3890     fprintf(fp,"$ perl_exit 'perl_status'\n");
3891     fsync(fileno(fp));
3892
3893     fgetname(fp, file, 1);
3894     fstat(fileno(fp), &s0.crtl_stat);
3895     fclose(fp);
3896
3897     if (decc_filename_unix_only)
3898         int_tounixspec(file, file, NULL);
3899     fp = fopen(file,"r","shr=get");
3900     if (!fp) return 0;
3901     fstat(fileno(fp), &s1.crtl_stat);
3902
3903     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3904     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3905         fclose(fp);
3906         return 0;
3907     }
3908
3909     return fp;
3910 }
3911
3912
3913 static int vms_is_syscommand_xterm(void)
3914 {
3915     const static struct dsc$descriptor_s syscommand_dsc =
3916       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3917
3918     const static struct dsc$descriptor_s decwdisplay_dsc =
3919       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3920
3921     struct item_list_3 items[2];
3922     unsigned short dvi_iosb[4];
3923     unsigned long devchar;
3924     unsigned long devclass;
3925     int status;
3926
3927     /* Very simple check to guess if sys$command is a decterm? */
3928     /* First see if the DECW$DISPLAY: device exists */
3929     items[0].len = 4;
3930     items[0].code = DVI$_DEVCHAR;
3931     items[0].bufadr = &devchar;
3932     items[0].retadr = NULL;
3933     items[1].len = 0;
3934     items[1].code = 0;
3935
3936     status = sys$getdviw
3937         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3938
3939     if ($VMS_STATUS_SUCCESS(status)) {
3940         status = dvi_iosb[0];
3941     }
3942
3943     if (!$VMS_STATUS_SUCCESS(status)) {
3944         SETERRNO(EVMSERR, status);
3945         return -1;
3946     }
3947
3948     /* If it does, then for now assume that we are on a workstation */
3949     /* Now verify that SYS$COMMAND is a terminal */
3950     /* for creating the debugger DECTerm */
3951
3952     items[0].len = 4;
3953     items[0].code = DVI$_DEVCLASS;
3954     items[0].bufadr = &devclass;
3955     items[0].retadr = NULL;
3956     items[1].len = 0;
3957     items[1].code = 0;
3958
3959     status = sys$getdviw
3960         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3961
3962     if ($VMS_STATUS_SUCCESS(status)) {
3963         status = dvi_iosb[0];
3964     }
3965
3966     if (!$VMS_STATUS_SUCCESS(status)) {
3967         SETERRNO(EVMSERR, status);
3968         return -1;
3969     }
3970     else {
3971         if (devclass == DC$_TERM) {
3972             return 0;
3973         }
3974     }
3975     return -1;
3976 }
3977
3978 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3979 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3980 {
3981     int status;
3982     int ret_stat;
3983     char * ret_char;
3984     char device_name[65];
3985     unsigned short device_name_len;
3986     struct dsc$descriptor_s customization_dsc;
3987     struct dsc$descriptor_s device_name_dsc;
3988     const char * cptr;
3989     char customization[200];
3990     char title[40];
3991     pInfo info = NULL;
3992     char mbx1[64];
3993     unsigned short p_chan;
3994     int n;
3995     unsigned short iosb[4];
3996     const char * cust_str =
3997         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3998     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3999                                           DSC$K_CLASS_S, mbx1};
4000
4001      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4002     /*---------------------------------------*/
4003     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4004
4005
4006     /* Make sure that this is from the Perl debugger */
4007     ret_char = strstr(cmd," xterm ");
4008     if (ret_char == NULL)
4009         return NULL;
4010     cptr = ret_char + 7;
4011     ret_char = strstr(cmd,"tty");
4012     if (ret_char == NULL)
4013         return NULL;
4014     ret_char = strstr(cmd,"sleep");
4015     if (ret_char == NULL)
4016         return NULL;
4017
4018     if (decw_term_port == 0) {
4019         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4020         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4021         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4022
4023        status = lib$find_image_symbol
4024                                (&filename1_dsc,
4025                                 &decw_term_port_dsc,
4026                                 (void *)&decw_term_port,
4027                                 NULL,
4028                                 0);
4029
4030         /* Try again with the other image name */
4031         if (!$VMS_STATUS_SUCCESS(status)) {
4032
4033            status = lib$find_image_symbol
4034                                (&filename2_dsc,
4035                                 &decw_term_port_dsc,
4036                                 (void *)&decw_term_port,
4037                                 NULL,
4038                                 0);
4039
4040         }
4041
4042     }
4043
4044
4045     /* No decw$term_port, give it up */
4046     if (!$VMS_STATUS_SUCCESS(status))
4047         return NULL;
4048
4049     /* Are we on a workstation? */
4050     /* to do: capture the rows / columns and pass their properties */
4051     ret_stat = vms_is_syscommand_xterm();
4052     if (ret_stat < 0)
4053         return NULL;
4054
4055     /* Make the title: */
4056     ret_char = strstr(cptr,"-title");
4057     if (ret_char != NULL) {
4058         while ((*cptr != 0) && (*cptr != '\"')) {
4059             cptr++;
4060         }
4061         if (*cptr == '\"')
4062             cptr++;
4063         n = 0;
4064         while ((*cptr != 0) && (*cptr != '\"')) {
4065             title[n] = *cptr;
4066             n++;
4067             if (n == 39) {
4068                 title[39] = 0;
4069                 break;
4070             }
4071             cptr++;
4072         }
4073         title[n] = 0;
4074     }
4075     else {
4076             /* Default title */
4077             strcpy(title,"Perl Debug DECTerm");
4078     }
4079     sprintf(customization, cust_str, title);
4080
4081     customization_dsc.dsc$a_pointer = customization;
4082     customization_dsc.dsc$w_length = strlen(customization);
4083     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4084     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4085
4086     device_name_dsc.dsc$a_pointer = device_name;
4087     device_name_dsc.dsc$w_length = sizeof device_name -1;
4088     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4089     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4090
4091     device_name_len = 0;
4092
4093     /* Try to create the window */
4094      status = (*decw_term_port)
4095        (NULL,
4096         NULL,
4097         &customization_dsc,
4098         &device_name_dsc,
4099         &device_name_len,
4100         NULL,
4101         NULL,
4102         NULL);
4103     if (!$VMS_STATUS_SUCCESS(status)) {
4104         SETERRNO(EVMSERR, status);
4105         return NULL;
4106     }
4107
4108     device_name[device_name_len] = '\0';
4109
4110     /* Need to set this up to look like a pipe for cleanup */
4111     n = sizeof(Info);
4112     status = lib$get_vm(&n, &info);
4113     if (!$VMS_STATUS_SUCCESS(status)) {
4114         SETERRNO(ENOMEM, status);
4115         return NULL;
4116     }
4117
4118     info->mode = *mode;
4119     info->done = FALSE;
4120     info->completion = 0;
4121     info->closing    = FALSE;
4122     info->in         = 0;
4123     info->out        = 0;
4124     info->err        = 0;
4125     info->fp         = NULL;
4126     info->useFILE    = 0;
4127     info->waiting    = 0;
4128     info->in_done    = TRUE;
4129     info->out_done   = TRUE;
4130     info->err_done   = TRUE;
4131
4132     /* Assign a channel on this so that it will persist, and not login */
4133     /* We stash this channel in the info structure for reference. */
4134     /* The created xterm self destructs when the last channel is removed */
4135     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4136     /* So leave this assigned. */
4137     device_name_dsc.dsc$w_length = device_name_len;
4138     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4139     if (!$VMS_STATUS_SUCCESS(status)) {
4140         SETERRNO(EVMSERR, status);
4141         return NULL;
4142     }
4143     info->xchan_valid = 1;
4144
4145     /* Now create a mailbox to be read by the application */
4146
4147     create_mbx(&p_chan, &d_mbx1);
4148
4149     /* write the name of the created terminal to the mailbox */
4150     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4151             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4152
4153     if (!$VMS_STATUS_SUCCESS(status)) {
4154         SETERRNO(EVMSERR, status);
4155         return NULL;
4156     }
4157
4158     info->fp  = PerlIO_open(mbx1, mode);
4159
4160     /* Done with this channel */
4161     sys$dassgn(p_chan);
4162
4163     /* If any errors, then clean up */
4164     if (!info->fp) {
4165         n = sizeof(Info);
4166         _ckvmssts_noperl(lib$free_vm(&n, &info));
4167         return NULL;
4168         }
4169
4170     /* All done */
4171     return info->fp;
4172 }
4173
4174 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4175
4176 static PerlIO *
4177 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4178 {
4179     static int handler_set_up = FALSE;
4180     PerlIO * ret_fp;
4181     unsigned long int sts, flags = CLI$M_NOWAIT;
4182     /* The use of a GLOBAL table (as was done previously) rendered
4183      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4184      * environment.  Hence we've switched to LOCAL symbol table.
4185      */
4186     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4187     int j, wait = 0, n;
4188     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4189     char *in, *out, *err, mbx[512];
4190     FILE *tpipe = 0;
4191     char tfilebuf[NAM$C_MAXRSS+1];
4192     pInfo info = NULL;
4193     char cmd_sym_name[20];
4194     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4195                                       DSC$K_CLASS_S, symbol};
4196     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4197                                       DSC$K_CLASS_S, 0};
4198     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4199                                       DSC$K_CLASS_S, cmd_sym_name};
4200     struct dsc$descriptor_s *vmscmd;
4201     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4202     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4203     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4204
4205     /* Check here for Xterm create request.  This means looking for
4206      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4207      *  is possible to create an xterm.
4208      */
4209     if (*in_mode == 'r') {
4210         PerlIO * xterm_fd;
4211
4212 #if defined(PERL_IMPLICIT_CONTEXT)
4213         /* Can not fork an xterm with a NULL context */
4214         /* This probably could never happen */
4215         xterm_fd = NULL;
4216         if (aTHX != NULL)
4217 #endif
4218         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4219         if (xterm_fd != NULL)
4220             return xterm_fd;
4221     }
4222
4223     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4224
4225     /* once-per-program initialization...
4226        note that the SETAST calls and the dual test of pipe_ef
4227        makes sure that only the FIRST thread through here does
4228        the initialization...all other threads wait until it's
4229        done.
4230
4231        Yeah, uglier than a pthread call, it's got all the stuff inline
4232        rather than in a separate routine.
4233     */
4234
4235     if (!pipe_ef) {
4236         _ckvmssts_noperl(sys$setast(0));
4237         if (!pipe_ef) {
4238             unsigned long int pidcode = JPI$_PID;
4239             $DESCRIPTOR(d_delay, RETRY_DELAY);
4240             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4241             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4242             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4243         }
4244         if (!handler_set_up) {
4245           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4246           handler_set_up = TRUE;
4247         }
4248         _ckvmssts_noperl(sys$setast(1));
4249     }
4250
4251     /* see if we can find a VMSPIPE.COM */
4252
4253     tfilebuf[0] = '@';
4254     vmspipe = find_vmspipe(aTHX);
4255     if (vmspipe) {
4256         strcpy(tfilebuf+1,vmspipe);
4257     } else {        /* uh, oh...we're in tempfile hell */
4258         tpipe = vmspipe_tempfile(aTHX);
4259         if (!tpipe) {       /* a fish popular in Boston */
4260             if (ckWARN(WARN_PIPE)) {
4261                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4262             }
4263         return NULL;
4264         }
4265         fgetname(tpipe,tfilebuf+1,1);
4266     }
4267     vmspipedsc.dsc$a_pointer = tfilebuf;
4268     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4269
4270     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4271     if (!(sts & 1)) {
4272       switch (sts) {
4273         case RMS$_FNF:  case RMS$_DNF:
4274           set_errno(ENOENT); break;
4275         case RMS$_DIR:
4276           set_errno(ENOTDIR); break;
4277         case RMS$_DEV:
4278           set_errno(ENODEV); break;
4279         case RMS$_PRV:
4280           set_errno(EACCES); break;
4281         case RMS$_SYN:
4282           set_errno(EINVAL); break;
4283         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4284           set_errno(E2BIG); break;
4285         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4286           _ckvmssts_noperl(sts); /* fall through */
4287         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4288           set_errno(EVMSERR);
4289       }
4290       set_vaxc_errno(sts);
4291       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4292         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4293       }
4294       *psts = sts;
4295       return NULL;
4296     }
4297     n = sizeof(Info);
4298     _ckvmssts_noperl(lib$get_vm(&n, &info));
4299
4300     strcpy(mode,in_mode);
4301     info->mode = *mode;
4302     info->done = FALSE;
4303     info->completion = 0;
4304     info->closing    = FALSE;
4305     info->in         = 0;
4306     info->out        = 0;
4307     info->err        = 0;
4308     info->fp         = NULL;
4309     info->useFILE    = 0;
4310     info->waiting    = 0;
4311     info->in_done    = TRUE;
4312     info->out_done   = TRUE;
4313     info->err_done   = TRUE;
4314     info->xchan      = 0;
4315     info->xchan_valid = 0;
4316
4317     in = PerlMem_malloc(VMS_MAXRSS);
4318     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4319     out = PerlMem_malloc(VMS_MAXRSS);
4320     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4321     err = PerlMem_malloc(VMS_MAXRSS);
4322     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4323
4324     in[0] = out[0] = err[0] = '\0';
4325
4326     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4327         info->useFILE = 1;
4328         strcpy(p,p+1);
4329     }
4330     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4331         wait = 1;
4332         strcpy(p,p+1);
4333     }
4334
4335     if (*mode == 'r') {             /* piping from subroutine */
4336
4337         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4338         if (info->out) {
4339             info->out->pipe_done = &info->out_done;
4340             info->out_done = FALSE;
4341             info->out->info = info;
4342         }
4343         if (!info->useFILE) {
4344             info->fp  = PerlIO_open(mbx, mode);
4345         } else {
4346             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4347             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4348         }
4349
4350         if (!info->fp && info->out) {
4351             sys$cancel(info->out->chan_out);
4352
4353             while (!info->out_done) {
4354                 int done;
4355                 _ckvmssts_noperl(sys$setast(0));
4356                 done = info->out_done;
4357                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4358                 _ckvmssts_noperl(sys$setast(1));
4359                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4360             }
4361
4362             if (info->out->buf) {
4363                 n = info->out->bufsize * sizeof(char);
4364                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4365             }
4366             n = sizeof(Pipe);
4367             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4368             n = sizeof(Info);
4369             _ckvmssts_noperl(lib$free_vm(&n, &info));
4370             *psts = RMS$_FNF;
4371             return NULL;
4372         }
4373
4374         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4375         if (info->err) {
4376             info->err->pipe_done = &info->err_done;
4377             info->err_done = FALSE;
4378             info->err->info = info;
4379         }
4380
4381     } else if (*mode == 'w') {      /* piping to subroutine */
4382
4383         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4384         if (info->out) {
4385             info->out->pipe_done = &info->out_done;
4386             info->out_done = FALSE;
4387             info->out->info = info;
4388         }
4389
4390         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4391         if (info->err) {
4392             info->err->pipe_done = &info->err_done;
4393             info->err_done = FALSE;
4394             info->err->info = info;
4395         }
4396
4397         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4398         if (!info->useFILE) {
4399             info->fp  = PerlIO_open(mbx, mode);
4400         } else {
4401             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4402             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4403         }
4404
4405         if (info->in) {
4406             info->in->pipe_done = &info->in_done;
4407             info->in_done = FALSE;
4408             info->in->info = info;
4409         }
4410
4411         /* error cleanup */
4412         if (!info->fp && info->in) {
4413             info->done = TRUE;
4414             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4415                                       0, 0, 0, 0, 0, 0, 0, 0));
4416
4417             while (!info->in_done) {
4418                 int done;
4419                 _ckvmssts_noperl(sys$setast(0));
4420                 done = info->in_done;
4421                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4422                 _ckvmssts_noperl(sys$setast(1));
4423                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4424             }
4425
4426             if (info->in->buf) {
4427                 n = info->in->bufsize * sizeof(char);
4428                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4429             }
4430             n = sizeof(Pipe);
4431             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4432             n = sizeof(Info);
4433             _ckvmssts_noperl(lib$free_vm(&n, &info));
4434             *psts = RMS$_FNF;
4435             return NULL;
4436         }
4437
4438
4439     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4440         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4441         if (info->out) {
4442             info->out->pipe_done = &info->out_done;
4443             info->out_done = FALSE;
4444             info->out->info = info;
4445         }
4446
4447         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4448         if (info->err) {
4449             info->err->pipe_done = &info->err_done;
4450             info->err_done = FALSE;
4451             info->err->info = info;
4452         }
4453     }
4454
4455     symbol[MAX_DCL_SYMBOL] = '\0';
4456
4457     strncpy(symbol, in, MAX_DCL_SYMBOL);
4458     d_symbol.dsc$w_length = strlen(symbol);
4459     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4460
4461     strncpy(symbol, err, MAX_DCL_SYMBOL);
4462     d_symbol.dsc$w_length = strlen(symbol);
4463     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4464
4465     strncpy(symbol, out, MAX_DCL_SYMBOL);
4466     d_symbol.dsc$w_length = strlen(symbol);
4467     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4468
4469     /* Done with the names for the pipes */
4470     PerlMem_free(err);
4471     PerlMem_free(out);
4472     PerlMem_free(in);
4473
4474     p = vmscmd->dsc$a_pointer;
4475     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4476     if (*p == '$') p++;                         /* remove leading $ */
4477     while (*p == ' ' || *p == '\t') p++;
4478
4479     for (j = 0; j < 4; j++) {
4480         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4481         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4482
4483     strncpy(symbol, p, MAX_DCL_SYMBOL);
4484     d_symbol.dsc$w_length = strlen(symbol);
4485     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4486
4487         if (strlen(p) > MAX_DCL_SYMBOL) {
4488             p += MAX_DCL_SYMBOL;
4489         } else {
4490             p += strlen(p);
4491         }
4492     }
4493     _ckvmssts_noperl(sys$setast(0));
4494     info->next=open_pipes;  /* prepend to list */
4495     open_pipes=info;
4496     _ckvmssts_noperl(sys$setast(1));
4497     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4498      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4499      * have SYS$COMMAND if we need it.
4500      */
4501     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4502                       0, &info->pid, &info->completion,
4503                       0, popen_completion_ast,info,0,0,0));
4504
4505     /* if we were using a tempfile, close it now */
4506
4507     if (tpipe) fclose(tpipe);
4508
4509     /* once the subprocess is spawned, it has copied the symbols and
4510        we can get rid of ours */
4511
4512     for (j = 0; j < 4; j++) {
4513         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4514         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4515     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4516     }
4517     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4518     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4519     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4520     vms_execfree(vmscmd);
4521
4522 #ifdef PERL_IMPLICIT_CONTEXT
4523     if (aTHX)
4524 #endif
4525     PL_forkprocess = info->pid;
4526
4527     ret_fp = info->fp;
4528     if (wait) {
4529          dSAVEDERRNO;
4530          int done = 0;
4531          while (!done) {
4532              _ckvmssts_noperl(sys$setast(0));
4533              done = info->done;
4534              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4535              _ckvmssts_noperl(sys$setast(1));
4536              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4537          }
4538         *psts = info->completion;
4539 /* Caller thinks it is open and tries to close it. */
4540 /* This causes some problems, as it changes the error status */
4541 /*        my_pclose(info->fp); */
4542
4543          /* If we did not have a file pointer open, then we have to */
4544          /* clean up here or eventually we will run out of something */
4545          SAVE_ERRNO;
4546          if (info->fp == NULL) {
4547              my_pclose_pinfo(aTHX_ info);
4548          }
4549          RESTORE_ERRNO;
4550
4551     } else {
4552         *psts = info->pid;
4553     }
4554     return ret_fp;
4555 }  /* end of safe_popen */
4556
4557
4558 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4559 PerlIO *
4560 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4561 {
4562     int sts;
4563     TAINT_ENV();
4564     TAINT_PROPER("popen");
4565     PERL_FLUSHALL_FOR_CHILD;
4566     return safe_popen(aTHX_ cmd,mode,&sts);
4567 }
4568
4569 /*}}}*/
4570
4571
4572 /* Routine to close and cleanup a pipe info structure */
4573
4574 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4575
4576     unsigned long int retsts;
4577     int done, n;
4578     pInfo next, last;
4579
4580     /* If we were writing to a subprocess, insure that someone reading from
4581      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4582      * produce an EOF record in the mailbox.
4583      *
4584      *  well, at least sometimes it *does*, so we have to watch out for
4585      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4586      */
4587      if (info->fp) {
4588         if (!info->useFILE
4589 #if defined(USE_ITHREADS)
4590           && my_perl
4591 #endif
4592 #ifdef USE_PERLIO
4593           && PL_perlio_fd_refcnt
4594 #endif
4595            )
4596             PerlIO_flush(info->fp);
4597         else
4598             fflush((FILE *)info->fp);
4599     }
4600
4601     _ckvmssts(sys$setast(0));
4602      info->closing = TRUE;
4603      done = info->done && info->in_done && info->out_done && info->err_done;
4604      /* hanging on write to Perl's input? cancel it */
4605      if (info->mode == 'r' && info->out && !info->out_done) {
4606         if (info->out->chan_out) {
4607             _ckvmssts(sys$cancel(info->out->chan_out));
4608             if (!info->out->chan_in) {   /* EOF generation, need AST */
4609                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4610             }
4611         }
4612      }
4613      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4614          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4615                            0, 0, 0, 0, 0, 0));
4616     _ckvmssts(sys$setast(1));
4617     if (info->fp) {
4618      if (!info->useFILE
4619 #if defined(USE_ITHREADS)
4620          && my_perl
4621 #endif
4622 #ifdef USE_PERLIO
4623          && PL_perlio_fd_refcnt
4624 #endif
4625         )
4626         PerlIO_close(info->fp);
4627      else
4628         fclose((FILE *)info->fp);
4629     }
4630      /*
4631         we have to wait until subprocess completes, but ALSO wait until all
4632         the i/o completes...otherwise we'll be freeing the "info" structure
4633         that the i/o ASTs could still be using...
4634      */
4635
4636      while (!done) {
4637          _ckvmssts(sys$setast(0));
4638          done = info->done && info->in_done && info->out_done && info->err_done;
4639          if (!done) _ckvmssts(sys$clref(pipe_ef));
4640          _ckvmssts(sys$setast(1));
4641          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4642      }
4643      retsts = info->completion;
4644
4645     /* remove from list of open pipes */
4646     _ckvmssts(sys$setast(0));
4647     last = NULL;
4648     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4649         if (next == info)
4650             break;
4651     }
4652
4653     if (last)
4654         last->next = info->next;
4655     else
4656         open_pipes = info->next;
4657     _ckvmssts(sys$setast(1));
4658
4659     /* free buffers and structures */
4660
4661     if (info->in) {
4662         if (info->in->buf) {
4663             n = info->in->bufsize * sizeof(char);
4664             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4665         }
4666         n = sizeof(Pipe);
4667         _ckvmssts(lib$free_vm(&n, &info->in));
4668     }
4669     if (info->out) {
4670         if (info->out->buf) {
4671             n = info->out->bufsize * sizeof(char);
4672             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4673         }
4674         n = sizeof(Pipe);
4675         _ckvmssts(lib$free_vm(&n, &info->out));
4676     }
4677     if (info->err) {
4678         if (info->err->buf) {
4679             n = info->err->bufsize * sizeof(char);
4680             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4681         }
4682         n = sizeof(Pipe);
4683         _ckvmssts(lib$free_vm(&n, &info->err));
4684     }
4685     n = sizeof(Info);
4686     _ckvmssts(lib$free_vm(&n, &info));
4687
4688     return retsts;
4689 }
4690
4691
4692 /*{{{  I32 my_pclose(PerlIO *fp)*/
4693 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4694 {
4695     pInfo info, last = NULL;
4696     I32 ret_status;
4697
4698     /* Fixme - need ast and mutex protection here */
4699     for (info = open_pipes; info != NULL; last = info, info = info->next)
4700         if (info->fp == fp) break;
4701
4702     if (info == NULL) {  /* no such pipe open */
4703       set_errno(ECHILD); /* quoth POSIX */
4704       set_vaxc_errno(SS$_NONEXPR);
4705       return -1;
4706     }
4707
4708     ret_status = my_pclose_pinfo(aTHX_ info);
4709
4710     return ret_status;
4711
4712 }  /* end of my_pclose() */
4713
4714 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4715   /* Roll our own prototype because we want this regardless of whether
4716    * _VMS_WAIT is defined.
4717    */
4718   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4719 #endif
4720 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4721    created with popen(); otherwise partially emulate waitpid() unless
4722    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4723    Also check processes not considered by the CRTL waitpid().
4724  */
4725 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4726 Pid_t
4727 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4728 {
4729     pInfo info;
4730     int done;
4731     int sts;
4732     int j;
4733
4734     if (statusp) *statusp = 0;
4735
4736     for (info = open_pipes; info != NULL; info = info->next)
4737         if (info->pid == pid) break;
4738
4739     if (info != NULL) {  /* we know about this child */
4740       while (!info->done) {
4741           _ckvmssts(sys$setast(0));
4742           done = info->done;
4743           if (!done) _ckvmssts(sys$clref(pipe_ef));
4744           _ckvmssts(sys$setast(1));
4745           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4746       }
4747
4748       if (statusp) *statusp = info->completion;
4749       return pid;
4750     }
4751
4752     /* child that already terminated? */
4753
4754     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4755         if (closed_list[j].pid == pid) {
4756             if (statusp) *statusp = closed_list[j].completion;
4757             return pid;
4758         }
4759     }
4760
4761     /* fall through if this child is not one of our own pipe children */
4762
4763 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4764
4765       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4766        * in 7.2 did we get a version that fills in the VMS completion
4767        * status as Perl has always tried to do.
4768        */
4769
4770       sts = __vms_waitpid( pid, statusp, flags );
4771
4772       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4773          return sts;
4774
4775       /* If the real waitpid tells us the child does not exist, we
4776        * fall through here to implement waiting for a child that
4777        * was created by some means other than exec() (say, spawned
4778        * from DCL) or to wait for a process that is not a subprocess
4779        * of the current process.
4780        */
4781
4782 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4783
4784     {
4785       $DESCRIPTOR(intdsc,"0 00:00:01");
4786       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4787       unsigned long int pidcode = JPI$_PID, mypid;
4788       unsigned long int interval[2];
4789       unsigned int jpi_iosb[2];
4790       struct itmlst_3 jpilist[2] = {
4791           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4792           {                      0,         0,                 0, 0}
4793       };
4794
4795       if (pid <= 0) {
4796         /* Sorry folks, we don't presently implement rooting around for
4797            the first child we can find, and we definitely don't want to
4798            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4799          */
4800         set_errno(ENOTSUP);
4801         return -1;
4802       }
4803
4804       /* Get the owner of the child so I can warn if it's not mine. If the
4805        * process doesn't exist or I don't have the privs to look at it,
4806        * I can go home early.
4807        */
4808       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4809       if (sts & 1) sts = jpi_iosb[0];
4810       if (!(sts & 1)) {
4811         switch (sts) {
4812             case SS$_NONEXPR:
4813                 set_errno(ECHILD);
4814                 break;
4815             case SS$_NOPRIV:
4816                 set_errno(EACCES);
4817                 break;
4818             default:
4819                 _ckvmssts(sts);
4820         }
4821         set_vaxc_errno(sts);
4822         return -1;
4823       }
4824
4825       if (ckWARN(WARN_EXEC)) {
4826         /* remind folks they are asking for non-standard waitpid behavior */
4827         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4828         if (ownerpid != mypid)
4829           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4830                       "waitpid: process %x is not a child of process %x",
4831                       pid,mypid);
4832       }
4833
4834       /* simply check on it once a second until it's not there anymore. */
4835
4836       _ckvmssts(sys$bintim(&intdsc,interval));
4837       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4838             _ckvmssts(sys$schdwk(0,0,interval,0));
4839             _ckvmssts(sys$hiber());
4840       }
4841       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4842
4843       _ckvmssts(sts);
4844       return pid;
4845     }
4846 }  /* end of waitpid() */
4847 /*}}}*/
4848 /*}}}*/
4849 /*}}}*/
4850
4851 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4852 char *
4853 my_gconvert(double val, int ndig, int trail, char *buf)
4854 {
4855   static char __gcvtbuf[DBL_DIG+1];
4856   char *loc;
4857
4858   loc = buf ? buf : __gcvtbuf;
4859
4860 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4861   if (val < 1) {
4862     sprintf(loc,"%.*g",ndig,val);
4863     return loc;
4864   }
4865 #endif
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(__VAX) || !defined(NAML$C_MAXRSS)
4880 static int rms_free_search_context(struct FAB * fab)
4881 {
4882 struct NAM * nam;
4883
4884     nam = fab->fab$l_nam;
4885     nam->nam$b_nop |= NAM$M_SYNCHK;
4886     nam->nam$l_rlf = NULL;
4887     fab->fab$b_dns = 0;
4888     return sys$parse(fab, NULL, NULL);
4889 }
4890
4891 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4892 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4893 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4894 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4895 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4896 #define rms_nam_esll(nam) nam.nam$b_esl
4897 #define rms_nam_esl(nam) nam.nam$b_esl
4898 #define rms_nam_name(nam) nam.nam$l_name
4899 #define rms_nam_namel(nam) nam.nam$l_name
4900 #define rms_nam_type(nam) nam.nam$l_type
4901 #define rms_nam_typel(nam) nam.nam$l_type
4902 #define rms_nam_ver(nam) nam.nam$l_ver
4903 #define rms_nam_verl(nam) nam.nam$l_ver
4904 #define rms_nam_rsll(nam) nam.nam$b_rsl
4905 #define rms_nam_rsl(nam) nam.nam$b_rsl
4906 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4907 #define rms_set_fna(fab, nam, name, size) \
4908         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4909 #define rms_get_fna(fab, nam) fab.fab$l_fna
4910 #define rms_set_dna(fab, nam, name, size) \
4911         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4912 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4913 #define rms_set_esa(nam, name, size) \
4914         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4915 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4916         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4917 #define rms_set_rsa(nam, name, size) \
4918         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4919 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4920         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4921 #define rms_nam_name_type_l_size(nam) \
4922         (nam.nam$b_name + nam.nam$b_type)
4923 #else
4924 static int rms_free_search_context(struct FAB * fab)
4925 {
4926 struct NAML * nam;
4927
4928     nam = fab->fab$l_naml;
4929     nam->naml$b_nop |= NAM$M_SYNCHK;
4930     nam->naml$l_rlf = NULL;
4931     nam->naml$l_long_defname_size = 0;
4932
4933     fab->fab$b_dns = 0;
4934     return sys$parse(fab, NULL, NULL);
4935 }
4936
4937 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4938 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4939 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4940 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4941 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4942 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4943 #define rms_nam_esl(nam) nam.naml$b_esl
4944 #define rms_nam_name(nam) nam.naml$l_name
4945 #define rms_nam_namel(nam) nam.naml$l_long_name
4946 #define rms_nam_type(nam) nam.naml$l_type
4947 #define rms_nam_typel(nam) nam.naml$l_long_type
4948 #define rms_nam_ver(nam) nam.naml$l_ver
4949 #define rms_nam_verl(nam) nam.naml$l_long_ver
4950 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4951 #define rms_nam_rsl(nam) nam.naml$b_rsl
4952 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4953 #define rms_set_fna(fab, nam, name, size) \
4954         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4955         nam.naml$l_long_filename_size = size; \
4956         nam.naml$l_long_filename = name;}
4957 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4958 #define rms_set_dna(fab, nam, name, size) \
4959         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4960         nam.naml$l_long_defname_size = size; \
4961         nam.naml$l_long_defname = name; }
4962 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4963 #define rms_set_esa(nam, name, size) \
4964         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4965         nam.naml$l_long_expand_alloc = size; \
4966         nam.naml$l_long_expand = name; }
4967 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4968         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4969         nam.naml$l_long_expand = l_name; \
4970         nam.naml$l_long_expand_alloc = l_size; }
4971 #define rms_set_rsa(nam, name, size) \
4972         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4973         nam.naml$l_long_result = name; \
4974         nam.naml$l_long_result_alloc = size; }
4975 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4976         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4977         nam.naml$l_long_result = l_name; \
4978         nam.naml$l_long_result_alloc = l_size; }
4979 #define rms_nam_name_type_l_size(nam) \
4980         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4981 #endif
4982
4983
4984 /* rms_erase
4985  * The CRTL for 8.3 and later can create symbolic links in any mode,
4986  * however in 8.3 the unlink/remove/delete routines will only properly handle
4987  * them if one of the PCP modes is active.
4988  */
4989 static int rms_erase(const char * vmsname)
4990 {
4991   int status;
4992   struct FAB myfab = cc$rms_fab;
4993   rms_setup_nam(mynam);
4994
4995   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4996   rms_bind_fab_nam(myfab, mynam);
4997
4998 #ifdef NAML$M_OPEN_SPECIAL
4999   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5000 #endif
5001
5002   status = sys$erase(&myfab, 0, 0);
5003
5004   return status;
5005 }
5006
5007
5008 static int
5009 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5010                     const struct dsc$descriptor_s * vms_dst_dsc,
5011                     unsigned long flags)
5012 {
5013     /*  VMS and UNIX handle file permissions differently and the
5014      * the same ACL trick may be needed for renaming files,
5015      * especially if they are directories.
5016      */
5017
5018    /* todo: get kill_file and rename to share common code */
5019    /* I can not find online documentation for $change_acl
5020     * it appears to be replaced by $set_security some time ago */
5021
5022 const unsigned int access_mode = 0;
5023 $DESCRIPTOR(obj_file_dsc,"FILE");
5024 char *vmsname;
5025 char *rslt;
5026 unsigned long int jpicode = JPI$_UIC;
5027 int aclsts, fndsts, rnsts = -1;
5028 unsigned int ctx = 0;
5029 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5030 struct dsc$descriptor_s * clean_dsc;
5031
5032 struct myacedef {
5033     unsigned char myace$b_length;
5034     unsigned char myace$b_type;
5035     unsigned short int myace$w_flags;
5036     unsigned long int myace$l_access;
5037     unsigned long int myace$l_ident;
5038 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5039              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5040              0},
5041              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5042
5043 struct item_list_3
5044         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5045                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5046                       {0,0,0,0}},
5047         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5048         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5049                      {0,0,0,0}};
5050
5051
5052     /* Expand the input spec using RMS, since we do not want to put
5053      * ACLs on the target of a symbolic link */
5054     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5055     if (vmsname == NULL)
5056         return SS$_INSFMEM;
5057
5058     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5059                         vmsname,
5060                         PERL_RMSEXPAND_M_SYMLINK);
5061     if (rslt == NULL) {
5062         PerlMem_free(vmsname);
5063         return SS$_INSFMEM;
5064     }
5065
5066     /* So we get our own UIC to use as a rights identifier,
5067      * and the insert an ACE at the head of the ACL which allows us
5068      * to delete the file.
5069      */
5070     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5071
5072     fildsc.dsc$w_length = strlen(vmsname);
5073     fildsc.dsc$a_pointer = vmsname;
5074     ctx = 0;
5075     newace.myace$l_ident = oldace.myace$l_ident;
5076     rnsts = SS$_ABORT;
5077
5078     /* Grab any existing ACEs with this identifier in case we fail */
5079     clean_dsc = &fildsc;
5080     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5081                                &fildsc,
5082                                NULL,
5083                                OSS$M_WLOCK,
5084                                findlst,
5085                                &ctx,
5086                                &access_mode);
5087
5088     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5089         /* Add the new ACE . . . */
5090
5091         /* if the sys$get_security succeeded, then ctx is valid, and the
5092          * object/file descriptors will be ignored.  But otherwise they
5093          * are needed
5094          */
5095         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5096                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5097         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5098             set_errno(EVMSERR);
5099             set_vaxc_errno(aclsts);
5100             PerlMem_free(vmsname);
5101             return aclsts;
5102         }
5103
5104         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5105                                 NULL, NULL,
5106                                 &flags,
5107                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5108
5109         if ($VMS_STATUS_SUCCESS(rnsts)) {
5110             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5111         }
5112
5113         /* Put things back the way they were. */
5114         ctx = 0;
5115         aclsts = sys$get_security(&obj_file_dsc,
5116                                   clean_dsc,
5117                                   NULL,
5118                                   OSS$M_WLOCK,
5119                                   findlst,
5120                                   &ctx,
5121                                   &access_mode);
5122
5123         if ($VMS_STATUS_SUCCESS(aclsts)) {
5124         int sec_flags;
5125
5126             sec_flags = 0;
5127             if (!$VMS_STATUS_SUCCESS(fndsts))
5128                 sec_flags = OSS$M_RELCTX;
5129
5130             /* Get rid of the new ACE */
5131             aclsts = sys$set_security(NULL, NULL, NULL,
5132                                   sec_flags, dellst, &ctx, &access_mode);
5133
5134             /* If there was an old ACE, put it back */
5135             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5136                 addlst[0].bufadr = &oldace;
5137                 aclsts = sys$set_security(NULL, NULL, NULL,
5138                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5139                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5140                     set_errno(EVMSERR);
5141                     set_vaxc_errno(aclsts);
5142                     rnsts = aclsts;
5143                 }
5144             } else {
5145             int aclsts2;
5146
5147                 /* Try to clear the lock on the ACL list */
5148                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5149                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5150
5151                 /* Rename errors are most important */
5152                 if (!$VMS_STATUS_SUCCESS(rnsts))
5153                     aclsts = rnsts;
5154                 set_errno(EVMSERR);
5155                 set_vaxc_errno(aclsts);
5156                 rnsts = aclsts;
5157             }
5158         }
5159         else {
5160             if (aclsts != SS$_ACLEMPTY)
5161                 rnsts = aclsts;
5162         }
5163     }
5164     else
5165         rnsts = fndsts;
5166
5167     PerlMem_free(vmsname);
5168     return rnsts;
5169 }
5170
5171
5172 /*{{{int rename(const char *, const char * */
5173 /* Not exactly what X/Open says to do, but doing it absolutely right
5174  * and efficiently would require a lot more work.  This should be close
5175  * enough to pass all but the most strict X/Open compliance test.
5176  */
5177 int
5178 Perl_rename(pTHX_ const char *src, const char * dst)
5179 {
5180 int retval;
5181 int pre_delete = 0;
5182 int src_sts;
5183 int dst_sts;
5184 Stat_t src_st;
5185 Stat_t dst_st;
5186
5187     /* Validate the source file */
5188     src_sts = flex_lstat(src, &src_st);
5189     if (src_sts != 0) {
5190
5191         /* No source file or other problem */
5192         return src_sts;
5193     }
5194     if (src_st.st_devnam[0] == 0)  {
5195         /* This may be possible so fail if it is seen. */
5196         errno = EIO;
5197         return -1;
5198     }
5199
5200     dst_sts = flex_lstat(dst, &dst_st);
5201     if (dst_sts == 0) {
5202
5203         if (dst_st.st_dev != src_st.st_dev) {
5204             /* Must be on the same device */
5205             errno = EXDEV;
5206             return -1;
5207         }
5208
5209         /* VMS_INO_T_COMPARE is true if the inodes are different
5210          * to match the output of memcmp
5211          */
5212
5213         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5214             /* That was easy, the files are the same! */
5215             return 0;
5216         }
5217
5218         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5219             /* If source is a directory, so must be dest */
5220                 errno = EISDIR;
5221                 return -1;
5222         }
5223
5224     }
5225
5226
5227     if ((dst_sts == 0) &&
5228         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5229
5230         /* We have issues here if vms_unlink_all_versions is set
5231          * If the destination exists, and is not a directory, then
5232          * we must delete in advance.
5233          *
5234          * If the src is a directory, then we must always pre-delete
5235          * the destination.
5236          *
5237          * If we successfully delete the dst in advance, and the rename fails
5238          * X/Open requires that errno be EIO.
5239          *
5240          */
5241
5242         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5243             int d_sts;
5244             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5245                                      S_ISDIR(dst_st.st_mode));
5246
5247            /* Need to delete all versions ? */
5248            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5249                 int i = 0;
5250
5251                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5252                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5253                     if (d_sts != 0)
5254                         break;
5255                     i++;
5256
5257                     /* Make sure that we do not loop forever */
5258                     if (i > 32767) {
5259                         errno = EIO;
5260                         d_sts = -1;
5261                         break;
5262                     }
5263                 }
5264            }
5265
5266             if (d_sts != 0)
5267                 return d_sts;
5268
5269             /* We killed the destination, so only errno now is EIO */
5270             pre_delete = 1;
5271         }
5272     }
5273
5274     /* Originally the idea was to call the CRTL rename() and only
5275      * try the lib$rename_file if it failed.
5276      * It turns out that there are too many variants in what the
5277      * the CRTL rename might do, so only use lib$rename_file
5278      */
5279     retval = -1;
5280
5281     {
5282         /* Is the source and dest both in VMS format */
5283         /* if the source is a directory, then need to fileify */
5284         /*  and dest must be a directory or non-existent. */
5285
5286         char * vms_dst;
5287         int sts;
5288         char * ret_str;
5289         unsigned long flags;
5290         struct dsc$descriptor_s old_file_dsc;
5291         struct dsc$descriptor_s new_file_dsc;
5292
5293         /* We need to modify the src and dst depending
5294          * on if one or more of them are directories.
5295          */
5296
5297         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5298         if (vms_dst == NULL)
5299             _ckvmssts_noperl(SS$_INSFMEM);
5300
5301         if (S_ISDIR(src_st.st_mode)) {
5302         char * ret_str;
5303         char * vms_dir_file;
5304
5305             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5306             if (vms_dir_file == NULL)
5307                 _ckvmssts_noperl(SS$_INSFMEM);
5308
5309             /* If the dest is a directory, we must remove it
5310             if (dst_sts == 0) {
5311                 int d_sts;
5312                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5313                 if (d_sts != 0) {
5314                     PerlMem_free(vms_dst);
5315                     errno = EIO;
5316                     return sts;
5317                 }
5318
5319                 pre_delete = 1;
5320             }
5321
5322            /* The dest must be a VMS file specification */
5323            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5324            if (ret_str == NULL) {
5325                 PerlMem_free(vms_dst);
5326                 errno = EIO;
5327                 return -1;
5328            }
5329
5330             /* The source must be a file specification */
5331             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5332             if (ret_str == NULL) {
5333                 PerlMem_free(vms_dst);
5334                 PerlMem_free(vms_dir_file);
5335                 errno = EIO;
5336                 return -1;
5337             }
5338             PerlMem_free(vms_dst);
5339             vms_dst = vms_dir_file;
5340
5341         } else {
5342             /* File to file or file to new dir */
5343
5344             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5345                 /* VMS pathify a dir target */
5346                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5347                 if (ret_str == NULL) {
5348                     PerlMem_free(vms_dst);
5349                     errno = EIO;
5350                     return -1;
5351                 }
5352             } else {
5353                 char * v_spec, * r_spec, * d_spec, * n_spec;
5354                 char * e_spec, * vs_spec;
5355                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5356
5357                 /* fileify a target VMS file specification */
5358                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5359                 if (ret_str == NULL) {
5360                     PerlMem_free(vms_dst);
5361                     errno = EIO;
5362                     return -1;
5363                 }
5364
5365                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5366                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5367                              &e_len, &vs_spec, &vs_len);
5368                 if (sts == 0) {
5369                      if (e_len == 0) {
5370                          /* Get rid of the version */
5371                          if (vs_len != 0) {
5372                              *vs_spec = '\0';
5373                          }
5374                          /* Need to specify a '.' so that the extension */
5375                          /* is not inherited */
5376                          strcat(vms_dst,".");
5377                      }
5378                 }
5379             }
5380         }
5381
5382         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5383         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5384         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5385         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5386
5387         new_file_dsc.dsc$a_pointer = vms_dst;
5388         new_file_dsc.dsc$w_length = strlen(vms_dst);
5389         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5390         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5391
5392         flags = 0;
5393 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5394         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5395 #endif
5396
5397         sts = lib$rename_file(&old_file_dsc,
5398                               &new_file_dsc,
5399                               NULL, NULL,
5400                               &flags,
5401                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5402         if (!$VMS_STATUS_SUCCESS(sts)) {
5403
5404            /* We could have failed because VMS style permissions do not
5405             * permit renames that UNIX will allow.  Just like the hack
5406             * in for kill_file.
5407             */
5408            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5409         }
5410
5411         PerlMem_free(vms_dst);
5412         if (!$VMS_STATUS_SUCCESS(sts)) {
5413             errno = EIO;
5414             return -1;
5415         }
5416         retval = 0;
5417     }
5418
5419     if (vms_unlink_all_versions) {
5420         /* Now get rid of any previous versions of the source file that
5421          * might still exist
5422          */
5423         int i = 0;
5424         dSAVEDERRNO;
5425         SAVE_ERRNO;
5426         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5427                                    S_ISDIR(src_st.st_mode));
5428         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5429              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5430                                        S_ISDIR(src_st.st_mode));
5431              if (src_sts != 0)
5432                  break;
5433              i++;
5434
5435              /* Make sure that we do not loop forever */
5436              if (i > 32767) {
5437                  src_sts = -1;
5438                  break;
5439              }
5440         }
5441         RESTORE_ERRNO;
5442     }
5443
5444     /* We deleted the destination, so must force the error to be EIO */
5445     if ((retval != 0) && (pre_delete != 0))
5446         errno = EIO;
5447
5448     return retval;
5449 }
5450 /*}}}*/
5451
5452
5453 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5454 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5455  * to expand file specification.  Allows for a single default file
5456  * specification and a simple mask of options.  If outbuf is non-NULL,
5457  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5458  * the resultant file specification is placed.  If outbuf is NULL, the
5459  * resultant file specification is placed into a static buffer.
5460  * The third argument, if non-NULL, is taken to be a default file
5461  * specification string.  The fourth argument is unused at present.
5462  * rmesexpand() returns the address of the resultant string if
5463  * successful, and NULL on error.
5464  *
5465  * New functionality for previously unused opts value:
5466  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5467  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5468  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5469  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5470  */
5471 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5472
5473 static char *
5474 int_rmsexpand
5475    (const char *filespec,
5476     char *outbuf,
5477     const char *defspec,
5478     unsigned opts,
5479     int * fs_utf8,
5480     int * dfs_utf8)
5481 {
5482   char * ret_spec;
5483   const char * in_spec;
5484   char * spec_buf;
5485   const char * def_spec;
5486   char * vmsfspec, *vmsdefspec;
5487   char * esa;
5488   char * esal = NULL;
5489   char * outbufl;
5490   struct FAB myfab = cc$rms_fab;
5491   rms_setup_nam(mynam);
5492   STRLEN speclen;
5493   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5494   int sts;
5495
5496   /* temp hack until UTF8 is actually implemented */
5497   if (fs_utf8 != NULL)
5498     *fs_utf8 = 0;
5499
5500   if (!filespec || !*filespec) {
5501     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5502     return NULL;
5503   }
5504
5505   vmsfspec = NULL;
5506   vmsdefspec = NULL;
5507   outbufl = NULL;
5508
5509   in_spec = filespec;
5510   isunix = 0;
5511   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5512       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5513       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5514
5515       /* If this is a UNIX file spec, convert it to VMS */
5516       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5517                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5518                            &e_len, &vs_spec, &vs_len);
5519       if (sts != 0) {
5520           isunix = 1;
5521           char * ret_spec;
5522
5523           vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5524           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5525           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5526           if (ret_spec == NULL) {
5527               PerlMem_free(vmsfspec);
5528               return NULL;
5529           }
5530           in_spec = (const char *)vmsfspec;
5531
5532           /* Unless we are forcing to VMS format, a UNIX input means
5533            * UNIX output, and that requires long names to be used
5534            */
5535           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5536 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5537               opts |= PERL_RMSEXPAND_M_LONG;
5538 #else
5539               NOOP;
5540 #endif
5541           else
5542               isunix = 0;
5543       }
5544
5545   }
5546
5547   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5548   rms_bind_fab_nam(myfab, mynam);
5549
5550   /* Process the default file specification if present */
5551   def_spec = defspec;
5552   if (defspec && *defspec) {
5553     int t_isunix;
5554     t_isunix = is_unix_filespec(defspec);
5555     if (t_isunix) {
5556       vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5557       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5558       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5559
5560       if (ret_spec == NULL) {
5561           /* Clean up and bail */
5562           PerlMem_free(vmsdefspec);
5563           if (vmsfspec != NULL)
5564               PerlMem_free(vmsfspec);
5565               return NULL;
5566           }
5567           def_spec = (const char *)vmsdefspec;
5568       }
5569       rms_set_dna(myfab, mynam,
5570                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5571   }
5572
5573   /* Now we need the expansion buffers */
5574   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5575   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5576 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5577   esal = PerlMem_malloc(VMS_MAXRSS);
5578   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5579 #endif
5580   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5581
5582   /* If a NAML block is used RMS always writes to the long and short
5583    * addresses unless you suppress the short name.
5584    */
5585 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5586   outbufl = PerlMem_malloc(VMS_MAXRSS);
5587   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5588 #endif
5589    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5590
5591 #ifdef NAM$M_NO_SHORT_UPCASE
5592   if (decc_efs_case_preserve)
5593     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5594 #endif
5595
5596    /* We may not want to follow symbolic links */
5597 #ifdef NAML$M_OPEN_SPECIAL
5598   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5599     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5600 #endif
5601
5602   /* First attempt to parse as an existing file */
5603   retsts = sys$parse(&myfab,0,0);
5604   if (!(retsts & STS$K_SUCCESS)) {
5605
5606     /* Could not find the file, try as syntax only if error is not fatal */
5607     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5608     if (retsts == RMS$_DNF ||
5609         retsts == RMS$_DIR ||
5610         retsts == RMS$_DEV ||
5611         retsts == RMS$_PRV) {
5612       retsts = sys$parse(&myfab,0,0);
5613       if (retsts & STS$K_SUCCESS) goto int_expanded;
5614     }
5615
5616      /* Still could not parse the file specification */
5617     /*----------------------------------------------*/
5618     sts = rms_free_search_context(&myfab); /* Free search context */
5619     if (vmsdefspec != NULL)
5620         PerlMem_free(vmsdefspec);
5621     if (vmsfspec != NULL)
5622         PerlMem_free(vmsfspec);
5623     if (outbufl != NULL)
5624         PerlMem_free(outbufl);
5625     PerlMem_free(esa);
5626     if (esal != NULL)
5627         PerlMem_free(esal);
5628     set_vaxc_errno(retsts);
5629     if      (retsts == RMS$_PRV) set_errno(EACCES);
5630     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5631     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5632     else                         set_errno(EVMSERR);
5633     return NULL;
5634   }
5635   retsts = sys$search(&myfab,0,0);
5636   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5637     sts = rms_free_search_context(&myfab); /* Free search context */
5638     if (vmsdefspec != NULL)
5639         PerlMem_free(vmsdefspec);
5640     if (vmsfspec != NULL)
5641         PerlMem_free(vmsfspec);
5642     if (outbufl != NULL)
5643         PerlMem_free(outbufl);
5644     PerlMem_free(esa);
5645     if (esal != NULL)
5646         PerlMem_free(esal);
5647     set_vaxc_errno(retsts);
5648     if      (retsts == RMS$_PRV) set_errno(EACCES);
5649     else                         set_errno(EVMSERR);
5650     return NULL;
5651   }
5652
5653   /* If the input filespec contained any lowercase characters,
5654    * downcase the result for compatibility with Unix-minded code. */
5655 int_expanded:
5656   if (!decc_efs_case_preserve) {
5657     char * tbuf;
5658     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5659       if (islower(*tbuf)) { haslower = 1; break; }
5660   }
5661
5662    /* Is a long or a short name expected */
5663   /*------------------------------------*/
5664   spec_buf = NULL;
5665 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5666   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5667     if (rms_nam_rsll(mynam)) {
5668         spec_buf = outbufl;
5669         speclen = rms_nam_rsll(mynam);
5670     }
5671     else {
5672         spec_buf = esal; /* Not esa */
5673         speclen = rms_nam_esll(mynam);
5674     }
5675   }
5676   else {
5677 #endif
5678     if (rms_nam_rsl(mynam)) {
5679         spec_buf = outbuf;
5680         speclen = rms_nam_rsl(mynam);
5681     }
5682     else {
5683         spec_buf = esa; /* Not esal */
5684         speclen = rms_nam_esl(mynam);
5685     }
5686 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5687   }
5688 #endif
5689   spec_buf[speclen] = '\0';
5690
5691   /* Trim off null fields added by $PARSE
5692    * If type > 1 char, must have been specified in original or default spec
5693    * (not true for version; $SEARCH may have added version of existing file).
5694    */
5695   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5696   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5697     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5698              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5699   }
5700   else {
5701     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5702              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5703   }
5704   if (trimver || trimtype) {
5705     if (defspec && *defspec) {
5706       char *defesal = NULL;
5707       char *defesa = NULL;
5708       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5709       if (defesa != NULL) {
5710         struct FAB deffab = cc$rms_fab;
5711 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5712         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5713         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5714 #endif
5715         rms_setup_nam(defnam);
5716
5717         rms_bind_fab_nam(deffab, defnam);
5718
5719         /* Cast ok */
5720         rms_set_fna
5721             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5722
5723         /* RMS needs the esa/esal as a work area if wildcards are involved */
5724         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5725
5726         rms_clear_nam_nop(defnam);
5727         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5728 #ifdef NAM$M_NO_SHORT_UPCASE
5729         if (decc_efs_case_preserve)
5730           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5731 #endif
5732 #ifdef NAML$M_OPEN_SPECIAL
5733         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5734           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5735 #endif
5736         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5737           if (trimver) {
5738              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5739           }
5740           if (trimtype) {
5741             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5742           }
5743         }
5744         if (defesal != NULL)
5745             PerlMem_free(defesal);
5746         PerlMem_free(defesa);
5747       } else {
5748           _ckvmssts_noperl(SS$_INSFMEM);
5749       }
5750     }
5751     if (trimver) {
5752       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5753         if (*(rms_nam_verl(mynam)) != '\"')
5754           speclen = rms_nam_verl(mynam) - spec_buf;
5755       }
5756       else {
5757         if (*(rms_nam_ver(mynam)) != '\"')
5758           speclen = rms_nam_ver(mynam) - spec_buf;
5759       }
5760     }
5761     if (trimtype) {
5762       /* If we didn't already trim version, copy down */
5763       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5764         if (speclen > rms_nam_verl(mynam) - spec_buf)
5765           memmove
5766            (rms_nam_typel(mynam),
5767             rms_nam_verl(mynam),
5768             speclen - (rms_nam_verl(mynam) - spec_buf));
5769           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5770       }
5771       else {
5772         if (speclen > rms_nam_ver(mynam) - spec_buf)
5773           memmove
5774            (rms_nam_type(mynam),
5775             rms_nam_ver(mynam),
5776             speclen - (rms_nam_ver(mynam) - spec_buf));
5777           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5778       }
5779     }
5780   }
5781
5782    /* Done with these copies of the input files */
5783   /*-------------------------------------------*/
5784   if (vmsfspec != NULL)
5785         PerlMem_free(vmsfspec);
5786   if (vmsdefspec != NULL)
5787         PerlMem_free(vmsdefspec);
5788
5789   /* If we just had a directory spec on input, $PARSE "helpfully"
5790    * adds an empty name and type for us */
5791 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5792   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5793     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5794         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5795         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5796       speclen = rms_nam_namel(mynam) - spec_buf;
5797   }
5798   else
5799 #endif
5800   {
5801     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5802         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5803         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5804       speclen = rms_nam_name(mynam) - spec_buf;
5805   }
5806
5807   /* Posix format specifications must have matching quotes */
5808   if (speclen < (VMS_MAXRSS - 1)) {
5809     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5810       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5811         spec_buf[speclen] = '\"';
5812         speclen++;
5813       }
5814     }
5815   }
5816   spec_buf[speclen] = '\0';
5817   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5818
5819   /* Have we been working with an expanded, but not resultant, spec? */
5820   /* Also, convert back to Unix syntax if necessary. */
5821   {
5822   int rsl;
5823
5824 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5825     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5826       rsl = rms_nam_rsll(mynam);
5827     } else
5828 #endif
5829     {
5830       rsl = rms_nam_rsl(mynam);
5831     }
5832     if (!rsl) {
5833       /* rsl is not present, it means that spec_buf is either */
5834       /* esa or esal, and needs to be copied to outbuf */
5835       /* convert to Unix if desired */
5836       if (isunix) {
5837         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5838       } else {
5839         /* VMS file specs are not in UTF-8 */
5840         if (fs_utf8 != NULL)
5841             *fs_utf8 = 0;
5842         strcpy(outbuf, spec_buf);
5843         ret_spec = outbuf;
5844       }
5845     }
5846     else {
5847       /* Now spec_buf is either outbuf or outbufl */
5848       /* We need the result into outbuf */
5849       if (isunix) {
5850            /* If we need this in UNIX, then we need another buffer */
5851            /* to keep things in order */
5852            char * src;
5853            char * new_src = NULL;
5854            if (spec_buf == outbuf) {
5855                new_src = PerlMem_malloc(VMS_MAXRSS);
5856                strcpy(new_src, spec_buf);
5857            } else {
5858                src = spec_buf;
5859            }
5860            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5861            if (new_src) {
5862                PerlMem_free(new_src);
5863            }
5864       } else {
5865            /* VMS file specs are not in UTF-8 */
5866            if (fs_utf8 != NULL)
5867                *fs_utf8 = 0;
5868
5869            /* Copy the buffer if needed */
5870            if (outbuf != spec_buf)
5871                strcpy(outbuf, spec_buf);
5872            ret_spec = outbuf;
5873       }
5874     }
5875   }
5876
5877   /* Need to clean up the search context */
5878   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5879   sts = rms_free_search_context(&myfab); /* Free search context */
5880
5881   /* Clean up the extra buffers */
5882   if (esal != NULL)
5883       PerlMem_free(esal);
5884   PerlMem_free(esa);
5885   if (outbufl != NULL)
5886      PerlMem_free(outbufl);
5887
5888   /* Return the result */
5889   return ret_spec;
5890 }
5891
5892 /* Common simple case - Expand an already VMS spec */
5893 static char *
5894 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5895     opts |= PERL_RMSEXPAND_M_VMS_IN;
5896     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5897 }
5898
5899 /* Common simple case - Expand to a VMS spec */
5900 static char *
5901 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5902     opts |= PERL_RMSEXPAND_M_VMS;
5903     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5904 }
5905
5906
5907 /* Entry point used by perl routines */
5908 static char *
5909 mp_do_rmsexpand
5910    (pTHX_ const char *filespec,
5911     char *outbuf,
5912     int ts,
5913     const char *defspec,
5914     unsigned opts,
5915     int * fs_utf8,
5916     int * dfs_utf8)
5917 {
5918     static char __rmsexpand_retbuf[VMS_MAXRSS];
5919     char * expanded, *ret_spec, *ret_buf;
5920
5921     expanded = NULL;
5922     ret_buf = outbuf;
5923     if (ret_buf == NULL) {
5924         if (ts) {
5925             Newx(expanded, VMS_MAXRSS, char);
5926             if (expanded == NULL)
5927                 _ckvmssts(SS$_INSFMEM);
5928             ret_buf = expanded;
5929         } else {
5930             ret_buf = __rmsexpand_retbuf;
5931         }
5932     }
5933
5934
5935     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5936                              opts, fs_utf8,  dfs_utf8);
5937
5938     if (ret_spec == NULL) {
5939        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5940        if (expanded)
5941            Safefree(expanded);
5942     }
5943
5944     return ret_spec;
5945 }
5946 /*}}}*/
5947 /* External entry points */
5948 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5949 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5950 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5951 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5952 char *Perl_rmsexpand_utf8
5953   (pTHX_ const char *spec, char *buf, const char *def,
5954    unsigned opt, int * fs_utf8, int * dfs_utf8)
5955 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5956 char *Perl_rmsexpand_utf8_ts
5957   (pTHX_ const char *spec, char *buf, const char *def,
5958    unsigned opt, int * fs_utf8, int * dfs_utf8)
5959 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5960
5961
5962 /*
5963 ** The following routines are provided to make life easier when
5964 ** converting among VMS-style and Unix-style directory specifications.
5965 ** All will take input specifications in either VMS or Unix syntax. On
5966 ** failure, all return NULL.  If successful, the routines listed below
5967 ** return a pointer to a buffer containing the appropriately
5968 ** reformatted spec (and, therefore, subsequent calls to that routine
5969 ** will clobber the result), while the routines of the same names with
5970 ** a _ts suffix appended will return a pointer to a mallocd string
5971 ** containing the appropriately reformatted spec.
5972 ** In all cases, only explicit syntax is altered; no check is made that
5973 ** the resulting string is valid or that the directory in question
5974 ** actually exists.
5975 **
5976 **   fileify_dirspec() - convert a directory spec into the name of the
5977 **     directory file (i.e. what you can stat() to see if it's a dir).
5978 **     The style (VMS or Unix) of the result is the same as the style
5979 **     of the parameter passed in.
5980 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5981 **     what you prepend to a filename to indicate what directory it's in).
5982 **     The style (VMS or Unix) of the result is the same as the style
5983 **     of the parameter passed in.
5984 **   tounixpath() - convert a directory spec into a Unix-style path.
5985 **   tovmspath() - convert a directory spec into a VMS-style path.
5986 **   tounixspec() - convert any file spec into a Unix-style file spec.
5987 **   tovmsspec() - convert any file spec into a VMS-style spec.
5988 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5989 **
5990 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5991 ** Permission is given to distribute this code as part of the Perl
5992 ** standard distribution under the terms of the GNU General Public
5993 ** License or the Perl Artistic License.  Copies of each may be
5994 ** found in the Perl standard distribution.
5995  */
5996
5997 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5998 static char *
5999 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
6000 {
6001     unsigned long int dirlen, retlen, hasfilename = 0;
6002     char *cp1, *cp2, *lastdir;
6003     char *trndir, *vmsdir;
6004     unsigned short int trnlnm_iter_count;
6005     int is_vms = 0;
6006     int is_unix = 0;
6007     int sts;
6008     if (utf8_fl != NULL)
6009         *utf8_fl = 0;
6010
6011     if (!dir || !*dir) {
6012       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6013     }
6014     dirlen = strlen(dir);
6015     while (dirlen && dir[dirlen-1] == '/') --dirlen;
6016     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6017       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6018         dir = "/sys$disk";
6019         dirlen = 9;
6020       }
6021       else
6022         dirlen = 1;
6023     }
6024     if (dirlen > (VMS_MAXRSS - 1)) {
6025       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6026       return NULL;
6027     }
6028     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6029     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6030     if (!strpbrk(dir+1,"/]>:")  &&
6031         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6032       strcpy(trndir,*dir == '/' ? dir + 1: dir);
6033       trnlnm_iter_count = 0;
6034       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6035         trnlnm_iter_count++;
6036         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6037       }
6038       dirlen = strlen(trndir);
6039     }
6040     else {
6041       strncpy(trndir,dir,dirlen);
6042       trndir[dirlen] = '\0';
6043     }
6044
6045     /* At this point we are done with *dir and use *trndir which is a
6046      * copy that can be modified.  *dir must not be modified.
6047      */
6048
6049     /* If we were handed a rooted logical name or spec, treat it like a
6050      * simple directory, so that
6051      *    $ Define myroot dev:[dir.]
6052      *    ... do_fileify_dirspec("myroot",buf,1) ...
6053      * does something useful.
6054      */
6055     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6056       trndir[--dirlen] = '\0';
6057       trndir[dirlen-1] = ']';
6058     }
6059     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6060       trndir[--dirlen] = '\0';
6061       trndir[dirlen-1] = '>';
6062     }
6063
6064     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6065       /* If we've got an explicit filename, we can just shuffle the string. */
6066       if (*(cp1+1)) hasfilename = 1;
6067       /* Similarly, we can just back up a level if we've got multiple levels
6068          of explicit directories in a VMS spec which ends with directories. */
6069       else {
6070         for (cp2 = cp1; cp2 > trndir; cp2--) {
6071           if (*cp2 == '.') {
6072             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6073 /* fix-me, can not scan EFS file specs backward like this */
6074               *cp2 = *cp1; *cp1 = '\0';
6075               hasfilename = 1;
6076               break;
6077             }
6078           }
6079           if (*cp2 == '[' || *cp2 == '<') break;
6080         }
6081       }
6082     }
6083
6084     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6085     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6086     cp1 = strpbrk(trndir,"]:>");
6087     if (hasfilename || !cp1) { /* filename present or not VMS */
6088
6089       if (decc_efs_charset && !cp1) {
6090
6091           /* EFS handling for UNIX mode */
6092
6093           /* Just remove the trailing '/' and we should be done */
6094           STRLEN trndir_len;
6095           trndir_len = strlen(trndir);
6096
6097           if (trndir_len > 1) {
6098               trndir_len--;
6099               if (trndir[trndir_len] == '/') {
6100                   trndir[trndir_len] = '\0';
6101               }
6102           }
6103           strcpy(buf, trndir);
6104           PerlMem_free(trndir);
6105           PerlMem_free(vmsdir);
6106           return buf;
6107       }
6108
6109       /* For non-EFS mode, this is left for backwards compatibility */
6110       /* For EFS mode, this is only done for VMS format filespecs as */
6111       /* Perl programs generally have problems when a UNIX format spec */
6112       /* returns a VMS format spec */
6113       if (trndir[0] == '.') {
6114         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6115           PerlMem_free(trndir);
6116           PerlMem_free(vmsdir);
6117           return int_fileify_dirspec("[]", buf, NULL);
6118         }
6119         else if (trndir[1] == '.' &&
6120                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6121           PerlMem_free(trndir);
6122           PerlMem_free(vmsdir);
6123           return int_fileify_dirspec("[-]", buf, NULL);
6124         }
6125       }
6126       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6127         dirlen -= 1;                 /* to last element */
6128         lastdir = strrchr(trndir,'/');
6129       }
6130       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6131         /* If we have "/." or "/..", VMSify it and let the VMS code
6132          * below expand it, rather than repeating the code to handle
6133          * relative components of a filespec here */
6134         do {
6135           if (*(cp1+2) == '.') cp1++;
6136           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6137             char * ret_chr;
6138             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6139                 PerlMem_free(trndir);
6140                 PerlMem_free(vmsdir);
6141                 return NULL;
6142             }
6143             if (strchr(vmsdir,'/') != NULL) {
6144               /* If int_tovmsspec() returned it, it must have VMS syntax
6145                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6146                * the time to check this here only so we avoid a recursion
6147                * loop; otherwise, gigo.
6148                */
6149               PerlMem_free(trndir);
6150               PerlMem_free(vmsdir);
6151               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6152               return NULL;
6153             }
6154             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6155                 PerlMem_free(trndir);
6156                 PerlMem_free(vmsdir);
6157                 return NULL;
6158             }
6159             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6160             PerlMem_free(trndir);
6161             PerlMem_free(vmsdir);
6162             return ret_chr;
6163           }
6164           cp1++;
6165         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6166         lastdir = strrchr(trndir,'/');
6167       }
6168       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6169         char * ret_chr;
6170         /* Ditto for specs that end in an MFD -- let the VMS code
6171          * figure out whether it's a real device or a rooted logical. */
6172
6173         /* This should not happen any more.  Allowing the fake /000000
6174          * in a UNIX pathname causes all sorts of problems when trying
6175          * to run in UNIX emulation.  So the VMS to UNIX conversions
6176          * now remove the fake /000000 directories.
6177          */
6178
6179         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6180         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6181             PerlMem_free(trndir);
6182             PerlMem_free(vmsdir);
6183             return NULL;
6184         }
6185         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6186             PerlMem_free(trndir);
6187             PerlMem_free(vmsdir);
6188             return NULL;
6189         }
6190         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6191         PerlMem_free(trndir);
6192         PerlMem_free(vmsdir);
6193         return ret_chr;
6194       }
6195       else {
6196
6197         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6198              !(lastdir = cp1 = strrchr(trndir,']')) &&
6199              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6200
6201         cp2 = strrchr(cp1,'.');
6202         if (cp2) {
6203             int e_len, vs_len = 0;
6204             int is_dir = 0;
6205             char * cp3;
6206             cp3 = strchr(cp2,';');
6207             e_len = strlen(cp2);
6208             if (cp3) {
6209                 vs_len = strlen(cp3);
6210                 e_len = e_len - vs_len;
6211             }
6212             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6213             if (!is_dir) {
6214                 if (!decc_efs_charset) {
6215                     /* If this is not EFS, then not a directory */
6216                     PerlMem_free(trndir);
6217                     PerlMem_free(vmsdir);
6218                     set_errno(ENOTDIR);
6219                     set_vaxc_errno(RMS$_DIR);
6220                     return NULL;
6221                 }
6222             } else {
6223                 /* Ok, here we have an issue, technically if a .dir shows */
6224                 /* from inside a directory, then we should treat it as */
6225                 /* xxx^.dir.dir.  But we do not have that context at this */
6226                 /* point unless this is totally restructured, so we remove */
6227                 /* The .dir for now, and fix this better later */
6228                 dirlen = cp2 - trndir;
6229             }
6230         }
6231
6232       }
6233
6234       retlen = dirlen + 6;
6235       memcpy(buf, trndir, dirlen);
6236       buf[dirlen] = '\0';
6237
6238       /* We've picked up everything up to the directory file name.
6239          Now just add the type and version, and we're set. */
6240
6241       /* We should only add type for VMS syntax, but historically Perl
6242          has added it for UNIX style also */
6243
6244       /* Fix me - we should not be using the same routine for VMS and
6245          UNIX format files.  Things are too tangled so we need to lookup
6246          what syntax the output is */
6247
6248       is_unix = 0;
6249       is_vms = 0;
6250       lastdir = strrchr(trndir,'/');
6251       if (lastdir) {
6252           is_unix = 1;
6253       } else {
6254           lastdir = strpbrk(trndir,"]:>");
6255           if (lastdir) {
6256               is_vms = 1;
6257           }
6258       }
6259
6260       if ((is_vms == 0) && (is_unix == 0)) {
6261           /* We still do not  know? */
6262           is_unix = decc_filename_unix_report;
6263           if (is_unix == 0)
6264               is_vms = 1;
6265       }
6266
6267       if ((is_unix && !decc_efs_charset) || is_vms) {
6268
6269            /* It is a bug to add a .dir to a UNIX format directory spec */
6270            /* However Perl on VMS may have programs that expect this so */
6271            /* If not using EFS character specifications allow it. */
6272
6273            if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6274                /* Traditionally Perl expects filenames in lower case */
6275                strcat(buf, ".dir");
6276            } else {
6277                /* VMS expects the .DIR to be in upper case */
6278                strcat(buf, ".DIR");
6279            }
6280
6281            /* It is also a bug to put a VMS format version on a UNIX file */
6282            /* specification.  Perl self tests are looking for this */
6283            if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6284                strcat(buf, ";1");
6285       }
6286       PerlMem_free(trndir);
6287       PerlMem_free(vmsdir);
6288       return buf;
6289     }
6290     else {  /* VMS-style directory spec */
6291
6292       char *esa, *esal, term, *cp;
6293       char *my_esa;
6294       int my_esa_len;
6295       unsigned long int cmplen, haslower = 0;
6296       struct FAB dirfab = cc$rms_fab;
6297       rms_setup_nam(savnam);
6298       rms_setup_nam(dirnam);
6299
6300       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6301       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6302       esal = NULL;
6303 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6304       esal = PerlMem_malloc(VMS_MAXRSS);
6305       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6306 #endif
6307       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6308       rms_bind_fab_nam(dirfab, dirnam);
6309       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6310       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6311 #ifdef NAM$M_NO_SHORT_UPCASE
6312       if (decc_efs_case_preserve)
6313         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6314 #endif
6315
6316       for (cp = trndir; *cp; cp++)
6317         if (islower(*cp)) { haslower = 1; break; }
6318       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6319         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6320             (dirfab.fab$l_sts == RMS$_DNF) ||
6321             (dirfab.fab$l_sts == RMS$_PRV)) {
6322             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6323             sts = sys$parse(&dirfab);
6324         }
6325         if (!sts) {
6326           PerlMem_free(esa);
6327           if (esal != NULL)
6328               PerlMem_free(esal);
6329           PerlMem_free(trndir);
6330           PerlMem_free(vmsdir);
6331           set_errno(EVMSERR);
6332           set_vaxc_errno(dirfab.fab$l_sts);
6333           return NULL;
6334         }
6335       }
6336       else {
6337         savnam = dirnam;
6338         /* Does the file really exist? */
6339         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6340           /* Yes; fake the fnb bits so we'll check type below */
6341           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6342         }
6343         else { /* No; just work with potential name */
6344           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6345           else {
6346             int fab_sts;
6347             fab_sts = dirfab.fab$l_sts;
6348             sts = rms_free_search_context(&dirfab);
6349             PerlMem_free(esa);
6350             if (esal != NULL)
6351                 PerlMem_free(esal);
6352             PerlMem_free(trndir);
6353             PerlMem_free(vmsdir);
6354             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6355             return NULL;
6356           }
6357         }
6358       }
6359
6360       /* Make sure we are using the right buffer */
6361 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6362       if (esal != NULL) {
6363         my_esa = esal;
6364         my_esa_len = rms_nam_esll(dirnam);
6365       } else {
6366 #endif
6367         my_esa = esa;
6368         my_esa_len = rms_nam_esl(dirnam);
6369 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6370       }
6371 #endif
6372       my_esa[my_esa_len] = '\0';
6373       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6374         cp1 = strchr(my_esa,']');
6375         if (!cp1) cp1 = strchr(my_esa,'>');
6376         if (cp1) {  /* Should always be true */
6377           my_esa_len -= cp1 - my_esa - 1;
6378           memmove(my_esa, cp1 + 1, my_esa_len);
6379         }
6380       }
6381       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6382         /* Yep; check version while we're at it, if it's there. */
6383         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6384         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6385           /* Something other than .DIR[;1].  Bzzt. */
6386           sts = rms_free_search_context(&dirfab);
6387           PerlMem_free(esa);
6388           if (esal != NULL)
6389              PerlMem_free(esal);
6390           PerlMem_free(trndir);
6391           PerlMem_free(vmsdir);
6392           set_errno(ENOTDIR);
6393           set_vaxc_errno(RMS$_DIR);
6394           return NULL;
6395         }
6396       }
6397
6398       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6399         /* They provided at least the name; we added the type, if necessary, */
6400         strcpy(buf, my_esa);
6401         sts = rms_free_search_context(&dirfab);
6402         PerlMem_free(trndir);
6403         PerlMem_free(esa);
6404         if (esal != NULL)
6405             PerlMem_free(esal);
6406         PerlMem_free(vmsdir);
6407         return buf;
6408       }
6409       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6410         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6411         *cp1 = '\0';
6412         my_esa_len -= 9;
6413       }
6414       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6415       if (cp1 == NULL) { /* should never happen */
6416         sts = rms_free_search_context(&dirfab);
6417         PerlMem_free(trndir);
6418         PerlMem_free(esa);
6419         if (esal != NULL)
6420             PerlMem_free(esal);
6421         PerlMem_free(vmsdir);
6422         return NULL;
6423       }
6424       term = *cp1;
6425       *cp1 = '\0';
6426       retlen = strlen(my_esa);
6427       cp1 = strrchr(my_esa,'.');
6428       /* ODS-5 directory specifications can have extra "." in them. */
6429       /* Fix-me, can not scan EFS file specifications backwards */
6430       while (cp1 != NULL) {
6431         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6432           break;
6433         else {
6434            cp1--;
6435            while ((cp1 > my_esa) && (*cp1 != '.'))
6436              cp1--;
6437         }
6438         if (cp1 == my_esa)
6439           cp1 = NULL;
6440       }
6441
6442       if ((cp1) != NULL) {
6443         /* There's more than one directory in the path.  Just roll back. */
6444         *cp1 = term;
6445         strcpy(buf, my_esa);
6446       }
6447       else {
6448         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6449           /* Go back and expand rooted logical name */
6450           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6451 #ifdef NAM$M_NO_SHORT_UPCASE
6452           if (decc_efs_case_preserve)
6453             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6454 #endif
6455           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6456             sts = rms_free_search_context(&dirfab);
6457             PerlMem_free(esa);
6458             if (esal != NULL)
6459                 PerlMem_free(esal);
6460             PerlMem_free(trndir);
6461             PerlMem_free(vmsdir);
6462             set_errno(EVMSERR);
6463             set_vaxc_errno(dirfab.fab$l_sts);
6464             return NULL;
6465           }
6466
6467           /* This changes the length of the string of course */
6468           if (esal != NULL) {
6469               my_esa_len = rms_nam_esll(dirnam);
6470           } else {
6471               my_esa_len = rms_nam_esl(dirnam);
6472           }
6473
6474           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6475           cp1 = strstr(my_esa,"][");
6476           if (!cp1) cp1 = strstr(my_esa,"]<");
6477           dirlen = cp1 - my_esa;
6478           memcpy(buf, my_esa, dirlen);
6479           if (!strncmp(cp1+2,"000000]",7)) {
6480             buf[dirlen-1] = '\0';
6481             /* fix-me Not full ODS-5, just extra dots in directories for now */
6482             cp1 = buf + dirlen - 1;
6483             while (cp1 > buf)
6484             {
6485               if (*cp1 == '[')
6486                 break;
6487               if (*cp1 == '.') {
6488                 if (*(cp1-1) != '^')
6489                   break;
6490               }
6491               cp1--;
6492             }
6493             if (*cp1 == '.') *cp1 = ']';
6494             else {
6495               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6496               memmove(cp1+1,"000000]",7);
6497             }
6498           }
6499           else {
6500             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6501             buf[retlen] = '\0';
6502             /* Convert last '.' to ']' */
6503             cp1 = buf+retlen-1;
6504             while (*cp != '[') {
6505               cp1--;
6506               if (*cp1 == '.') {
6507                 /* Do not trip on extra dots in ODS-5 directories */
6508                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6509                 break;
6510               }
6511             }
6512             if (*cp1 == '.') *cp1 = ']';
6513             else {
6514               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6515               memmove(cp1+1,"000000]",7);
6516             }
6517           }
6518         }
6519         else {  /* This is a top-level dir.  Add the MFD to the path. */
6520           cp1 = my_esa;
6521           cp2 = buf;
6522           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6523           strcpy(cp2,":[000000]");
6524           cp1 += 2;
6525           strcpy(cp2+9,cp1);
6526         }
6527       }
6528       sts = rms_free_search_context(&dirfab);
6529       /* We've set up the string up through the filename.  Add the
6530          type and version, and we're done. */
6531       strcat(buf,".DIR;1");
6532
6533       /* $PARSE may have upcased filespec, so convert output to lower
6534        * case if input contained any lowercase characters. */
6535       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6536       PerlMem_free(trndir);
6537       PerlMem_free(esa);
6538       if (esal != NULL)
6539         PerlMem_free(esal);
6540       PerlMem_free(vmsdir);
6541       return buf;
6542     }
6543 }  /* end of int_fileify_dirspec() */
6544
6545
6546 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6547 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6548 {
6549     static char __fileify_retbuf[VMS_MAXRSS];
6550     char * fileified, *ret_spec, *ret_buf;
6551
6552     fileified = NULL;
6553     ret_buf = buf;
6554     if (ret_buf == NULL) {
6555         if (ts) {
6556             Newx(fileified, VMS_MAXRSS, char);
6557             if (fileified == NULL)
6558                 _ckvmssts(SS$_INSFMEM);
6559             ret_buf = fileified;
6560         } else {
6561             ret_buf = __fileify_retbuf;
6562         }
6563     }
6564
6565     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6566
6567     if (ret_spec == NULL) {
6568        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6569        if (fileified)
6570            Safefree(fileified);
6571     }
6572
6573     return ret_spec;
6574 }  /* end of do_fileify_dirspec() */
6575 /*}}}*/
6576
6577 /* External entry points */
6578 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6579 { return do_fileify_dirspec(dir,buf,0,NULL); }
6580 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6581 { return do_fileify_dirspec(dir,buf,1,NULL); }
6582 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6583 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6584 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6585 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6586
6587 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6588     char * v_spec, int v_len, char * r_spec, int r_len,
6589     char * d_spec, int d_len, char * n_spec, int n_len,
6590     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6591
6592     /* VMS specification - Try to do this the simple way */
6593     if ((v_len + r_len > 0) || (d_len > 0)) {
6594         int is_dir;
6595
6596         /* No name or extension component, already a directory */
6597         if ((n_len + e_len + vs_len) == 0) {
6598             strcpy(buf, dir);
6599             return buf;
6600         }
6601
6602         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6603         /* This results from catfile() being used instead of catdir() */
6604         /* So even though it should not work, we need to allow it */
6605
6606         /* If this is .DIR;1 then do a simple conversion */
6607         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6608         if (is_dir || (e_len == 0) && (d_len > 0)) {
6609              int len;
6610              len = v_len + r_len + d_len - 1;
6611              char dclose = d_spec[d_len - 1];
6612              strncpy(buf, dir, len);
6613              buf[len] = '.';
6614              len++;
6615              strncpy(&buf[len], n_spec, n_len);
6616              len += n_len;
6617              buf[len] = dclose;
6618              buf[len + 1] = '\0';
6619              return buf;
6620         }
6621
6622 #ifdef HAS_SYMLINK
6623         else if (d_len > 0) {
6624             /* In the olden days, a directory needed to have a .DIR */
6625             /* extension to be a valid directory, but now it could  */
6626             /* be a symbolic link */
6627             int len;
6628             len = v_len + r_len + d_len - 1;
6629             char dclose = d_spec[d_len - 1];
6630             strncpy(buf, dir, len);
6631             buf[len] = '.';
6632             len++;
6633             strncpy(&buf[len], n_spec, n_len);
6634             len += n_len;
6635             if (e_len > 0) {
6636                 if (decc_efs_charset) {
6637                     buf[len] = '^';
6638                     len++;
6639                     strncpy(&buf[len], e_spec, e_len);
6640                     len += e_len;
6641                 } else {
6642                     set_vaxc_errno(RMS$_DIR);
6643                     set_errno(ENOTDIR);
6644                     return NULL;
6645                 }
6646             }
6647             buf[len] = dclose;
6648             buf[len + 1] = '\0';
6649             return buf;
6650         }
6651 #else
6652         else {
6653             set_vaxc_errno(RMS$_DIR);
6654             set_errno(ENOTDIR);
6655             return NULL;
6656         }
6657 #endif
6658     }
6659     set_vaxc_errno(RMS$_DIR);
6660     set_errno(ENOTDIR);
6661     return NULL;
6662 }
6663
6664
6665 /* Internal routine to make sure or convert a directory to be in a */
6666 /* path specification.  No utf8 flag because it is not changed or used */
6667 static char *int_pathify_dirspec(const char *dir, char *buf)
6668 {
6669     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6670     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6671     char * exp_spec, *ret_spec;
6672     char * trndir;
6673     unsigned short int trnlnm_iter_count;
6674     STRLEN trnlen;
6675     int need_to_lower;
6676
6677     if (vms_debug_fileify) {
6678         if (dir == NULL)
6679             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6680         else
6681             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6682     }
6683
6684     /* We may need to lower case the result if we translated  */
6685     /* a logical name or got the current working directory */
6686     need_to_lower = 0;
6687
6688     if (!dir || !*dir) {
6689       set_errno(EINVAL);
6690       set_vaxc_errno(SS$_BADPARAM);
6691       return NULL;
6692     }
6693
6694     trndir = PerlMem_malloc(VMS_MAXRSS);
6695     if (trndir == NULL)
6696         _ckvmssts_noperl(SS$_INSFMEM);
6697
6698     /* If no directory specified use the current default */
6699     if (*dir)
6700         strcpy(trndir, dir);
6701     else {
6702         getcwd(trndir, VMS_MAXRSS - 1);
6703         need_to_lower = 1;
6704     }
6705
6706     /* now deal with bare names that could be logical names */
6707     trnlnm_iter_count = 0;
6708     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6709            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6710         trnlnm_iter_count++;
6711         need_to_lower = 1;
6712         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6713             break;
6714         trnlen = strlen(trndir);
6715
6716         /* Trap simple rooted lnms, and return lnm:[000000] */
6717         if (!strcmp(trndir+trnlen-2,".]")) {
6718             strcpy(buf, dir);
6719             strcat(buf, ":[000000]");
6720             PerlMem_free(trndir);
6721
6722             if (vms_debug_fileify) {
6723                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6724             }
6725             return buf;
6726         }
6727     }
6728
6729     /* At this point we do not work with *dir, but the copy in  *trndir */
6730
6731     if (need_to_lower && !decc_efs_case_preserve) {
6732         /* Legacy mode, lower case the returned value */
6733         __mystrtolower(trndir);
6734     }
6735
6736
6737     /* Some special cases, '..', '.' */
6738     sts = 0;
6739     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6740        /* Force UNIX filespec */
6741        sts = 1;
6742
6743     } else {
6744         /* Is this Unix or VMS format? */
6745         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6746                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6747                              &e_len, &vs_spec, &vs_len);
6748         if (sts == 0) {
6749
6750             /* Just a filename? */
6751             if ((v_len + r_len + d_len) == 0) {
6752
6753                 /* Now we have a problem, this could be Unix or VMS */
6754                 /* We have to guess.  .DIR usually means VMS */
6755
6756                 /* In UNIX report mode, the .DIR extension is removed */
6757                 /* if one shows up, it is for a non-directory or a directory */
6758                 /* in EFS charset mode */
6759
6760                 /* So if we are in Unix report mode, assume that this */
6761                 /* is a relative Unix directory specification */
6762
6763                 sts = 1;
6764                 if (!decc_filename_unix_report && decc_efs_charset) {
6765                     int is_dir;
6766                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6767
6768                     if (is_dir) {
6769                         /* Traditional mode, assume .DIR is directory */
6770                         buf[0] = '[';
6771                         buf[1] = '.';
6772                         strncpy(&buf[2], n_spec, n_len);
6773                         buf[n_len + 2] = ']';
6774                         buf[n_len + 3] = '\0';
6775                         PerlMem_free(trndir);
6776                         if (vms_debug_fileify) {
6777                             fprintf(stderr,
6778                                     "int_pathify_dirspec: buf = %s\n",
6779                                     buf);
6780                         }
6781                         return buf;
6782                     }
6783                 }
6784             }
6785         }
6786     }
6787     if (sts == 0) {
6788         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6789             v_spec, v_len, r_spec, r_len,
6790             d_spec, d_len, n_spec, n_len,
6791             e_spec, e_len, vs_spec, vs_len);
6792
6793         if (ret_spec != NULL) {
6794             PerlMem_free(trndir);
6795             if (vms_debug_fileify) {
6796                 fprintf(stderr,
6797                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6798             }
6799             return ret_spec;
6800         }
6801
6802         /* Simple way did not work, which means that a logical name */
6803         /* was present for the directory specification.             */
6804         /* Need to use an rmsexpand variant to decode it completely */
6805         exp_spec = PerlMem_malloc(VMS_MAXRSS);
6806         if (exp_spec == NULL)
6807             _ckvmssts_noperl(SS$_INSFMEM);
6808
6809         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6810         if (ret_spec != NULL) {
6811             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6812                                  &r_spec, &r_len, &d_spec, &d_len,
6813                                  &n_spec, &n_len, &e_spec,
6814                                  &e_len, &vs_spec, &vs_len);
6815             if (sts == 0) {
6816                 ret_spec = int_pathify_dirspec_simple(
6817                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6818                     d_spec, d_len, n_spec, n_len,
6819                     e_spec, e_len, vs_spec, vs_len);
6820
6821                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6822                     /* Legacy mode, lower case the returned value */
6823                     __mystrtolower(ret_spec);
6824                 }
6825             } else {
6826                 set_vaxc_errno(RMS$_DIR);
6827                 set_errno(ENOTDIR);
6828                 ret_spec = NULL;
6829             }
6830         }
6831         PerlMem_free(exp_spec);
6832         PerlMem_free(trndir);
6833         if (vms_debug_fileify) {
6834             if (ret_spec == NULL)
6835                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6836             else
6837                 fprintf(stderr,
6838                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6839         }
6840         return ret_spec;
6841
6842     } else {
6843         /* Unix specification, Could be trivial conversion */
6844         STRLEN dir_len;
6845         dir_len = strlen(trndir);
6846
6847         /* If the extended file character set is in effect */
6848         /* then pathify is simple */
6849
6850         if (!decc_efs_charset) {
6851             /* Have to deal with trailing '.dir' or extra '.' */
6852             /* that should not be there in legacy mode, but is */
6853
6854             char * lastdot;
6855             char * lastslash;
6856             int is_dir;
6857
6858             lastslash = strrchr(trndir, '/');
6859             if (lastslash == NULL)
6860                 lastslash = trndir;
6861             else
6862                 lastslash++;
6863
6864             lastdot = NULL;
6865
6866             /* '..' or '.' are valid directory components */
6867             is_dir = 0;
6868             if (lastslash[0] == '.') {
6869                 if (lastslash[1] == '\0') {
6870                    is_dir = 1;
6871                 } else if (lastslash[1] == '.') {
6872                     if (lastslash[2] == '\0') {
6873                         is_dir = 1;
6874                     } else {
6875                         /* And finally allow '...' */
6876                         if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6877                             is_dir = 1;
6878                         }
6879                     }
6880                 }
6881             }
6882
6883             if (!is_dir) {
6884                lastdot = strrchr(lastslash, '.');
6885             }
6886             if (lastdot != NULL) {
6887                 STRLEN e_len;
6888
6889                 /* '.dir' is discarded, and any other '.' is invalid */
6890                 e_len = strlen(lastdot);
6891
6892                 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6893
6894                 if (is_dir) {
6895                     dir_len = dir_len - 4;
6896
6897                 }
6898             }
6899         }
6900
6901         strcpy(buf, trndir);
6902         if (buf[dir_len - 1] != '/') {
6903             buf[dir_len] = '/';
6904             buf[dir_len + 1] = '\0';
6905         }
6906
6907         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6908         if (!decc_efs_charset) {
6909              int dir_start = 0;
6910              char * str = buf;
6911              if (str[0] == '.') {
6912                  char * dots = str;
6913                  int cnt = 1;
6914                  while ((dots[cnt] == '.') && (cnt < 3))
6915                      cnt++;
6916                  if (cnt <= 3) {
6917                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6918                          dir_start = 1;
6919                          str += cnt;
6920                      }
6921                  }
6922              }
6923              for (; *str; ++str) {
6924                  while (*str == '/') {
6925                      dir_start = 1;
6926                      *str++;
6927                  }
6928                  if (dir_start) {
6929
6930                      /* Have to skip up to three dots which could be */
6931                      /* directories, 3 dots being a VMS extension for Perl */
6932                      char * dots = str;
6933                      int cnt = 0;
6934                      while ((dots[cnt] == '.') && (cnt < 3)) {
6935                          cnt++;
6936                      }
6937                      if (dots[cnt] == '\0')
6938                          break;
6939                      if ((cnt > 1) && (dots[cnt] != '/')) {
6940                          dir_start = 0;
6941                      } else {
6942                          str += cnt;
6943                      }
6944
6945                      /* too many dots? */
6946                      if ((cnt == 0) || (cnt > 3)) {
6947                          dir_start = 0;
6948                      }
6949                  }
6950                  if (!dir_start && (*str == '.')) {
6951                      *str = '_';
6952                  }
6953              }
6954         }
6955         PerlMem_free(trndir);
6956         ret_spec = buf;
6957         if (vms_debug_fileify) {
6958             if (ret_spec == NULL)
6959                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6960             else
6961                 fprintf(stderr,
6962                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6963         }
6964         return ret_spec;
6965     }
6966 }
6967
6968 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6969 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6970 {
6971     static char __pathify_retbuf[VMS_MAXRSS];
6972     char * pathified, *ret_spec, *ret_buf;
6973
6974     pathified = NULL;
6975     ret_buf = buf;
6976     if (ret_buf == NULL) {
6977         if (ts) {
6978             Newx(pathified, VMS_MAXRSS, char);
6979             if (pathified == NULL)
6980                 _ckvmssts(SS$_INSFMEM);
6981             ret_buf = pathified;
6982         } else {
6983             ret_buf = __pathify_retbuf;
6984         }
6985     }
6986
6987     ret_spec = int_pathify_dirspec(dir, ret_buf);
6988
6989     if (ret_spec == NULL) {
6990        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6991        if (pathified)
6992            Safefree(pathified);
6993     }
6994
6995     return ret_spec;
6996
6997 }  /* end of do_pathify_dirspec() */
6998
6999
7000 /* External entry points */
7001 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
7002 { return do_pathify_dirspec(dir,buf,0,NULL); }
7003 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
7004 { return do_pathify_dirspec(dir,buf,1,NULL); }
7005 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
7006 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
7007 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
7008 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
7009
7010 /* Internal tounixspec routine that does not use a thread context */
7011 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7012 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7013 {
7014   char *dirend, *cp1, *cp3, *tmp;
7015   const char *cp2;
7016   int dirlen;
7017   unsigned short int trnlnm_iter_count;
7018   int cmp_rslt;
7019   if (utf8_fl != NULL)
7020     *utf8_fl = 0;
7021
7022   if (vms_debug_fileify) {
7023       if (spec == NULL)
7024           fprintf(stderr, "int_tounixspec: spec = NULL\n");
7025       else
7026           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7027   }
7028
7029
7030   if (spec == NULL) {
7031       set_errno(EINVAL);
7032       set_vaxc_errno(SS$_BADPARAM);
7033       return NULL;
7034   }
7035   if (strlen(spec) > (VMS_MAXRSS-1)) {
7036       set_errno(E2BIG);
7037       set_vaxc_errno(SS$_BUFFEROVF);
7038       return NULL;
7039   }
7040
7041   /* New VMS specific format needs translation
7042    * glob passes filenames with trailing '\n' and expects this preserved.
7043    */
7044   if (decc_posix_compliant_pathnames) {
7045     if (strncmp(spec, "\"^UP^", 5) == 0) {
7046       char * uspec;
7047       char *tunix;
7048       int tunix_len;
7049       int nl_flag;
7050
7051       tunix = PerlMem_malloc(VMS_MAXRSS);
7052       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7053       strcpy(tunix, spec);
7054       tunix_len = strlen(tunix);
7055       nl_flag = 0;
7056       if (tunix[tunix_len - 1] == '\n') {
7057         tunix[tunix_len - 1] = '\"';
7058         tunix[tunix_len] = '\0';
7059         tunix_len--;
7060         nl_flag = 1;
7061       }
7062       uspec = decc$translate_vms(tunix);
7063       PerlMem_free(tunix);
7064       if ((int)uspec > 0) {
7065         strcpy(rslt,uspec);
7066         if (nl_flag) {
7067           strcat(rslt,"\n");
7068         }
7069         else {
7070           /* If we can not translate it, makemaker wants as-is */
7071           strcpy(rslt, spec);
7072         }
7073         return rslt;
7074       }
7075     }
7076   }
7077
7078   cmp_rslt = 0; /* Presume VMS */
7079   cp1 = strchr(spec, '/');
7080   if (cp1 == NULL)
7081     cmp_rslt = 0;
7082
7083     /* Look for EFS ^/ */
7084     if (decc_efs_charset) {
7085       while (cp1 != NULL) {
7086         cp2 = cp1 - 1;
7087         if (*cp2 != '^') {
7088           /* Found illegal VMS, assume UNIX */
7089           cmp_rslt = 1;
7090           break;
7091         }
7092       cp1++;
7093       cp1 = strchr(cp1, '/');
7094     }
7095   }
7096
7097   /* Look for "." and ".." */
7098   if (decc_filename_unix_report) {
7099     if (spec[0] == '.') {
7100       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7101         cmp_rslt = 1;
7102       }
7103       else {
7104         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7105           cmp_rslt = 1;
7106         }
7107       }
7108     }
7109   }
7110   /* This is already UNIX or at least nothing VMS understands */
7111   if (cmp_rslt) {
7112     strcpy(rslt,spec);
7113     if (vms_debug_fileify) {
7114         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7115     }
7116     return rslt;
7117   }
7118
7119   cp1 = rslt;
7120   cp2 = spec;
7121   dirend = strrchr(spec,']');
7122   if (dirend == NULL) dirend = strrchr(spec,'>');
7123   if (dirend == NULL) dirend = strchr(spec,':');
7124   if (dirend == NULL) {
7125     strcpy(rslt,spec);
7126     if (vms_debug_fileify) {
7127         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7128     }
7129     return rslt;
7130   }
7131
7132   /* Special case 1 - sys$posix_root = / */
7133 #if __CRTL_VER >= 70000000
7134   if (!decc_disable_posix_root) {
7135     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7136       *cp1 = '/';
7137       cp1++;
7138       cp2 = cp2 + 15;
7139       }
7140   }
7141 #endif
7142
7143   /* Special case 2 - Convert NLA0: to /dev/null */
7144 #if __CRTL_VER < 70000000
7145   cmp_rslt = strncmp(spec,"NLA0:", 5);
7146   if (cmp_rslt != 0)
7147      cmp_rslt = strncmp(spec,"nla0:", 5);
7148 #else
7149   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7150 #endif
7151   if (cmp_rslt == 0) {
7152     strcpy(rslt, "/dev/null");
7153     cp1 = cp1 + 9;
7154     cp2 = cp2 + 5;
7155     if (spec[6] != '\0') {
7156       cp1[9] = '/';
7157       cp1++;
7158       cp2++;
7159     }
7160   }
7161
7162    /* Also handle special case "SYS$SCRATCH:" */
7163 #if __CRTL_VER < 70000000
7164   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7165   if (cmp_rslt != 0)
7166      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7167 #else
7168   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7169 #endif
7170   tmp = PerlMem_malloc(VMS_MAXRSS);
7171   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7172   if (cmp_rslt == 0) {
7173   int islnm;
7174
7175     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7176     if (!islnm) {
7177       strcpy(rslt, "/tmp");
7178       cp1 = cp1 + 4;
7179       cp2 = cp2 + 12;
7180       if (spec[12] != '\0') {
7181         cp1[4] = '/';
7182         cp1++;
7183         cp2++;
7184       }
7185     }
7186   }
7187
7188   if (*cp2 != '[' && *cp2 != '<') {
7189     *(cp1++) = '/';
7190   }
7191   else {  /* the VMS spec begins with directories */
7192     cp2++;
7193     if (*cp2 == ']' || *cp2 == '>') {
7194       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7195       PerlMem_free(tmp);
7196       return rslt;
7197     }
7198     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7199       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7200         PerlMem_free(tmp);
7201         if (vms_debug_fileify) {
7202             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7203         }
7204         return NULL;
7205       }
7206       trnlnm_iter_count = 0;
7207       do {
7208         cp3 = tmp;
7209         while (*cp3 != ':' && *cp3) cp3++;
7210         *(cp3++) = '\0';
7211         if (strchr(cp3,']') != NULL) break;
7212         trnlnm_iter_count++;
7213         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7214       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7215       cp1 = rslt;
7216       cp3 = tmp;
7217       *(cp1++) = '/';
7218       while (*cp3) {
7219         *(cp1++) = *(cp3++);
7220         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7221             PerlMem_free(tmp);
7222             set_errno(ENAMETOOLONG);
7223             set_vaxc_errno(SS$_BUFFEROVF);
7224             if (vms_debug_fileify) {
7225                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7226             }
7227             return NULL; /* No room */
7228         }
7229       }
7230       *(cp1++) = '/';
7231     }
7232     if ((*cp2 == '^')) {
7233         /* EFS file escape, pass the next character as is */
7234         /* Fix me: HEX encoding for Unicode not implemented */
7235         cp2++;
7236     }
7237     else if ( *cp2 == '.') {
7238       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7239         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7240         cp2 += 3;
7241       }
7242       else cp2++;
7243     }
7244   }
7245   PerlMem_free(tmp);
7246   for (; cp2 <= dirend; cp2++) {
7247     if ((*cp2 == '^')) {
7248         /* EFS file escape, pass the next character as is */
7249         /* Fix me: HEX encoding for Unicode not implemented */
7250         *(cp1++) = *(++cp2);
7251         /* An escaped dot stays as is -- don't convert to slash */
7252         if (*cp2 == '.') cp2++;
7253     }
7254     if (*cp2 == ':') {
7255       *(cp1++) = '/';
7256       if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7257     }
7258     else if (*cp2 == ']' || *cp2 == '>') {
7259       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7260     }
7261     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7262       *(cp1++) = '/';
7263       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7264         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7265                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7266         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7267             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7268       }
7269       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7270         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7271         cp2 += 2;
7272       }
7273     }
7274     else if (*cp2 == '-') {
7275       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7276         while (*cp2 == '-') {
7277           cp2++;
7278           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7279         }
7280         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7281                                                          /* filespecs like */
7282           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7283           if (vms_debug_fileify) {
7284               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7285           }
7286           return NULL;
7287         }
7288       }
7289       else *(cp1++) = *cp2;
7290     }
7291     else *(cp1++) = *cp2;
7292   }
7293   /* Translate the rest of the filename. */
7294   while (*cp2) {
7295       int dot_seen;
7296       dot_seen = 0;
7297       switch(*cp2) {
7298       /* Fixme - for compatibility with the CRTL we should be removing */
7299       /* spaces from the file specifications, but this may show that */
7300       /* some tests that were appearing to pass are not really passing */
7301       case '%':
7302           cp2++;
7303           *(cp1++) = '?';
7304           break;
7305       case '^':
7306           /* Fix me hex expansions not implemented */
7307           cp2++;  /* '^.' --> '.' and other. */
7308           if (*cp2) {
7309               if (*cp2 == '_') {
7310                   cp2++;
7311                   *(cp1++) = ' ';
7312               } else {
7313                   *(cp1++) = *(cp2++);
7314               }
7315           }
7316           break;
7317       case ';':
7318           if (decc_filename_unix_no_version) {
7319               /* Easy, drop the version */
7320               while (*cp2)
7321                   cp2++;
7322               break;
7323           } else {
7324               /* Punt - passing the version as a dot will probably */
7325               /* break perl in weird ways, but so did passing */
7326               /* through the ; as a version.  Follow the CRTL and */
7327               /* hope for the best. */
7328               cp2++;
7329               *(cp1++) = '.';
7330           }
7331           break;
7332       case '.':
7333           if (dot_seen) {
7334               /* We will need to fix this properly later */
7335               /* As Perl may be installed on an ODS-5 volume, but not */
7336               /* have the EFS_CHARSET enabled, it still may encounter */
7337               /* filenames with extra dots in them, and a precedent got */
7338               /* set which allowed them to work, that we will uphold here */
7339               /* If extra dots are present in a name and no ^ is on them */
7340               /* VMS assumes that the first one is the extension delimiter */
7341               /* the rest have an implied ^. */
7342
7343               /* this is also a conflict as the . is also a version */
7344               /* delimiter in VMS, */
7345
7346               *(cp1++) = *(cp2++);
7347               break;
7348           }
7349           dot_seen = 1;
7350           /* This is an extension */
7351           if (decc_readdir_dropdotnotype) {
7352               cp2++;
7353               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7354                   /* Drop the dot for the extension */
7355                   break;
7356               } else {
7357                   *(cp1++) = '.';
7358               }
7359               break;
7360           }
7361       default:
7362           *(cp1++) = *(cp2++);
7363       }
7364   }
7365   *cp1 = '\0';
7366
7367   /* This still leaves /000000/ when working with a
7368    * VMS device root or concealed root.
7369    */
7370   {
7371   int ulen;
7372   char * zeros;
7373
7374       ulen = strlen(rslt);
7375
7376       /* Get rid of "000000/ in rooted filespecs */
7377       if (ulen > 7) {
7378         zeros = strstr(rslt, "/000000/");
7379         if (zeros != NULL) {
7380           int mlen;
7381           mlen = ulen - (zeros - rslt) - 7;
7382           memmove(zeros, &zeros[7], mlen);
7383           ulen = ulen - 7;
7384           rslt[ulen] = '\0';
7385         }
7386       }
7387   }
7388
7389   if (vms_debug_fileify) {
7390       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7391   }
7392   return rslt;
7393
7394 }  /* end of int_tounixspec() */
7395
7396
7397 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7398 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7399 {
7400     static char __tounixspec_retbuf[VMS_MAXRSS];
7401     char * unixspec, *ret_spec, *ret_buf;
7402
7403     unixspec = NULL;
7404     ret_buf = buf;
7405     if (ret_buf == NULL) {
7406         if (ts) {
7407             Newx(unixspec, VMS_MAXRSS, char);
7408             if (unixspec == NULL)
7409                 _ckvmssts(SS$_INSFMEM);
7410             ret_buf = unixspec;
7411         } else {
7412             ret_buf = __tounixspec_retbuf;
7413         }
7414     }
7415
7416     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7417
7418     if (ret_spec == NULL) {
7419        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7420        if (unixspec)
7421            Safefree(unixspec);
7422     }
7423
7424     return ret_spec;
7425
7426 }  /* end of do_tounixspec() */
7427 /*}}}*/
7428 /* External entry points */
7429 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7430   { return do_tounixspec(spec,buf,0, NULL); }
7431 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7432   { return do_tounixspec(spec,buf,1, NULL); }
7433 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7434   { return do_tounixspec(spec,buf,0, utf8_fl); }
7435 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7436   { return do_tounixspec(spec,buf,1, utf8_fl); }
7437
7438 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7439
7440 /*
7441  This procedure is used to identify if a path is based in either
7442  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7443  it returns the OpenVMS format directory for it.
7444
7445  It is expecting specifications of only '/' or '/xxxx/'
7446
7447  If a posix root does not exist, or 'xxxx' is not a directory
7448  in the posix root, it returns a failure.
7449
7450  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7451
7452  It is used only internally by posix_to_vmsspec_hardway().
7453  */
7454
7455 static int posix_root_to_vms
7456   (char *vmspath, int vmspath_len,
7457    const char *unixpath,
7458    const int * utf8_fl)
7459 {
7460 int sts;
7461 struct FAB myfab = cc$rms_fab;
7462 rms_setup_nam(mynam);
7463 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7464 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7465 char * esa, * esal, * rsa, * rsal;
7466 int dir_flag;
7467 int unixlen;
7468
7469     dir_flag = 0;
7470     vmspath[0] = '\0';
7471     unixlen = strlen(unixpath);
7472     if (unixlen == 0) {
7473       return RMS$_FNF;
7474     }
7475
7476 #if __CRTL_VER >= 80200000
7477   /* If not a posix spec already, convert it */
7478   if (decc_posix_compliant_pathnames) {
7479     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7480       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7481     }
7482     else {
7483       /* This is already a VMS specification, no conversion */
7484       unixlen--;
7485       strncpy(vmspath,unixpath, vmspath_len);
7486     }
7487   }
7488   else
7489 #endif
7490   {
7491   int path_len;
7492   int i,j;
7493
7494      /* Check to see if this is under the POSIX root */
7495      if (decc_disable_posix_root) {
7496         return RMS$_FNF;
7497      }
7498
7499      /* Skip leading / */
7500      if (unixpath[0] == '/') {
7501         unixpath++;
7502         unixlen--;
7503      }
7504
7505
7506      strcpy(vmspath,"SYS$POSIX_ROOT:");
7507
7508      /* If this is only the / , or blank, then... */
7509      if (unixpath[0] == '\0') {
7510         /* by definition, this is the answer */
7511         return SS$_NORMAL;
7512      }
7513
7514      /* Need to look up a directory */
7515      vmspath[15] = '[';
7516      vmspath[16] = '\0';
7517
7518      /* Copy and add '^' escape characters as needed */
7519      j = 16;
7520      i = 0;
7521      while (unixpath[i] != 0) {
7522      int k;
7523
7524         j += copy_expand_unix_filename_escape
7525             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7526         i += k;
7527      }
7528
7529      path_len = strlen(vmspath);
7530      if (vmspath[path_len - 1] == '/')
7531         path_len--;
7532      vmspath[path_len] = ']';
7533      path_len++;
7534      vmspath[path_len] = '\0';
7535
7536   }
7537   vmspath[vmspath_len] = 0;
7538   if (unixpath[unixlen - 1] == '/')
7539   dir_flag = 1;
7540   esal = PerlMem_malloc(VMS_MAXRSS);
7541   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7542   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7543   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7544   rsal = PerlMem_malloc(VMS_MAXRSS);
7545   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7546   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7547   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7548   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7549   rms_bind_fab_nam(myfab, mynam);
7550   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7551   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7552   if (decc_efs_case_preserve)
7553     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7554 #ifdef NAML$M_OPEN_SPECIAL
7555   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7556 #endif
7557
7558   /* Set up the remaining naml fields */
7559   sts = sys$parse(&myfab);
7560
7561   /* It failed! Try again as a UNIX filespec */
7562   if (!(sts & 1)) {
7563     PerlMem_free(esal);
7564     PerlMem_free(esa);
7565     PerlMem_free(rsal);
7566     PerlMem_free(rsa);
7567     return sts;
7568   }
7569
7570    /* get the Device ID and the FID */
7571    sts = sys$search(&myfab);
7572
7573    /* These are no longer needed */
7574    PerlMem_free(esa);
7575    PerlMem_free(rsal);
7576    PerlMem_free(rsa);
7577
7578    /* on any failure, returned the POSIX ^UP^ filespec */
7579    if (!(sts & 1)) {
7580       PerlMem_free(esal);
7581       return sts;
7582    }
7583    specdsc.dsc$a_pointer = vmspath;
7584    specdsc.dsc$w_length = vmspath_len;
7585
7586    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7587    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7588    sts = lib$fid_to_name
7589       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7590
7591   /* on any failure, returned the POSIX ^UP^ filespec */
7592   if (!(sts & 1)) {
7593      /* This can happen if user does not have permission to read directories */
7594      if (strncmp(unixpath,"\"^UP^",5) != 0)
7595        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7596      else
7597        strcpy(vmspath, unixpath);
7598   }
7599   else {
7600     vmspath[specdsc.dsc$w_length] = 0;
7601
7602     /* Are we expecting a directory? */
7603     if (dir_flag != 0) {
7604     int i;
7605     char *eptr;
7606
7607       eptr = NULL;
7608
7609       i = specdsc.dsc$w_length - 1;
7610       while (i > 0) {
7611       int zercnt;
7612         zercnt = 0;
7613         /* Version must be '1' */
7614         if (vmspath[i--] != '1')
7615           break;
7616         /* Version delimiter is one of ".;" */
7617         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7618           break;
7619         i--;
7620         if (vmspath[i--] != 'R')
7621           break;
7622         if (vmspath[i--] != 'I')
7623           break;
7624         if (vmspath[i--] != 'D')
7625           break;
7626         if (vmspath[i--] != '.')
7627           break;
7628         eptr = &vmspath[i+1];
7629         while (i > 0) {
7630           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7631             if (vmspath[i-1] != '^') {
7632               if (zercnt != 6) {
7633                 *eptr = vmspath[i];
7634                 eptr[1] = '\0';
7635                 vmspath[i] = '.';
7636                 break;
7637               }
7638               else {
7639                 /* Get rid of 6 imaginary zero directory filename */
7640                 vmspath[i+1] = '\0';
7641               }
7642             }
7643           }
7644           if (vmspath[i] == '0')
7645             zercnt++;
7646           else
7647             zercnt = 10;
7648           i--;
7649         }
7650         break;
7651       }
7652     }
7653   }
7654   PerlMem_free(esal);
7655   return sts;
7656 }
7657
7658 /* /dev/mumble needs to be handled special.
7659    /dev/null becomes NLA0:, And there is the potential for other stuff
7660    like /dev/tty which may need to be mapped to something.
7661 */
7662
7663 static int
7664 slash_dev_special_to_vms
7665    (const char * unixptr,
7666     char * vmspath,
7667     int vmspath_len)
7668 {
7669 char * nextslash;
7670 int len;
7671 int cmp;
7672
7673     unixptr += 4;
7674     nextslash = strchr(unixptr, '/');
7675     len = strlen(unixptr);
7676     if (nextslash != NULL)
7677         len = nextslash - unixptr;
7678     cmp = strncmp("null", unixptr, 5);
7679     if (cmp == 0) {
7680         if (vmspath_len >= 6) {
7681             strcpy(vmspath, "_NLA0:");
7682             return SS$_NORMAL;
7683         }
7684     }
7685     return 0;
7686 }
7687
7688
7689 /* The built in routines do not understand perl's special needs, so
7690     doing a manual conversion from UNIX to VMS
7691
7692     If the utf8_fl is not null and points to a non-zero value, then
7693     treat 8 bit characters as UTF-8.
7694
7695     The sequence starting with '$(' and ending with ')' will be passed
7696     through with out interpretation instead of being escaped.
7697
7698   */
7699 static int posix_to_vmsspec_hardway
7700   (char *vmspath, int vmspath_len,
7701    const char *unixpath,
7702    int dir_flag,
7703    int * utf8_fl) {
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 (strncmp(unixptr,"\"^UP^",5) == 0) {
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 = PerlMem_malloc(vmspath_len);
7799         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7800
7801         trn = PerlMem_malloc(VMS_MAXRSS);
7802         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7803
7804         if (nextslash != NULL) {
7805
7806             seg_len = nextslash - unixptr;
7807             strncpy(esa, unixptr, seg_len);
7808             esa[seg_len] = 0;
7809         }
7810         else {
7811             strcpy(esa, unixptr);
7812             seg_len = strlen(unixptr);
7813         }
7814         /* trnlnm(section) */
7815         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7816
7817         if (islnm) {
7818             /* Now fix up the directory */
7819
7820             /* Split up the path to find the components */
7821             sts = vms_split_path
7822                   (trn,
7823                    &v_spec,
7824                    &v_len,
7825                    &r_spec,
7826                    &r_len,
7827                    &d_spec,
7828                    &d_len,
7829                    &n_spec,
7830                    &n_len,
7831                    &e_spec,
7832                    &e_len,
7833                    &vs_spec,
7834                    &vs_len);
7835
7836             while (sts == 0) {
7837             int cmp;
7838
7839                 /* A logical name must be a directory  or the full
7840                    specification.  It is only a full specification if
7841                    it is the only component */
7842                 if ((unixptr[seg_len] == '\0') ||
7843                     (unixptr[seg_len+1] == '\0')) {
7844
7845                     /* Is a directory being required? */
7846                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7847                         /* Not a logical name */
7848                         break;
7849                     }
7850
7851
7852                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7853                         /* This must be a directory */
7854                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7855                             strcpy(vmsptr, esa);
7856                             vmslen=strlen(vmsptr);
7857                             vmsptr[vmslen] = ':';
7858                             vmslen++;
7859                             vmsptr[vmslen] = '\0';
7860                             return SS$_NORMAL;
7861                         }
7862                     }
7863
7864                 }
7865
7866
7867                 /* must be dev/directory - ignore version */
7868                 if ((n_len + e_len) != 0)
7869                     break;
7870
7871                 /* transfer the volume */
7872                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7873                     strncpy(vmsptr, v_spec, v_len);
7874                     vmsptr += v_len;
7875                     vmsptr[0] = '\0';
7876                     vmslen += v_len;
7877                 }
7878
7879                 /* unroot the rooted directory */
7880                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7881                     r_spec[0] = '[';
7882                     r_spec[r_len - 1] = ']';
7883
7884                     /* This should not be there, but nothing is perfect */
7885                     if (r_len > 9) {
7886                         cmp = strcmp(&r_spec[1], "000000.");
7887                         if (cmp == 0) {
7888                             r_spec += 7;
7889                             r_spec[7] = '[';
7890                             r_len -= 7;
7891                             if (r_len == 2)
7892                                 r_len = 0;
7893                         }
7894                     }
7895                     if (r_len > 0) {
7896                         strncpy(vmsptr, r_spec, r_len);
7897                         vmsptr += r_len;
7898                         vmslen += r_len;
7899                         vmsptr[0] = '\0';
7900                     }
7901                 }
7902                 /* Bring over the directory. */
7903                 if ((d_len > 0) &&
7904                     ((d_len + vmslen) < vmspath_len)) {
7905                     d_spec[0] = '[';
7906                     d_spec[d_len - 1] = ']';
7907                     if (d_len > 9) {
7908                         cmp = strcmp(&d_spec[1], "000000.");
7909                         if (cmp == 0) {
7910                             d_spec += 7;
7911                             d_spec[7] = '[';
7912                             d_len -= 7;
7913                             if (d_len == 2)
7914                                 d_len = 0;
7915                         }
7916                     }
7917
7918                     if (r_len > 0) {
7919                         /* Remove the redundant root */
7920                         if (r_len > 0) {
7921                             /* remove the ][ */
7922                             vmsptr--;
7923                             vmslen--;
7924                             d_spec++;
7925                             d_len--;
7926                         }
7927                         strncpy(vmsptr, d_spec, d_len);
7928                             vmsptr += d_len;
7929                             vmslen += d_len;
7930                             vmsptr[0] = '\0';
7931                     }
7932                 }
7933                 break;
7934             }
7935         }
7936
7937         PerlMem_free(esa);
7938         PerlMem_free(trn);
7939     }
7940
7941     if (lastslash > unixptr) {
7942     int dotdir_seen;
7943
7944       /* skip leading ./ */
7945       dotdir_seen = 0;
7946       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7947         dotdir_seen = 1;
7948         unixptr++;
7949         unixptr++;
7950       }
7951
7952       /* Are we still in a directory? */
7953       if (unixptr <= lastslash) {
7954         *vmsptr++ = '[';
7955         vmslen = 1;
7956         dir_start = 1;
7957
7958         /* if not backing up, then it is relative forward. */
7959         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7960               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7961           *vmsptr++ = '.';
7962           vmslen++;
7963           dir_dot = 1;
7964           }
7965        }
7966        else {
7967          if (dotdir_seen) {
7968            /* Perl wants an empty directory here to tell the difference
7969             * between a DCL command and a filename
7970             */
7971           *vmsptr++ = '[';
7972           *vmsptr++ = ']';
7973           vmslen = 2;
7974         }
7975       }
7976     }
7977     else {
7978       /* Handle two special files . and .. */
7979       if (unixptr[0] == '.') {
7980         if (&unixptr[1] == unixend) {
7981           *vmsptr++ = '[';
7982           *vmsptr++ = ']';
7983           vmslen += 2;
7984           *vmsptr++ = '\0';
7985           return SS$_NORMAL;
7986         }
7987         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7988           *vmsptr++ = '[';
7989           *vmsptr++ = '-';
7990           *vmsptr++ = ']';
7991           vmslen += 3;
7992           *vmsptr++ = '\0';
7993           return SS$_NORMAL;
7994         }
7995       }
7996     }
7997   }
7998   else {        /* Absolute PATH handling */
7999   int sts;
8000   char * nextslash;
8001   int seg_len;
8002     /* Need to find out where root is */
8003
8004     /* In theory, this procedure should never get an absolute POSIX pathname
8005      * that can not be found on the POSIX root.
8006      * In practice, that can not be relied on, and things will show up
8007      * here that are a VMS device name or concealed logical name instead.
8008      * So to make things work, this procedure must be tolerant.
8009      */
8010     esa = PerlMem_malloc(vmspath_len);
8011     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8012
8013     sts = SS$_NORMAL;
8014     nextslash = strchr(&unixptr[1],'/');
8015     seg_len = 0;
8016     if (nextslash != NULL) {
8017     int cmp;
8018       seg_len = nextslash - &unixptr[1];
8019       strncpy(vmspath, unixptr, seg_len + 1);
8020       vmspath[seg_len+1] = 0;
8021       cmp = 1;
8022       if (seg_len == 3) {
8023         cmp = strncmp(vmspath, "dev", 4);
8024         if (cmp == 0) {
8025             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8026             if (sts == SS$_NORMAL)
8027                 return SS$_NORMAL;
8028         }
8029       }
8030       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8031     }
8032
8033     if ($VMS_STATUS_SUCCESS(sts)) {
8034       /* This is verified to be a real path */
8035
8036       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8037       if ($VMS_STATUS_SUCCESS(sts)) {
8038         strcpy(vmspath, esa);
8039         vmslen = strlen(vmspath);
8040         vmsptr = vmspath + vmslen;
8041         unixptr++;
8042         if (unixptr < lastslash) {
8043         char * rptr;
8044           vmsptr--;
8045           *vmsptr++ = '.';
8046           dir_start = 1;
8047           dir_dot = 1;
8048           if (vmslen > 7) {
8049           int cmp;
8050             rptr = vmsptr - 7;
8051             cmp = strcmp(rptr,"000000.");
8052             if (cmp == 0) {
8053               vmslen -= 7;
8054               vmsptr -= 7;
8055               vmsptr[1] = '\0';
8056             } /* removing 6 zeros */
8057           } /* vmslen < 7, no 6 zeros possible */
8058         } /* Not in a directory */
8059       } /* Posix root found */
8060       else {
8061         /* No posix root, fall back to default directory */
8062         strcpy(vmspath, "SYS$DISK:[");
8063         vmsptr = &vmspath[10];
8064         vmslen = 10;
8065         if (unixptr > lastslash) {
8066            *vmsptr = ']';
8067            vmsptr++;
8068            vmslen++;
8069         }
8070         else {
8071            dir_start = 1;
8072         }
8073       }
8074     } /* end of verified real path handling */
8075     else {
8076     int add_6zero;
8077     int islnm;
8078
8079       /* Ok, we have a device or a concealed root that is not in POSIX
8080        * or we have garbage.  Make the best of it.
8081        */
8082
8083       /* Posix to VMS destroyed this, so copy it again */
8084       strncpy(vmspath, &unixptr[1], seg_len);
8085       vmspath[seg_len] = 0;
8086       vmslen = seg_len;
8087       vmsptr = &vmsptr[vmslen];
8088       islnm = 0;
8089
8090       /* Now do we need to add the fake 6 zero directory to it? */
8091       add_6zero = 1;
8092       if ((*lastslash == '/') && (nextslash < lastslash)) {
8093         /* No there is another directory */
8094         add_6zero = 0;
8095       }
8096       else {
8097       int trnend;
8098       int cmp;
8099
8100         /* now we have foo:bar or foo:[000000]bar to decide from */
8101         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8102
8103         if (!islnm && !decc_posix_compliant_pathnames) {
8104
8105             cmp = strncmp("bin", vmspath, 4);
8106             if (cmp == 0) {
8107                 /* bin => SYS$SYSTEM: */
8108                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8109             }
8110             else {
8111                 /* tmp => SYS$SCRATCH: */
8112                 cmp = strncmp("tmp", vmspath, 4);
8113                 if (cmp == 0) {
8114                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8115                 }
8116             }
8117         }
8118
8119         trnend = islnm ? islnm - 1 : 0;
8120
8121         /* if this was a logical name, ']' or '>' must be present */
8122         /* if not a logical name, then assume a device and hope. */
8123         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8124
8125         /* if log name and trailing '.' then rooted - treat as device */
8126         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8127
8128         /* Fix me, if not a logical name, a device lookup should be
8129          * done to see if the device is file structured.  If the device
8130          * is not file structured, the 6 zeros should not be put on.
8131          *
8132          * As it is, perl is occasionally looking for dev:[000000]tty.
8133          * which looks a little strange.
8134          *
8135          * Not that easy to detect as "/dev" may be file structured with
8136          * special device files.
8137          */
8138
8139         if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
8140             (&nextslash[1] == unixend)) {
8141           /* No real directory present */
8142           add_6zero = 1;
8143         }
8144       }
8145
8146       /* Put the device delimiter on */
8147       *vmsptr++ = ':';
8148       vmslen++;
8149       unixptr = nextslash;
8150       unixptr++;
8151
8152       /* Start directory if needed */
8153       if (!islnm || add_6zero) {
8154         *vmsptr++ = '[';
8155         vmslen++;
8156         dir_start = 1;
8157       }
8158
8159       /* add fake 000000] if needed */
8160       if (add_6zero) {
8161         *vmsptr++ = '0';
8162         *vmsptr++ = '0';
8163         *vmsptr++ = '0';
8164         *vmsptr++ = '0';
8165         *vmsptr++ = '0';
8166         *vmsptr++ = '0';
8167         *vmsptr++ = ']';
8168         vmslen += 7;
8169         dir_start = 0;
8170       }
8171
8172     } /* non-POSIX translation */
8173     PerlMem_free(esa);
8174   } /* End of relative/absolute path handling */
8175
8176   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8177   int dash_flag;
8178   int in_cnt;
8179   int out_cnt;
8180
8181     dash_flag = 0;
8182
8183     if (dir_start != 0) {
8184
8185       /* First characters in a directory are handled special */
8186       while ((*unixptr == '/') ||
8187              ((*unixptr == '.') &&
8188               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8189                 (&unixptr[1]==unixend)))) {
8190       int loop_flag;
8191
8192         loop_flag = 0;
8193
8194         /* Skip redundant / in specification */
8195         while ((*unixptr == '/') && (dir_start != 0)) {
8196           loop_flag = 1;
8197           unixptr++;
8198           if (unixptr == lastslash)
8199             break;
8200         }
8201         if (unixptr == lastslash)
8202           break;
8203
8204         /* Skip redundant ./ characters */
8205         while ((*unixptr == '.') &&
8206                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8207           loop_flag = 1;
8208           unixptr++;
8209           if (unixptr == lastslash)
8210             break;
8211           if (*unixptr == '/')
8212             unixptr++;
8213         }
8214         if (unixptr == lastslash)
8215           break;
8216
8217         /* Skip redundant ../ characters */
8218         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8219              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8220           /* Set the backing up flag */
8221           loop_flag = 1;
8222           dir_dot = 0;
8223           dash_flag = 1;
8224           *vmsptr++ = '-';
8225           vmslen++;
8226           unixptr++; /* first . */
8227           unixptr++; /* second . */
8228           if (unixptr == lastslash)
8229             break;
8230           if (*unixptr == '/') /* The slash */
8231             unixptr++;
8232         }
8233         if (unixptr == lastslash)
8234           break;
8235
8236         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8237         /* Not needed when VMS is pretending to be UNIX. */
8238
8239         /* Is this loop stuck because of too many dots? */
8240         if (loop_flag == 0) {
8241           /* Exit the loop and pass the rest through */
8242           break;
8243         }
8244       }
8245
8246       /* Are we done with directories yet? */
8247       if (unixptr >= lastslash) {
8248
8249         /* Watch out for trailing dots */
8250         if (dir_dot != 0) {
8251             vmslen --;
8252             vmsptr--;
8253         }
8254         *vmsptr++ = ']';
8255         vmslen++;
8256         dash_flag = 0;
8257         dir_start = 0;
8258         if (*unixptr == '/')
8259           unixptr++;
8260       }
8261       else {
8262         /* Have we stopped backing up? */
8263         if (dash_flag) {
8264           *vmsptr++ = '.';
8265           vmslen++;
8266           dash_flag = 0;
8267           /* dir_start continues to be = 1 */
8268         }
8269         if (*unixptr == '-') {
8270           *vmsptr++ = '^';
8271           *vmsptr++ = *unixptr++;
8272           vmslen += 2;
8273           dir_start = 0;
8274
8275           /* Now are we done with directories yet? */
8276           if (unixptr >= lastslash) {
8277
8278             /* Watch out for trailing dots */
8279             if (dir_dot != 0) {
8280               vmslen --;
8281               vmsptr--;
8282             }
8283
8284             *vmsptr++ = ']';
8285             vmslen++;
8286             dash_flag = 0;
8287             dir_start = 0;
8288           }
8289         }
8290       }
8291     }
8292
8293     /* All done? */
8294     if (unixptr >= unixend)
8295       break;
8296
8297     /* Normal characters - More EFS work probably needed */
8298     dir_start = 0;
8299     dir_dot = 0;
8300
8301     switch(*unixptr) {
8302     case '/':
8303         /* remove multiple / */
8304         while (unixptr[1] == '/') {
8305            unixptr++;
8306         }
8307         if (unixptr == lastslash) {
8308           /* Watch out for trailing dots */
8309           if (dir_dot != 0) {
8310             vmslen --;
8311             vmsptr--;
8312           }
8313           *vmsptr++ = ']';
8314         }
8315         else {
8316           dir_start = 1;
8317           *vmsptr++ = '.';
8318           dir_dot = 1;
8319
8320           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8321           /* Not needed when VMS is pretending to be UNIX. */
8322
8323         }
8324         dash_flag = 0;
8325         if (unixptr != unixend)
8326           unixptr++;
8327         vmslen++;
8328         break;
8329     case '.':
8330         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8331             (&unixptr[1] == unixend)) {
8332           *vmsptr++ = '^';
8333           *vmsptr++ = '.';
8334           vmslen += 2;
8335           unixptr++;
8336
8337           /* trailing dot ==> '^..' on VMS */
8338           if (unixptr == unixend) {
8339             *vmsptr++ = '.';
8340             vmslen++;
8341             unixptr++;
8342           }
8343           break;
8344         }
8345
8346         *vmsptr++ = *unixptr++;
8347         vmslen ++;
8348         break;
8349     case '"':
8350         if (quoted && (&unixptr[1] == unixend)) {
8351             unixptr++;
8352             break;
8353         }
8354         in_cnt = copy_expand_unix_filename_escape
8355                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8356         vmsptr += out_cnt;
8357         unixptr += in_cnt;
8358         break;
8359     case '~':
8360     case ';':
8361     case '\\':
8362     case '?':
8363     case ' ':
8364     default:
8365         in_cnt = copy_expand_unix_filename_escape
8366                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8367         vmsptr += out_cnt;
8368         unixptr += in_cnt;
8369         break;
8370     }
8371   }
8372
8373   /* Make sure directory is closed */
8374   if (unixptr == lastslash) {
8375     char *vmsptr2;
8376     vmsptr2 = vmsptr - 1;
8377
8378     if (*vmsptr2 != ']') {
8379       *vmsptr2--;
8380
8381       /* directories do not end in a dot bracket */
8382       if (*vmsptr2 == '.') {
8383         vmsptr2--;
8384
8385         /* ^. is allowed */
8386         if (*vmsptr2 != '^') {
8387           vmsptr--; /* back up over the dot */
8388         }
8389       }
8390       *vmsptr++ = ']';
8391     }
8392   }
8393   else {
8394     char *vmsptr2;
8395     /* Add a trailing dot if a file with no extension */
8396     vmsptr2 = vmsptr - 1;
8397     if ((vmslen > 1) &&
8398         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8399         (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
8400         *vmsptr++ = '.';
8401         vmslen++;
8402     }
8403   }
8404
8405   *vmsptr = '\0';
8406   return SS$_NORMAL;
8407 }
8408 #endif
8409
8410  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8411 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8412 {
8413 char * result;
8414 int utf8_flag;
8415
8416    /* If a UTF8 flag is being passed, honor it */
8417    utf8_flag = 0;
8418    if (utf8_fl != NULL) {
8419      utf8_flag = *utf8_fl;
8420     *utf8_fl = 0;
8421    }
8422
8423    if (utf8_flag) {
8424      /* If there is a possibility of UTF8, then if any UTF8 characters
8425         are present, then they must be converted to VTF-7
8426       */
8427      result = strcpy(rslt, path); /* FIX-ME */
8428    }
8429    else
8430      result = strcpy(rslt, path);
8431
8432    return result;
8433 }
8434
8435
8436
8437 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8438 static char *int_tovmsspec
8439    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8440   char *dirend;
8441   char *lastdot;
8442   register char *cp1;
8443   const char *cp2;
8444   unsigned long int infront = 0, hasdir = 1;
8445   int rslt_len;
8446   int no_type_seen;
8447   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8448   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8449
8450   if (vms_debug_fileify) {
8451       if (path == NULL)
8452           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8453       else
8454           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8455   }
8456
8457   if (path == NULL) {
8458       /* If we fail, we should be setting errno */
8459       set_errno(EINVAL);
8460       set_vaxc_errno(SS$_BADPARAM);
8461       return NULL;
8462   }
8463   rslt_len = VMS_MAXRSS-1;
8464
8465   /* '.' and '..' are "[]" and "[-]" for a quick check */
8466   if (path[0] == '.') {
8467     if (path[1] == '\0') {
8468       strcpy(rslt,"[]");
8469       if (utf8_flag != NULL)
8470         *utf8_flag = 0;
8471       return rslt;
8472     }
8473     else {
8474       if (path[1] == '.' && path[2] == '\0') {
8475         strcpy(rslt,"[-]");
8476         if (utf8_flag != NULL)
8477            *utf8_flag = 0;
8478         return rslt;
8479       }
8480     }
8481   }
8482
8483    /* Posix specifications are now a native VMS format */
8484   /*--------------------------------------------------*/
8485 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8486   if (decc_posix_compliant_pathnames) {
8487     if (strncmp(path,"\"^UP^",5) == 0) {
8488       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8489       return rslt;
8490     }
8491   }
8492 #endif
8493
8494   /* This is really the only way to see if this is already in VMS format */
8495   sts = vms_split_path
8496        (path,
8497         &v_spec,
8498         &v_len,
8499         &r_spec,
8500         &r_len,
8501         &d_spec,
8502         &d_len,
8503         &n_spec,
8504         &n_len,
8505         &e_spec,
8506         &e_len,
8507         &vs_spec,
8508         &vs_len);
8509   if (sts == 0) {
8510     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8511        replacement, because the above parse just took care of most of
8512        what is needed to do vmspath when the specification is already
8513        in VMS format.
8514
8515        And if it is not already, it is easier to do the conversion as
8516        part of this routine than to call this routine and then work on
8517        the result.
8518      */
8519
8520     /* If VMS punctuation was found, it is already VMS format */
8521     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8522       if (utf8_flag != NULL)
8523         *utf8_flag = 0;
8524       strcpy(rslt, path);
8525       if (vms_debug_fileify) {
8526           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8527       }
8528       return rslt;
8529     }
8530     /* Now, what to do with trailing "." cases where there is no
8531        extension?  If this is a UNIX specification, and EFS characters
8532        are enabled, then the trailing "." should be converted to a "^.".
8533        But if this was already a VMS specification, then it should be
8534        left alone.
8535
8536        So in the case of ambiguity, leave the specification alone.
8537      */
8538
8539
8540     /* If there is a possibility of UTF8, then if any UTF8 characters
8541         are present, then they must be converted to VTF-7
8542      */
8543     if (utf8_flag != NULL)
8544       *utf8_flag = 0;
8545     strcpy(rslt, path);
8546     if (vms_debug_fileify) {
8547         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8548     }
8549     return rslt;
8550   }
8551
8552   dirend = strrchr(path,'/');
8553
8554   if (dirend == NULL) {
8555      char *macro_start;
8556      int has_macro;
8557
8558      /* If we get here with no UNIX directory delimiters, then this is
8559         not a complete file specification, either garbage a UNIX glob
8560         specification that can not be converted to a VMS wildcard, or
8561         it a UNIX shell macro.  MakeMaker wants shell macros passed
8562         through AS-IS,
8563
8564         utf8 flag setting needs to be preserved.
8565       */
8566       hasdir = 0;
8567
8568       has_macro = 0;
8569       macro_start = strchr(path,'$');
8570       if (macro_start != NULL) {
8571           if (macro_start[1] == '(') {
8572               has_macro = 1;
8573           }
8574       }
8575       if ((decc_efs_charset == 0) || (has_macro)) {
8576           strcpy(rslt, path);
8577           if (vms_debug_fileify) {
8578               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8579           }
8580           return rslt;
8581       }
8582   }
8583
8584 /* If EFS charset mode active, handle the conversion */
8585 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8586   if (decc_efs_charset) {
8587     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8588     if (vms_debug_fileify) {
8589         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8590     }
8591     return rslt;
8592   }
8593 #endif
8594
8595   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8596     if (!*(dirend+2)) dirend +=2;
8597     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8598     if (decc_efs_charset == 0) {
8599       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8600     }
8601   }
8602
8603   cp1 = rslt;
8604   cp2 = path;
8605   lastdot = strrchr(cp2,'.');
8606   if (*cp2 == '/') {
8607     char *trndev;
8608     int islnm, rooted;
8609     STRLEN trnend;
8610
8611     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8612     if (!*(cp2+1)) {
8613       if (decc_disable_posix_root) {
8614         strcpy(rslt,"sys$disk:[000000]");
8615       }
8616       else {
8617         strcpy(rslt,"sys$posix_root:[000000]");
8618       }
8619       if (utf8_flag != NULL)
8620         *utf8_flag = 0;
8621       if (vms_debug_fileify) {
8622           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8623       }
8624       return rslt;
8625     }
8626     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8627     *cp1 = '\0';
8628     trndev = PerlMem_malloc(VMS_MAXRSS);
8629     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8630     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8631
8632      /* DECC special handling */
8633     if (!islnm) {
8634       if (strcmp(rslt,"bin") == 0) {
8635         strcpy(rslt,"sys$system");
8636         cp1 = rslt + 10;
8637         *cp1 = 0;
8638         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8639       }
8640       else if (strcmp(rslt,"tmp") == 0) {
8641         strcpy(rslt,"sys$scratch");
8642         cp1 = rslt + 11;
8643         *cp1 = 0;
8644         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8645       }
8646       else if (!decc_disable_posix_root) {
8647         strcpy(rslt, "sys$posix_root");
8648         cp1 = rslt + 14;
8649         *cp1 = 0;
8650         cp2 = path;
8651         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8652         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8653       }
8654       else if (strcmp(rslt,"dev") == 0) {
8655         if (strncmp(cp2,"/null", 5) == 0) {
8656           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8657             strcpy(rslt,"NLA0");
8658             cp1 = rslt + 4;
8659             *cp1 = 0;
8660             cp2 = cp2 + 5;
8661             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8662           }
8663         }
8664       }
8665     }
8666
8667     trnend = islnm ? strlen(trndev) - 1 : 0;
8668     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8669     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8670     /* If the first element of the path is a logical name, determine
8671      * whether it has to be translated so we can add more directories. */
8672     if (!islnm || rooted) {
8673       *(cp1++) = ':';
8674       *(cp1++) = '[';
8675       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8676       else cp2++;
8677     }
8678     else {
8679       if (cp2 != dirend) {
8680         strcpy(rslt,trndev);
8681         cp1 = rslt + trnend;
8682         if (*cp2 != 0) {
8683           *(cp1++) = '.';
8684           cp2++;
8685         }
8686       }
8687       else {
8688         if (decc_disable_posix_root) {
8689           *(cp1++) = ':';
8690           hasdir = 0;
8691         }
8692       }
8693     }
8694     PerlMem_free(trndev);
8695   }
8696   else {
8697     *(cp1++) = '[';
8698     if (*cp2 == '.') {
8699       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8700         cp2 += 2;         /* skip over "./" - it's redundant */
8701         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8702       }
8703       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8704         *(cp1++) = '-';                                 /* "../" --> "-" */
8705         cp2 += 3;
8706       }
8707       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8708                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8709         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8710         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8711         cp2 += 4;
8712       }
8713       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8714         /* Escape the extra dots in EFS file specifications */
8715         *(cp1++) = '^';
8716       }
8717       if (cp2 > dirend) cp2 = dirend;
8718     }
8719     else *(cp1++) = '.';
8720   }
8721   for (; cp2 < dirend; cp2++) {
8722     if (*cp2 == '/') {
8723       if (*(cp2-1) == '/') continue;
8724       if (*(cp1-1) != '.') *(cp1++) = '.';
8725       infront = 0;
8726     }
8727     else if (!infront && *cp2 == '.') {
8728       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8729       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8730       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8731         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8732         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8733         else {  /* back up over previous directory name */
8734           cp1--;
8735           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8736           if (*(cp1-1) == '[') {
8737             memcpy(cp1,"000000.",7);
8738             cp1 += 7;
8739           }
8740         }
8741         cp2 += 2;
8742         if (cp2 == dirend) break;
8743       }
8744       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8745                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8746         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8747         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8748         if (!*(cp2+3)) {
8749           *(cp1++) = '.';  /* Simulate trailing '/' */
8750           cp2 += 2;  /* for loop will incr this to == dirend */
8751         }
8752         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8753       }
8754       else {
8755         if (decc_efs_charset == 0)
8756           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8757         else {
8758           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8759           *(cp1++) = '.';
8760         }
8761       }
8762     }
8763     else {
8764       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8765       if (*cp2 == '.') {
8766         if (decc_efs_charset == 0)
8767           *(cp1++) = '_';
8768         else {
8769           *(cp1++) = '^';
8770           *(cp1++) = '.';
8771         }
8772       }
8773       else                  *(cp1++) =  *cp2;
8774       infront = 1;
8775     }
8776   }
8777   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8778   if (hasdir) *(cp1++) = ']';
8779   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8780   /* fixme for ODS5 */
8781   no_type_seen = 0;
8782   if (cp2 > lastdot)
8783     no_type_seen = 1;
8784   while (*cp2) {
8785     switch(*cp2) {
8786     case '?':
8787         if (decc_efs_charset == 0)
8788           *(cp1++) = '%';
8789         else
8790           *(cp1++) = '?';
8791         cp2++;
8792     case ' ':
8793         *(cp1)++ = '^';
8794         *(cp1)++ = '_';
8795         cp2++;
8796         break;
8797     case '.':
8798         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8799             decc_readdir_dropdotnotype) {
8800           *(cp1)++ = '^';
8801           *(cp1)++ = '.';
8802           cp2++;
8803
8804           /* trailing dot ==> '^..' on VMS */
8805           if (*cp2 == '\0') {
8806             *(cp1++) = '.';
8807             no_type_seen = 0;
8808           }
8809         }
8810         else {
8811           *(cp1++) = *(cp2++);
8812           no_type_seen = 0;
8813         }
8814         break;
8815     case '$':
8816          /* This could be a macro to be passed through */
8817         *(cp1++) = *(cp2++);
8818         if (*cp2 == '(') {
8819         const char * save_cp2;
8820         char * save_cp1;
8821         int is_macro;
8822
8823             /* paranoid check */
8824             save_cp2 = cp2;
8825             save_cp1 = cp1;
8826             is_macro = 0;
8827
8828             /* Test through */
8829             *(cp1++) = *(cp2++);
8830             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8831                 *(cp1++) = *(cp2++);
8832                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8833                     *(cp1++) = *(cp2++);
8834                 }
8835                 if (*cp2 == ')') {
8836                     *(cp1++) = *(cp2++);
8837                     is_macro = 1;
8838                 }
8839             }
8840             if (is_macro == 0) {
8841                 /* Not really a macro - never mind */
8842                 cp2 = save_cp2;
8843                 cp1 = save_cp1;
8844             }
8845         }
8846         break;
8847     case '\"':
8848     case '~':
8849     case '`':
8850     case '!':
8851     case '#':
8852     case '%':
8853     case '^':
8854         /* Don't escape again if following character is
8855          * already something we escape.
8856          */
8857         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8858             *(cp1++) = *(cp2++);
8859             break;
8860         }
8861         /* But otherwise fall through and escape it. */
8862     case '&':
8863     case '(':
8864     case ')':
8865     case '=':
8866     case '+':
8867     case '\'':
8868     case '@':
8869     case '[':
8870     case ']':
8871     case '{':
8872     case '}':
8873     case ':':
8874     case '\\':
8875     case '|':
8876     case '<':
8877     case '>':
8878         *(cp1++) = '^';
8879         *(cp1++) = *(cp2++);
8880         break;
8881     case ';':
8882         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8883          * which is wrong.  UNIX notation should be ".dir." unless
8884          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8885          * changing this behavior could break more things at this time.
8886          * efs character set effectively does not allow "." to be a version
8887          * delimiter as a further complication about changing this.
8888          */
8889         if (decc_filename_unix_report != 0) {
8890           *(cp1++) = '^';
8891         }
8892         *(cp1++) = *(cp2++);
8893         break;
8894     default:
8895         *(cp1++) = *(cp2++);
8896     }
8897   }
8898   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8899   char *lcp1;
8900     lcp1 = cp1;
8901     lcp1--;
8902      /* Fix me for "^]", but that requires making sure that you do
8903       * not back up past the start of the filename
8904       */
8905     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8906       *cp1++ = '.';
8907   }
8908   *cp1 = '\0';
8909
8910   if (utf8_flag != NULL)
8911     *utf8_flag = 0;
8912   if (vms_debug_fileify) {
8913       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8914   }
8915   return rslt;
8916
8917 }  /* end of int_tovmsspec() */
8918
8919
8920 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8921 static char *mp_do_tovmsspec
8922    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8923   static char __tovmsspec_retbuf[VMS_MAXRSS];
8924     char * vmsspec, *ret_spec, *ret_buf;
8925
8926     vmsspec = NULL;
8927     ret_buf = buf;
8928     if (ret_buf == NULL) {
8929         if (ts) {
8930             Newx(vmsspec, VMS_MAXRSS, char);
8931             if (vmsspec == NULL)
8932                 _ckvmssts(SS$_INSFMEM);
8933             ret_buf = vmsspec;
8934         } else {
8935             ret_buf = __tovmsspec_retbuf;
8936         }
8937     }
8938
8939     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8940
8941     if (ret_spec == NULL) {
8942        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8943        if (vmsspec)
8944            Safefree(vmsspec);
8945     }
8946
8947     return ret_spec;
8948
8949 }  /* end of mp_do_tovmsspec() */
8950 /*}}}*/
8951 /* External entry points */
8952 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8953   { return do_tovmsspec(path,buf,0,NULL); }
8954 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8955   { return do_tovmsspec(path,buf,1,NULL); }
8956 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8957   { return do_tovmsspec(path,buf,0,utf8_fl); }
8958 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8959   { return do_tovmsspec(path,buf,1,utf8_fl); }
8960
8961 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8962 /* Internal routine for use with out an explicit context present */
8963 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
8964
8965     char * ret_spec, *pathified;
8966
8967     if (path == NULL)
8968         return NULL;
8969
8970     pathified = PerlMem_malloc(VMS_MAXRSS);
8971     if (pathified == NULL)
8972         _ckvmssts_noperl(SS$_INSFMEM);
8973
8974     ret_spec = int_pathify_dirspec(path, pathified);
8975
8976     if (ret_spec == NULL) {
8977         PerlMem_free(pathified);
8978         return NULL;
8979     }
8980
8981     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8982
8983     PerlMem_free(pathified);
8984     return ret_spec;
8985
8986 }
8987
8988 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8989 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8990   static char __tovmspath_retbuf[VMS_MAXRSS];
8991   int vmslen;
8992   char *pathified, *vmsified, *cp;
8993
8994   if (path == NULL) return NULL;
8995   pathified = PerlMem_malloc(VMS_MAXRSS);
8996   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8997   if (int_pathify_dirspec(path, pathified) == NULL) {
8998     PerlMem_free(pathified);
8999     return NULL;
9000   }
9001
9002   vmsified = NULL;
9003   if (buf == NULL)
9004      Newx(vmsified, VMS_MAXRSS, char);
9005   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
9006     PerlMem_free(pathified);
9007     if (vmsified) Safefree(vmsified);
9008     return NULL;
9009   }
9010   PerlMem_free(pathified);
9011   if (buf) {
9012     return buf;
9013   }
9014   else if (ts) {
9015     vmslen = strlen(vmsified);
9016     Newx(cp,vmslen+1,char);
9017     memcpy(cp,vmsified,vmslen);
9018     cp[vmslen] = '\0';
9019     Safefree(vmsified);
9020     return cp;
9021   }
9022   else {
9023     strcpy(__tovmspath_retbuf,vmsified);
9024     Safefree(vmsified);
9025     return __tovmspath_retbuf;
9026   }
9027
9028 }  /* end of do_tovmspath() */
9029 /*}}}*/
9030 /* External entry points */
9031 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
9032   { return do_tovmspath(path,buf,0, NULL); }
9033 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9034   { return do_tovmspath(path,buf,1, NULL); }
9035 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9036   { return do_tovmspath(path,buf,0,utf8_fl); }
9037 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9038   { return do_tovmspath(path,buf,1,utf8_fl); }
9039
9040
9041 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9042 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9043   static char __tounixpath_retbuf[VMS_MAXRSS];
9044   int unixlen;
9045   char *pathified, *unixified, *cp;
9046
9047   if (path == NULL) return NULL;
9048   pathified = PerlMem_malloc(VMS_MAXRSS);
9049   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9050   if (int_pathify_dirspec(path, pathified) == NULL) {
9051     PerlMem_free(pathified);
9052     return NULL;
9053   }
9054
9055   unixified = NULL;
9056   if (buf == NULL) {
9057       Newx(unixified, VMS_MAXRSS, char);
9058   }
9059   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9060     PerlMem_free(pathified);
9061     if (unixified) Safefree(unixified);
9062     return NULL;
9063   }
9064   PerlMem_free(pathified);
9065   if (buf) {
9066     return buf;
9067   }
9068   else if (ts) {
9069     unixlen = strlen(unixified);
9070     Newx(cp,unixlen+1,char);
9071     memcpy(cp,unixified,unixlen);
9072     cp[unixlen] = '\0';
9073     Safefree(unixified);
9074     return cp;
9075   }
9076   else {
9077     strcpy(__tounixpath_retbuf,unixified);
9078     Safefree(unixified);
9079     return __tounixpath_retbuf;
9080   }
9081
9082 }  /* end of do_tounixpath() */
9083 /*}}}*/
9084 /* External entry points */
9085 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
9086   { return do_tounixpath(path,buf,0,NULL); }
9087 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9088   { return do_tounixpath(path,buf,1,NULL); }
9089 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9090   { return do_tounixpath(path,buf,0,utf8_fl); }
9091 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9092   { return do_tounixpath(path,buf,1,utf8_fl); }
9093
9094 /*
9095  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
9096  *
9097  *****************************************************************************
9098  *                                                                           *
9099  *  Copyright (C) 1989-1994, 2007 by                                         *
9100  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
9101  *                                                                           *
9102  *  Permission is hereby granted for the reproduction of this software       *
9103  *  on condition that this copyright notice is included in source            *
9104  *  distributions of the software.  The code may be modified and             *
9105  *  distributed under the same terms as Perl itself.                         *
9106  *                                                                           *
9107  *  27-Aug-1994 Modified for inclusion in perl5                              *
9108  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9109  *****************************************************************************
9110  */
9111
9112 /*
9113  * getredirection() is intended to aid in porting C programs
9114  * to VMS (Vax-11 C).  The native VMS environment does not support
9115  * '>' and '<' I/O redirection, or command line wild card expansion,
9116  * or a command line pipe mechanism using the '|' AND background
9117  * command execution '&'.  All of these capabilities are provided to any
9118  * C program which calls this procedure as the first thing in the
9119  * main program.
9120  * The piping mechanism will probably work with almost any 'filter' type
9121  * of program.  With suitable modification, it may useful for other
9122  * portability problems as well.
9123  *
9124  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9125  */
9126 struct list_item
9127     {
9128     struct list_item *next;
9129     char *value;
9130     };
9131
9132 static void add_item(struct list_item **head,
9133                      struct list_item **tail,
9134                      char *value,
9135                      int *count);
9136
9137 static void mp_expand_wild_cards(pTHX_ char *item,
9138                                 struct list_item **head,
9139                                 struct list_item **tail,
9140                                 int *count);
9141
9142 static int background_process(pTHX_ int argc, char **argv);
9143
9144 static void pipe_and_fork(pTHX_ char **cmargv);
9145
9146 /*{{{ void getredirection(int *ac, char ***av)*/
9147 static void
9148 mp_getredirection(pTHX_ int *ac, char ***av)
9149 /*
9150  * Process vms redirection arg's.  Exit if any error is seen.
9151  * If getredirection() processes an argument, it is erased
9152  * from the vector.  getredirection() returns a new argc and argv value.
9153  * In the event that a background command is requested (by a trailing "&"),
9154  * this routine creates a background subprocess, and simply exits the program.
9155  *
9156  * Warning: do not try to simplify the code for vms.  The code
9157  * presupposes that getredirection() is called before any data is
9158  * read from stdin or written to stdout.
9159  *
9160  * Normal usage is as follows:
9161  *
9162  *      main(argc, argv)
9163  *      int             argc;
9164  *      char            *argv[];
9165  *      {
9166  *              getredirection(&argc, &argv);
9167  *      }
9168  */
9169 {
9170     int                 argc = *ac;     /* Argument Count         */
9171     char                **argv = *av;   /* Argument Vector        */
9172     char                *ap;            /* Argument pointer       */
9173     int                 j;              /* argv[] index           */
9174     int                 item_count = 0; /* Count of Items in List */
9175     struct list_item    *list_head = 0; /* First Item in List       */
9176     struct list_item    *list_tail;     /* Last Item in List        */
9177     char                *in = NULL;     /* Input File Name          */
9178     char                *out = NULL;    /* Output File Name         */
9179     char                *outmode = "w"; /* Mode to Open Output File */
9180     char                *err = NULL;    /* Error File Name          */
9181     char                *errmode = "w"; /* Mode to Open Error File  */
9182     int                 cmargc = 0;     /* Piped Command Arg Count  */
9183     char                **cmargv = NULL;/* Piped Command Arg Vector */
9184
9185     /*
9186      * First handle the case where the last thing on the line ends with
9187      * a '&'.  This indicates the desire for the command to be run in a
9188      * subprocess, so we satisfy that desire.
9189      */
9190     ap = argv[argc-1];
9191     if (0 == strcmp("&", ap))
9192        exit(background_process(aTHX_ --argc, argv));
9193     if (*ap && '&' == ap[strlen(ap)-1])
9194         {
9195         ap[strlen(ap)-1] = '\0';
9196        exit(background_process(aTHX_ argc, argv));
9197         }
9198     /*
9199      * Now we handle the general redirection cases that involve '>', '>>',
9200      * '<', and pipes '|'.
9201      */
9202     for (j = 0; j < argc; ++j)
9203         {
9204         if (0 == strcmp("<", argv[j]))
9205             {
9206             if (j+1 >= argc)
9207                 {
9208                 fprintf(stderr,"No input file after < on command line");
9209                 exit(LIB$_WRONUMARG);
9210                 }
9211             in = argv[++j];
9212             continue;
9213             }
9214         if ('<' == *(ap = argv[j]))
9215             {
9216             in = 1 + ap;
9217             continue;
9218             }
9219         if (0 == strcmp(">", ap))
9220             {
9221             if (j+1 >= argc)
9222                 {
9223                 fprintf(stderr,"No output file after > on command line");
9224                 exit(LIB$_WRONUMARG);
9225                 }
9226             out = argv[++j];
9227             continue;
9228             }
9229         if ('>' == *ap)
9230             {
9231             if ('>' == ap[1])
9232                 {
9233                 outmode = "a";
9234                 if ('\0' == ap[2])
9235                     out = argv[++j];
9236                 else
9237                     out = 2 + ap;
9238                 }
9239             else
9240                 out = 1 + ap;
9241             if (j >= argc)
9242                 {
9243                 fprintf(stderr,"No output file after > or >> on command line");
9244                 exit(LIB$_WRONUMARG);
9245                 }
9246             continue;
9247             }
9248         if (('2' == *ap) && ('>' == ap[1]))
9249             {
9250             if ('>' == ap[2])
9251                 {
9252                 errmode = "a";
9253                 if ('\0' == ap[3])
9254                     err = argv[++j];
9255                 else
9256                     err = 3 + ap;
9257                 }
9258             else
9259                 if ('\0' == ap[2])
9260                     err = argv[++j];
9261                 else
9262                     err = 2 + ap;
9263             if (j >= argc)
9264                 {
9265                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9266                 exit(LIB$_WRONUMARG);
9267                 }
9268             continue;
9269             }
9270         if (0 == strcmp("|", argv[j]))
9271             {
9272             if (j+1 >= argc)
9273                 {
9274                 fprintf(stderr,"No command into which to pipe on command line");
9275                 exit(LIB$_WRONUMARG);
9276                 }
9277             cmargc = argc-(j+1);
9278             cmargv = &argv[j+1];
9279             argc = j;
9280             continue;
9281             }
9282         if ('|' == *(ap = argv[j]))
9283             {
9284             ++argv[j];
9285             cmargc = argc-j;
9286             cmargv = &argv[j];
9287             argc = j;
9288             continue;
9289             }
9290         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9291         }
9292     /*
9293      * Allocate and fill in the new argument vector, Some Unix's terminate
9294      * the list with an extra null pointer.
9295      */
9296     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9297     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9298     *av = argv;
9299     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9300         argv[j] = list_head->value;
9301     *ac = item_count;
9302     if (cmargv != NULL)
9303         {
9304         if (out != NULL)
9305             {
9306             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9307             exit(LIB$_INVARGORD);
9308             }
9309         pipe_and_fork(aTHX_ cmargv);
9310         }
9311
9312     /* Check for input from a pipe (mailbox) */
9313
9314     if (in == NULL && 1 == isapipe(0))
9315         {
9316         char mbxname[L_tmpnam];
9317         long int bufsize;
9318         long int dvi_item = DVI$_DEVBUFSIZ;
9319         $DESCRIPTOR(mbxnam, "");
9320         $DESCRIPTOR(mbxdevnam, "");
9321
9322         /* Input from a pipe, reopen it in binary mode to disable       */
9323         /* carriage control processing.                                 */
9324
9325         fgetname(stdin, mbxname, 1);
9326         mbxnam.dsc$a_pointer = mbxname;
9327         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9328         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9329         mbxdevnam.dsc$a_pointer = mbxname;
9330         mbxdevnam.dsc$w_length = sizeof(mbxname);
9331         dvi_item = DVI$_DEVNAM;
9332         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9333         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9334         set_errno(0);
9335         set_vaxc_errno(1);
9336         freopen(mbxname, "rb", stdin);
9337         if (errno != 0)
9338             {
9339             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9340             exit(vaxc$errno);
9341             }
9342         }
9343     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9344         {
9345         fprintf(stderr,"Can't open input file %s as stdin",in);
9346         exit(vaxc$errno);
9347         }
9348     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9349         {
9350         fprintf(stderr,"Can't open output file %s as stdout",out);
9351         exit(vaxc$errno);
9352         }
9353         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9354
9355     if (err != NULL) {
9356         if (strcmp(err,"&1") == 0) {
9357             dup2(fileno(stdout), fileno(stderr));
9358             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9359         } else {
9360         FILE *tmperr;
9361         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9362             {
9363             fprintf(stderr,"Can't open error file %s as stderr",err);
9364             exit(vaxc$errno);
9365             }
9366             fclose(tmperr);
9367            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9368                 {
9369                 exit(vaxc$errno);
9370                 }
9371             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9372         }
9373         }
9374 #ifdef ARGPROC_DEBUG
9375     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9376     for (j = 0; j < *ac;  ++j)
9377         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9378 #endif
9379    /* Clear errors we may have hit expanding wildcards, so they don't
9380       show up in Perl's $! later */
9381    set_errno(0); set_vaxc_errno(1);
9382 }  /* end of getredirection() */
9383 /*}}}*/
9384
9385 static void add_item(struct list_item **head,
9386                      struct list_item **tail,
9387                      char *value,
9388                      int *count)
9389 {
9390     if (*head == 0)
9391         {
9392         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9393         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9394         *tail = *head;
9395         }
9396     else {
9397         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9398         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9399         *tail = (*tail)->next;
9400         }
9401     (*tail)->value = value;
9402     ++(*count);
9403 }
9404
9405 static void mp_expand_wild_cards(pTHX_ char *item,
9406                               struct list_item **head,
9407                               struct list_item **tail,
9408                               int *count)
9409 {
9410 int expcount = 0;
9411 unsigned long int context = 0;
9412 int isunix = 0;
9413 int item_len = 0;
9414 char *had_version;
9415 char *had_device;
9416 int had_directory;
9417 char *devdir,*cp;
9418 char *vmsspec;
9419 $DESCRIPTOR(filespec, "");
9420 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9421 $DESCRIPTOR(resultspec, "");
9422 unsigned long int lff_flags = 0;
9423 int sts;
9424 int rms_sts;
9425
9426 #ifdef VMS_LONGNAME_SUPPORT
9427     lff_flags = LIB$M_FIL_LONG_NAMES;
9428 #endif
9429
9430     for (cp = item; *cp; cp++) {
9431         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9432         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9433     }
9434     if (!*cp || isspace(*cp))
9435         {
9436         add_item(head, tail, item, count);
9437         return;
9438         }
9439     else
9440         {
9441      /* "double quoted" wild card expressions pass as is */
9442      /* From DCL that means using e.g.:                  */
9443      /* perl program """perl.*"""                        */
9444      item_len = strlen(item);
9445      if ( '"' == *item && '"' == item[item_len-1] )
9446        {
9447        item++;
9448        item[item_len-2] = '\0';
9449        add_item(head, tail, item, count);
9450        return;
9451        }
9452      }
9453     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9454     resultspec.dsc$b_class = DSC$K_CLASS_D;
9455     resultspec.dsc$a_pointer = NULL;
9456     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9457     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9458     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9459       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9460     if (!isunix || !filespec.dsc$a_pointer)
9461       filespec.dsc$a_pointer = item;
9462     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9463     /*
9464      * Only return version specs, if the caller specified a version
9465      */
9466     had_version = strchr(item, ';');
9467     /*
9468      * Only return device and directory specs, if the caller specified either.
9469      */
9470     had_device = strchr(item, ':');
9471     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9472
9473     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9474                                  (&filespec, &resultspec, &context,
9475                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9476         {
9477         char *string;
9478         char *c;
9479
9480         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9481         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9482         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9483         string[resultspec.dsc$w_length] = '\0';
9484         if (NULL == had_version)
9485             *(strrchr(string, ';')) = '\0';
9486         if ((!had_directory) && (had_device == NULL))
9487             {
9488             if (NULL == (devdir = strrchr(string, ']')))
9489                 devdir = strrchr(string, '>');
9490             strcpy(string, devdir + 1);
9491             }
9492         /*
9493          * Be consistent with what the C RTL has already done to the rest of
9494          * the argv items and lowercase all of these names.
9495          */
9496         if (!decc_efs_case_preserve) {
9497             for (c = string; *c; ++c)
9498             if (isupper(*c))
9499                 *c = tolower(*c);
9500         }
9501         if (isunix) trim_unixpath(string,item,1);
9502         add_item(head, tail, string, count);
9503         ++expcount;
9504     }
9505     PerlMem_free(vmsspec);
9506     if (sts != RMS$_NMF)
9507         {
9508         set_vaxc_errno(sts);
9509         switch (sts)
9510             {
9511             case RMS$_FNF: case RMS$_DNF:
9512                 set_errno(ENOENT); break;
9513             case RMS$_DIR:
9514                 set_errno(ENOTDIR); break;
9515             case RMS$_DEV:
9516                 set_errno(ENODEV); break;
9517             case RMS$_FNM: case RMS$_SYN:
9518                 set_errno(EINVAL); break;
9519             case RMS$_PRV:
9520                 set_errno(EACCES); break;
9521             default:
9522                 _ckvmssts_noperl(sts);
9523             }
9524         }
9525     if (expcount == 0)
9526         add_item(head, tail, item, count);
9527     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9528     _ckvmssts_noperl(lib$find_file_end(&context));
9529 }
9530
9531 static int child_st[2];/* Event Flag set when child process completes   */
9532
9533 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9534
9535 static unsigned long int exit_handler(int *status)
9536 {
9537 short iosb[4];
9538
9539     if (0 == child_st[0])
9540         {
9541 #ifdef ARGPROC_DEBUG
9542         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9543 #endif
9544         fflush(stdout);     /* Have to flush pipe for binary data to    */
9545                             /* terminate properly -- <tp@mccall.com>    */
9546         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9547         sys$dassgn(child_chan);
9548         fclose(stdout);
9549         sys$synch(0, child_st);
9550         }
9551     return(1);
9552 }
9553
9554 static void sig_child(int chan)
9555 {
9556 #ifdef ARGPROC_DEBUG
9557     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9558 #endif
9559     if (child_st[0] == 0)
9560         child_st[0] = 1;
9561 }
9562
9563 static struct exit_control_block exit_block =
9564     {
9565     0,
9566     exit_handler,
9567     1,
9568     &exit_block.exit_status,
9569     0
9570     };
9571
9572 static void
9573 pipe_and_fork(pTHX_ char **cmargv)
9574 {
9575     PerlIO *fp;
9576     struct dsc$descriptor_s *vmscmd;
9577     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9578     int sts, j, l, ismcr, quote, tquote = 0;
9579
9580     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9581     vms_execfree(vmscmd);
9582
9583     j = l = 0;
9584     p = subcmd;
9585     q = cmargv[0];
9586     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9587               && toupper(*(q+2)) == 'R' && !*(q+3);
9588
9589     while (q && l < MAX_DCL_LINE_LENGTH) {
9590         if (!*q) {
9591             if (j > 0 && quote) {
9592                 *p++ = '"';
9593                 l++;
9594             }
9595             q = cmargv[++j];
9596             if (q) {
9597                 if (ismcr && j > 1) quote = 1;
9598                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9599                 *p++ = ' ';
9600                 l++;
9601                 if (quote || tquote) {
9602                     *p++ = '"';
9603                     l++;
9604                 }
9605             }
9606         } else {
9607             if ((quote||tquote) && *q == '"') {
9608                 *p++ = '"';
9609                 l++;
9610             }
9611             *p++ = *q++;
9612             l++;
9613         }
9614     }
9615     *p = '\0';
9616
9617     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9618     if (fp == NULL) {
9619         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9620     }
9621 }
9622
9623 static int background_process(pTHX_ int argc, char **argv)
9624 {
9625 char command[MAX_DCL_SYMBOL + 1] = "$";
9626 $DESCRIPTOR(value, "");
9627 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9628 static $DESCRIPTOR(null, "NLA0:");
9629 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9630 char pidstring[80];
9631 $DESCRIPTOR(pidstr, "");
9632 int pid;
9633 unsigned long int flags = 17, one = 1, retsts;
9634 int len;
9635
9636     strcat(command, argv[0]);
9637     len = strlen(command);
9638     while (--argc && (len < MAX_DCL_SYMBOL))
9639         {
9640         strcat(command, " \"");
9641         strcat(command, *(++argv));
9642         strcat(command, "\"");
9643         len = strlen(command);
9644         }
9645     value.dsc$a_pointer = command;
9646     value.dsc$w_length = strlen(value.dsc$a_pointer);
9647     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9648     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9649     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9650         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9651     }
9652     else {
9653         _ckvmssts_noperl(retsts);
9654     }
9655 #ifdef ARGPROC_DEBUG
9656     PerlIO_printf(Perl_debug_log, "%s\n", command);
9657 #endif
9658     sprintf(pidstring, "%08X", pid);
9659     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9660     pidstr.dsc$a_pointer = pidstring;
9661     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9662     lib$set_symbol(&pidsymbol, &pidstr);
9663     return(SS$_NORMAL);
9664 }
9665 /*}}}*/
9666 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9667
9668
9669 /* OS-specific initialization at image activation (not thread startup) */
9670 /* Older VAXC header files lack these constants */
9671 #ifndef JPI$_RIGHTS_SIZE
9672 #  define JPI$_RIGHTS_SIZE 817
9673 #endif
9674 #ifndef KGB$M_SUBSYSTEM
9675 #  define KGB$M_SUBSYSTEM 0x8
9676 #endif
9677
9678 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9679
9680 /*{{{void vms_image_init(int *, char ***)*/
9681 void
9682 vms_image_init(int *argcp, char ***argvp)
9683 {
9684   int status;
9685   char eqv[LNM$C_NAMLENGTH+1] = "";
9686   unsigned int len, tabct = 8, tabidx = 0;
9687   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9688   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9689   unsigned short int dummy, rlen;
9690   struct dsc$descriptor_s **tabvec;
9691 #if defined(PERL_IMPLICIT_CONTEXT)
9692   pTHX = NULL;
9693 #endif
9694   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9695                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9696                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9697                                  {          0,                0,    0,      0} };
9698
9699 #ifdef KILL_BY_SIGPRC
9700     Perl_csighandler_init();
9701 #endif
9702
9703 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9704     /* This was moved from the pre-image init handler because on threaded */
9705     /* Perl it was always returning 0 for the default value. */
9706     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9707     if (status > 0) {
9708         int s;
9709         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9710         if (s > 0) {
9711             int initial;
9712             initial = decc$feature_get_value(s, 4);
9713             if (initial > 0) {
9714                 /* initial is: 0 if nothing has set the feature */
9715                 /*            -1 if initialized to default */
9716                 /*             1 if set by logical name */
9717                 /*             2 if set by decc$feature_set_value */
9718                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9719
9720                 /* If the value is not valid, force the feature off */
9721                 if (decc_disable_posix_root < 0) {
9722                     decc$feature_set_value(s, 1, 1);
9723                     decc_disable_posix_root = 1;
9724                 }
9725             }
9726             else {
9727                 /* Nothing has asked for it explicitly, so use our own default. */
9728                 decc_disable_posix_root = 1;
9729                 decc$feature_set_value(s, 1, 1);
9730             }
9731         }
9732     }
9733 #endif
9734
9735   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9736   _ckvmssts_noperl(iosb[0]);
9737   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9738     if (iprv[i]) {           /* Running image installed with privs? */
9739       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9740       will_taint = TRUE;
9741       break;
9742     }
9743   }
9744   /* Rights identifiers might trigger tainting as well. */
9745   if (!will_taint && (rlen || rsz)) {
9746     while (rlen < rsz) {
9747       /* We didn't get all the identifiers on the first pass.  Allocate a
9748        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9749        * were needed to hold all identifiers at time of last call; we'll
9750        * allocate that many unsigned long ints), and go back and get 'em.
9751        * If it gave us less than it wanted to despite ample buffer space,
9752        * something's broken.  Is your system missing a system identifier?
9753        */
9754       if (rsz <= jpilist[1].buflen) {
9755          /* Perl_croak accvios when used this early in startup. */
9756          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9757                          rsz, (unsigned long) jpilist[1].buflen,
9758                          "Check your rights database for corruption.\n");
9759          exit(SS$_ABORT);
9760       }
9761       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9762       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9763       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9764       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9765       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9766       _ckvmssts_noperl(iosb[0]);
9767     }
9768     mask = jpilist[1].bufadr;
9769     /* Check attribute flags for each identifier (2nd longword); protected
9770      * subsystem identifiers trigger tainting.
9771      */
9772     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9773       if (mask[i] & KGB$M_SUBSYSTEM) {
9774         will_taint = TRUE;
9775         break;
9776       }
9777     }
9778     if (mask != rlst) PerlMem_free(mask);
9779   }
9780
9781   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9782    * logical, some versions of the CRTL will add a phanthom /000000/
9783    * directory.  This needs to be removed.
9784    */
9785   if (decc_filename_unix_report) {
9786   char * zeros;
9787   int ulen;
9788     ulen = strlen(argvp[0][0]);
9789     if (ulen > 7) {
9790       zeros = strstr(argvp[0][0], "/000000/");
9791       if (zeros != NULL) {
9792         int mlen;
9793         mlen = ulen - (zeros - argvp[0][0]) - 7;
9794         memmove(zeros, &zeros[7], mlen);
9795         ulen = ulen - 7;
9796         argvp[0][0][ulen] = '\0';
9797       }
9798     }
9799     /* It also may have a trailing dot that needs to be removed otherwise
9800      * it will be converted to VMS mode incorrectly.
9801      */
9802     ulen--;
9803     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9804       argvp[0][0][ulen] = '\0';
9805   }
9806
9807   /* We need to use this hack to tell Perl it should run with tainting,
9808    * since its tainting flag may be part of the PL_curinterp struct, which
9809    * hasn't been allocated when vms_image_init() is called.
9810    */
9811   if (will_taint) {
9812     char **newargv, **oldargv;
9813     oldargv = *argvp;
9814     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9815     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9816     newargv[0] = oldargv[0];
9817     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9818     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9819     strcpy(newargv[1], "-T");
9820     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9821     (*argcp)++;
9822     newargv[*argcp] = NULL;
9823     /* We orphan the old argv, since we don't know where it's come from,
9824      * so we don't know how to free it.
9825      */
9826     *argvp = newargv;
9827   }
9828   else {  /* Did user explicitly request tainting? */
9829     int i;
9830     char *cp, **av = *argvp;
9831     for (i = 1; i < *argcp; i++) {
9832       if (*av[i] != '-') break;
9833       for (cp = av[i]+1; *cp; cp++) {
9834         if (*cp == 'T') { will_taint = 1; break; }
9835         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9836                   strchr("DFIiMmx",*cp)) break;
9837       }
9838       if (will_taint) break;
9839     }
9840   }
9841
9842   for (tabidx = 0;
9843        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9844        tabidx++) {
9845     if (!tabidx) {
9846       tabvec = (struct dsc$descriptor_s **)
9847             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9848       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9849     }
9850     else if (tabidx >= tabct) {
9851       tabct += 8;
9852       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9853       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9854     }
9855     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9856     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9857     tabvec[tabidx]->dsc$w_length  = 0;
9858     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9859     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9860     tabvec[tabidx]->dsc$a_pointer = NULL;
9861     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9862   }
9863   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9864
9865   getredirection(argcp,argvp);
9866 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9867   {
9868 # include <reentrancy.h>
9869   decc$set_reentrancy(C$C_MULTITHREAD);
9870   }
9871 #endif
9872   return;
9873 }
9874 /*}}}*/
9875
9876
9877 /* trim_unixpath()
9878  * Trim Unix-style prefix off filespec, so it looks like what a shell
9879  * glob expansion would return (i.e. from specified prefix on, not
9880  * full path).  Note that returned filespec is Unix-style, regardless
9881  * of whether input filespec was VMS-style or Unix-style.
9882  *
9883  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9884  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9885  * vector of options; at present, only bit 0 is used, and if set tells
9886  * trim unixpath to try the current default directory as a prefix when
9887  * presented with a possibly ambiguous ... wildcard.
9888  *
9889  * Returns !=0 on success, with trimmed filespec replacing contents of
9890  * fspec, and 0 on failure, with contents of fpsec unchanged.
9891  */
9892 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9893 int
9894 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9895 {
9896   char *unixified, *unixwild,
9897        *template, *base, *end, *cp1, *cp2;
9898   register int tmplen, reslen = 0, dirs = 0;
9899
9900   if (!wildspec || !fspec) return 0;
9901
9902   unixwild = PerlMem_malloc(VMS_MAXRSS);
9903   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9904   template = unixwild;
9905   if (strpbrk(wildspec,"]>:") != NULL) {
9906     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9907         PerlMem_free(unixwild);
9908         return 0;
9909     }
9910   }
9911   else {
9912     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9913     unixwild[VMS_MAXRSS-1] = 0;
9914   }
9915   unixified = PerlMem_malloc(VMS_MAXRSS);
9916   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9917   if (strpbrk(fspec,"]>:") != NULL) {
9918     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9919         PerlMem_free(unixwild);
9920         PerlMem_free(unixified);
9921         return 0;
9922     }
9923     else base = unixified;
9924     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9925      * check to see that final result fits into (isn't longer than) fspec */
9926     reslen = strlen(fspec);
9927   }
9928   else base = fspec;
9929
9930   /* No prefix or absolute path on wildcard, so nothing to remove */
9931   if (!*template || *template == '/') {
9932     PerlMem_free(unixwild);
9933     if (base == fspec) {
9934         PerlMem_free(unixified);
9935         return 1;
9936     }
9937     tmplen = strlen(unixified);
9938     if (tmplen > reslen) {
9939         PerlMem_free(unixified);
9940         return 0;  /* not enough space */
9941     }
9942     /* Copy unixified resultant, including trailing NUL */
9943     memmove(fspec,unixified,tmplen+1);
9944     PerlMem_free(unixified);
9945     return 1;
9946   }
9947
9948   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9949   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9950     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9951     for (cp1 = end ;cp1 >= base; cp1--)
9952       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9953         { cp1++; break; }
9954     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9955     PerlMem_free(unixified);
9956     PerlMem_free(unixwild);
9957     return 1;
9958   }
9959   else {
9960     char *tpl, *lcres;
9961     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9962     int ells = 1, totells, segdirs, match;
9963     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9964                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9965
9966     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9967     totells = ells;
9968     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9969     tpl = PerlMem_malloc(VMS_MAXRSS);
9970     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9971     if (ellipsis == template && opts & 1) {
9972       /* Template begins with an ellipsis.  Since we can't tell how many
9973        * directory names at the front of the resultant to keep for an
9974        * arbitrary starting point, we arbitrarily choose the current
9975        * default directory as a starting point.  If it's there as a prefix,
9976        * clip it off.  If not, fall through and act as if the leading
9977        * ellipsis weren't there (i.e. return shortest possible path that
9978        * could match template).
9979        */
9980       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9981           PerlMem_free(tpl);
9982           PerlMem_free(unixified);
9983           PerlMem_free(unixwild);
9984           return 0;
9985       }
9986       if (!decc_efs_case_preserve) {
9987         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9988           if (_tolower(*cp1) != _tolower(*cp2)) break;
9989       }
9990       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9991       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9992       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9993         memmove(fspec,cp2+1,end - cp2);
9994         PerlMem_free(tpl);
9995         PerlMem_free(unixified);
9996         PerlMem_free(unixwild);
9997         return 1;
9998       }
9999     }
10000     /* First off, back up over constant elements at end of path */
10001     if (dirs) {
10002       for (front = end ; front >= base; front--)
10003          if (*front == '/' && !dirs--) { front++; break; }
10004     }
10005     lcres = PerlMem_malloc(VMS_MAXRSS);
10006     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10007     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
10008          cp1++,cp2++) {
10009             if (!decc_efs_case_preserve) {
10010                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
10011             }
10012             else {
10013                 *cp2 = *cp1;
10014             }
10015     }
10016     if (cp1 != '\0') {
10017         PerlMem_free(tpl);
10018         PerlMem_free(unixified);
10019         PerlMem_free(unixwild);
10020         PerlMem_free(lcres);
10021         return 0;  /* Path too long. */
10022     }
10023     lcend = cp2;
10024     *cp2 = '\0';  /* Pick up with memcpy later */
10025     lcfront = lcres + (front - base);
10026     /* Now skip over each ellipsis and try to match the path in front of it. */
10027     while (ells--) {
10028       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
10029         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
10030             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
10031       if (cp1 < template) break; /* template started with an ellipsis */
10032       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
10033         ellipsis = cp1; continue;
10034       }
10035       wilddsc.dsc$a_pointer = tpl;
10036       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
10037       nextell = cp1;
10038       for (segdirs = 0, cp2 = tpl;
10039            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
10040            cp1++, cp2++) {
10041          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
10042          else {
10043             if (!decc_efs_case_preserve) {
10044               *cp2 = _tolower(*cp1);  /* else lowercase for match */
10045             }
10046             else {
10047               *cp2 = *cp1;  /* else preserve case for match */
10048             }
10049          }
10050          if (*cp2 == '/') segdirs++;
10051       }
10052       if (cp1 != ellipsis - 1) {
10053           PerlMem_free(tpl);
10054           PerlMem_free(unixified);
10055           PerlMem_free(unixwild);
10056           PerlMem_free(lcres);
10057           return 0; /* Path too long */
10058       }
10059       /* Back up at least as many dirs as in template before matching */
10060       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10061         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10062       for (match = 0; cp1 > lcres;) {
10063         resdsc.dsc$a_pointer = cp1;
10064         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10065           match++;
10066           if (match == 1) lcfront = cp1;
10067         }
10068         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10069       }
10070       if (!match) {
10071         PerlMem_free(tpl);
10072         PerlMem_free(unixified);
10073         PerlMem_free(unixwild);
10074         PerlMem_free(lcres);
10075         return 0;  /* Can't find prefix ??? */
10076       }
10077       if (match > 1 && opts & 1) {
10078         /* This ... wildcard could cover more than one set of dirs (i.e.
10079          * a set of similar dir names is repeated).  If the template
10080          * contains more than 1 ..., upstream elements could resolve the
10081          * ambiguity, but it's not worth a full backtracking setup here.
10082          * As a quick heuristic, clip off the current default directory
10083          * if it's present to find the trimmed spec, else use the
10084          * shortest string that this ... could cover.
10085          */
10086         char def[NAM$C_MAXRSS+1], *st;
10087
10088         if (getcwd(def, sizeof def,0) == NULL) {
10089             PerlMem_free(unixified);
10090             PerlMem_free(unixwild);
10091             PerlMem_free(lcres);
10092             PerlMem_free(tpl);
10093             return 0;
10094         }
10095         if (!decc_efs_case_preserve) {
10096           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10097             if (_tolower(*cp1) != _tolower(*cp2)) break;
10098         }
10099         segdirs = dirs - totells;  /* Min # of dirs we must have left */
10100         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10101         if (*cp1 == '\0' && *cp2 == '/') {
10102           memmove(fspec,cp2+1,end - cp2);
10103           PerlMem_free(tpl);
10104           PerlMem_free(unixified);
10105           PerlMem_free(unixwild);
10106           PerlMem_free(lcres);
10107           return 1;
10108         }
10109         /* Nope -- stick with lcfront from above and keep going. */
10110       }
10111     }
10112     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10113     PerlMem_free(tpl);
10114     PerlMem_free(unixified);
10115     PerlMem_free(unixwild);
10116     PerlMem_free(lcres);
10117     return 1;
10118   }
10119
10120 }  /* end of trim_unixpath() */
10121 /*}}}*/
10122
10123
10124 /*
10125  *  VMS readdir() routines.
10126  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10127  *
10128  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10129  *  Minor modifications to original routines.
10130  */
10131
10132 /* readdir may have been redefined by reentr.h, so make sure we get
10133  * the local version for what we do here.
10134  */
10135 #ifdef readdir
10136 # undef readdir
10137 #endif
10138 #if !defined(PERL_IMPLICIT_CONTEXT)
10139 # define readdir Perl_readdir
10140 #else
10141 # define readdir(a) Perl_readdir(aTHX_ a)
10142 #endif
10143
10144     /* Number of elements in vms_versions array */
10145 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10146
10147 /*
10148  *  Open a directory, return a handle for later use.
10149  */
10150 /*{{{ DIR *opendir(char*name) */
10151 DIR *
10152 Perl_opendir(pTHX_ const char *name)
10153 {
10154     DIR *dd;
10155     char *dir;
10156     Stat_t sb;
10157
10158     Newx(dir, VMS_MAXRSS, char);
10159     if (int_tovmspath(name, dir, NULL) == NULL) {
10160       Safefree(dir);
10161       return NULL;
10162     }
10163     /* Check access before stat; otherwise stat does not
10164      * accurately report whether it's a directory.
10165      */
10166     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10167       /* cando_by_name has already set errno */
10168       Safefree(dir);
10169       return NULL;
10170     }
10171     if (flex_stat(dir,&sb) == -1) return NULL;
10172     if (!S_ISDIR(sb.st_mode)) {
10173       Safefree(dir);
10174       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10175       return NULL;
10176     }
10177     /* Get memory for the handle, and the pattern. */
10178     Newx(dd,1,DIR);
10179     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10180
10181     /* Fill in the fields; mainly playing with the descriptor. */
10182     sprintf(dd->pattern, "%s*.*",dir);
10183     Safefree(dir);
10184     dd->context = 0;
10185     dd->count = 0;
10186     dd->flags = 0;
10187     /* By saying we always want the result of readdir() in unix format, we
10188      * are really saying we want all the escapes removed.  Otherwise the caller,
10189      * having no way to know whether it's already in VMS format, might send it
10190      * through tovmsspec again, thus double escaping.
10191      */
10192     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10193     dd->pat.dsc$a_pointer = dd->pattern;
10194     dd->pat.dsc$w_length = strlen(dd->pattern);
10195     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10196     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10197 #if defined(USE_ITHREADS)
10198     Newx(dd->mutex,1,perl_mutex);
10199     MUTEX_INIT( (perl_mutex *) dd->mutex );
10200 #else
10201     dd->mutex = NULL;
10202 #endif
10203
10204     return dd;
10205 }  /* end of opendir() */
10206 /*}}}*/
10207
10208 /*
10209  *  Set the flag to indicate we want versions or not.
10210  */
10211 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10212 void
10213 vmsreaddirversions(DIR *dd, int flag)
10214 {
10215     if (flag)
10216         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10217     else
10218         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10219 }
10220 /*}}}*/
10221
10222 /*
10223  *  Free up an opened directory.
10224  */
10225 /*{{{ void closedir(DIR *dd)*/
10226 void
10227 Perl_closedir(DIR *dd)
10228 {
10229     int sts;
10230
10231     sts = lib$find_file_end(&dd->context);
10232     Safefree(dd->pattern);
10233 #if defined(USE_ITHREADS)
10234     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10235     Safefree(dd->mutex);
10236 #endif
10237     Safefree(dd);
10238 }
10239 /*}}}*/
10240
10241 /*
10242  *  Collect all the version numbers for the current file.
10243  */
10244 static void
10245 collectversions(pTHX_ DIR *dd)
10246 {
10247     struct dsc$descriptor_s     pat;
10248     struct dsc$descriptor_s     res;
10249     struct dirent *e;
10250     char *p, *text, *buff;
10251     int i;
10252     unsigned long context, tmpsts;
10253
10254     /* Convenient shorthand. */
10255     e = &dd->entry;
10256
10257     /* Add the version wildcard, ignoring the "*.*" put on before */
10258     i = strlen(dd->pattern);
10259     Newx(text,i + e->d_namlen + 3,char);
10260     strcpy(text, dd->pattern);
10261     sprintf(&text[i - 3], "%s;*", e->d_name);
10262
10263     /* Set up the pattern descriptor. */
10264     pat.dsc$a_pointer = text;
10265     pat.dsc$w_length = i + e->d_namlen - 1;
10266     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10267     pat.dsc$b_class = DSC$K_CLASS_S;
10268
10269     /* Set up result descriptor. */
10270     Newx(buff, VMS_MAXRSS, char);
10271     res.dsc$a_pointer = buff;
10272     res.dsc$w_length = VMS_MAXRSS - 1;
10273     res.dsc$b_dtype = DSC$K_DTYPE_T;
10274     res.dsc$b_class = DSC$K_CLASS_S;
10275
10276     /* Read files, collecting versions. */
10277     for (context = 0, e->vms_verscount = 0;
10278          e->vms_verscount < VERSIZE(e);
10279          e->vms_verscount++) {
10280         unsigned long rsts;
10281         unsigned long flags = 0;
10282
10283 #ifdef VMS_LONGNAME_SUPPORT
10284         flags = LIB$M_FIL_LONG_NAMES;
10285 #endif
10286         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10287         if (tmpsts == RMS$_NMF || context == 0) break;
10288         _ckvmssts(tmpsts);
10289         buff[VMS_MAXRSS - 1] = '\0';
10290         if ((p = strchr(buff, ';')))
10291             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10292         else
10293             e->vms_versions[e->vms_verscount] = -1;
10294     }
10295
10296     _ckvmssts(lib$find_file_end(&context));
10297     Safefree(text);
10298     Safefree(buff);
10299
10300 }  /* end of collectversions() */
10301
10302 /*
10303  *  Read the next entry from the directory.
10304  */
10305 /*{{{ struct dirent *readdir(DIR *dd)*/
10306 struct dirent *
10307 Perl_readdir(pTHX_ DIR *dd)
10308 {
10309     struct dsc$descriptor_s     res;
10310     char *p, *buff;
10311     unsigned long int tmpsts;
10312     unsigned long rsts;
10313     unsigned long flags = 0;
10314     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10315     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10316
10317     /* Set up result descriptor, and get next file. */
10318     Newx(buff, VMS_MAXRSS, char);
10319     res.dsc$a_pointer = buff;
10320     res.dsc$w_length = VMS_MAXRSS - 1;
10321     res.dsc$b_dtype = DSC$K_DTYPE_T;
10322     res.dsc$b_class = DSC$K_CLASS_S;
10323
10324 #ifdef VMS_LONGNAME_SUPPORT
10325     flags = LIB$M_FIL_LONG_NAMES;
10326 #endif
10327
10328     tmpsts = lib$find_file
10329         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10330     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10331     if (!(tmpsts & 1)) {
10332       set_vaxc_errno(tmpsts);
10333       switch (tmpsts) {
10334         case RMS$_PRV:
10335           set_errno(EACCES); break;
10336         case RMS$_DEV:
10337           set_errno(ENODEV); break;
10338         case RMS$_DIR:
10339           set_errno(ENOTDIR); break;
10340         case RMS$_FNF: case RMS$_DNF:
10341           set_errno(ENOENT); break;
10342         default:
10343           set_errno(EVMSERR);
10344       }
10345       Safefree(buff);
10346       return NULL;
10347     }
10348     dd->count++;
10349     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10350     buff[res.dsc$w_length] = '\0';
10351     p = buff + res.dsc$w_length;
10352     while (--p >= buff) if (!isspace(*p)) break;
10353     *p = '\0';
10354     if (!decc_efs_case_preserve) {
10355       for (p = buff; *p; p++) *p = _tolower(*p);
10356     }
10357
10358     /* Skip any directory component and just copy the name. */
10359     sts = vms_split_path
10360        (buff,
10361         &v_spec,
10362         &v_len,
10363         &r_spec,
10364         &r_len,
10365         &d_spec,
10366         &d_len,
10367         &n_spec,
10368         &n_len,
10369         &e_spec,
10370         &e_len,
10371         &vs_spec,
10372         &vs_len);
10373
10374     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10375
10376         /* In Unix report mode, remove the ".dir;1" from the name */
10377         /* if it is a real directory. */
10378         if (decc_filename_unix_report || decc_efs_charset) {
10379             if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10380                 Stat_t statbuf;
10381                 int ret_sts;
10382
10383                 ret_sts = flex_lstat(buff, &statbuf);
10384                 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10385                     e_len = 0;
10386                     e_spec[0] = 0;
10387                 }
10388             }
10389         }
10390
10391         /* Drop NULL extensions on UNIX file specification */
10392         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10393             e_len = 0;
10394             e_spec[0] = '\0';
10395         }
10396     }
10397
10398     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10399     dd->entry.d_name[n_len + e_len] = '\0';
10400     dd->entry.d_namlen = strlen(dd->entry.d_name);
10401
10402     /* Convert the filename to UNIX format if needed */
10403     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10404
10405         /* Translate the encoded characters. */
10406         /* Fixme: Unicode handling could result in embedded 0 characters */
10407         if (strchr(dd->entry.d_name, '^') != NULL) {
10408             char new_name[256];
10409             char * q;
10410             p = dd->entry.d_name;
10411             q = new_name;
10412             while (*p != 0) {
10413                 int inchars_read, outchars_added;
10414                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10415                 p += inchars_read;
10416                 q += outchars_added;
10417                 /* fix-me */
10418                 /* if outchars_added > 1, then this is a wide file specification */
10419                 /* Wide file specifications need to be passed in Perl */
10420                 /* counted strings apparently with a Unicode flag */
10421             }
10422             *q = 0;
10423             strcpy(dd->entry.d_name, new_name);
10424             dd->entry.d_namlen = strlen(dd->entry.d_name);
10425         }
10426     }
10427
10428     dd->entry.vms_verscount = 0;
10429     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10430     Safefree(buff);
10431     return &dd->entry;
10432
10433 }  /* end of readdir() */
10434 /*}}}*/
10435
10436 /*
10437  *  Read the next entry from the directory -- thread-safe version.
10438  */
10439 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10440 int
10441 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10442 {
10443     int retval;
10444
10445     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10446
10447     entry = readdir(dd);
10448     *result = entry;
10449     retval = ( *result == NULL ? errno : 0 );
10450
10451     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10452
10453     return retval;
10454
10455 }  /* end of readdir_r() */
10456 /*}}}*/
10457
10458 /*
10459  *  Return something that can be used in a seekdir later.
10460  */
10461 /*{{{ long telldir(DIR *dd)*/
10462 long
10463 Perl_telldir(DIR *dd)
10464 {
10465     return dd->count;
10466 }
10467 /*}}}*/
10468
10469 /*
10470  *  Return to a spot where we used to be.  Brute force.
10471  */
10472 /*{{{ void seekdir(DIR *dd,long count)*/
10473 void
10474 Perl_seekdir(pTHX_ DIR *dd, long count)
10475 {
10476     int old_flags;
10477
10478     /* If we haven't done anything yet... */
10479     if (dd->count == 0)
10480         return;
10481
10482     /* Remember some state, and clear it. */
10483     old_flags = dd->flags;
10484     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10485     _ckvmssts(lib$find_file_end(&dd->context));
10486     dd->context = 0;
10487
10488     /* The increment is in readdir(). */
10489     for (dd->count = 0; dd->count < count; )
10490         readdir(dd);
10491
10492     dd->flags = old_flags;
10493
10494 }  /* end of seekdir() */
10495 /*}}}*/
10496
10497 /* VMS subprocess management
10498  *
10499  * my_vfork() - just a vfork(), after setting a flag to record that
10500  * the current script is trying a Unix-style fork/exec.
10501  *
10502  * vms_do_aexec() and vms_do_exec() are called in response to the
10503  * perl 'exec' function.  If this follows a vfork call, then they
10504  * call out the regular perl routines in doio.c which do an
10505  * execvp (for those who really want to try this under VMS).
10506  * Otherwise, they do exactly what the perl docs say exec should
10507  * do - terminate the current script and invoke a new command
10508  * (See below for notes on command syntax.)
10509  *
10510  * do_aspawn() and do_spawn() implement the VMS side of the perl
10511  * 'system' function.
10512  *
10513  * Note on command arguments to perl 'exec' and 'system': When handled
10514  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10515  * are concatenated to form a DCL command string.  If the first non-numeric
10516  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10517  * the command string is handed off to DCL directly.  Otherwise,
10518  * the first token of the command is taken as the filespec of an image
10519  * to run.  The filespec is expanded using a default type of '.EXE' and
10520  * the process defaults for device, directory, etc., and if found, the resultant
10521  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10522  * the command string as parameters.  This is perhaps a bit complicated,
10523  * but I hope it will form a happy medium between what VMS folks expect
10524  * from lib$spawn and what Unix folks expect from exec.
10525  */
10526
10527 static int vfork_called;
10528
10529 /*{{{int my_vfork()*/
10530 int
10531 my_vfork()
10532 {
10533   vfork_called++;
10534   return vfork();
10535 }
10536 /*}}}*/
10537
10538
10539 static void
10540 vms_execfree(struct dsc$descriptor_s *vmscmd)
10541 {
10542   if (vmscmd) {
10543       if (vmscmd->dsc$a_pointer) {
10544           PerlMem_free(vmscmd->dsc$a_pointer);
10545       }
10546       PerlMem_free(vmscmd);
10547   }
10548 }
10549
10550 static char *
10551 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10552 {
10553   char *junk, *tmps = NULL;
10554   register size_t cmdlen = 0;
10555   size_t rlen;
10556   register SV **idx;
10557   STRLEN n_a;
10558
10559   idx = mark;
10560   if (really) {
10561     tmps = SvPV(really,rlen);
10562     if (*tmps) {
10563       cmdlen += rlen + 1;
10564       idx++;
10565     }
10566   }
10567
10568   for (idx++; idx <= sp; idx++) {
10569     if (*idx) {
10570       junk = SvPVx(*idx,rlen);
10571       cmdlen += rlen ? rlen + 1 : 0;
10572     }
10573   }
10574   Newx(PL_Cmd, cmdlen+1, char);
10575
10576   if (tmps && *tmps) {
10577     strcpy(PL_Cmd,tmps);
10578     mark++;
10579   }
10580   else *PL_Cmd = '\0';
10581   while (++mark <= sp) {
10582     if (*mark) {
10583       char *s = SvPVx(*mark,n_a);
10584       if (!*s) continue;
10585       if (*PL_Cmd) strcat(PL_Cmd," ");
10586       strcat(PL_Cmd,s);
10587     }
10588   }
10589   return PL_Cmd;
10590
10591 }  /* end of setup_argstr() */
10592
10593
10594 static unsigned long int
10595 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10596                    struct dsc$descriptor_s **pvmscmd)
10597 {
10598   char * vmsspec;
10599   char * resspec;
10600   char image_name[NAM$C_MAXRSS+1];
10601   char image_argv[NAM$C_MAXRSS+1];
10602   $DESCRIPTOR(defdsc,".EXE");
10603   $DESCRIPTOR(defdsc2,".");
10604   struct dsc$descriptor_s resdsc;
10605   struct dsc$descriptor_s *vmscmd;
10606   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10607   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10608   register char *s, *rest, *cp, *wordbreak;
10609   char * cmd;
10610   int cmdlen;
10611   register int isdcl;
10612
10613   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10614   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10615
10616   /* vmsspec is a DCL command buffer, not just a filename */
10617   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10618   if (vmsspec == NULL)
10619       _ckvmssts_noperl(SS$_INSFMEM);
10620
10621   resspec = PerlMem_malloc(VMS_MAXRSS);
10622   if (resspec == NULL)
10623       _ckvmssts_noperl(SS$_INSFMEM);
10624
10625   /* Make a copy for modification */
10626   cmdlen = strlen(incmd);
10627   cmd = PerlMem_malloc(cmdlen+1);
10628   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10629   strncpy(cmd, incmd, cmdlen);
10630   cmd[cmdlen] = 0;
10631   image_name[0] = 0;
10632   image_argv[0] = 0;
10633
10634   resdsc.dsc$a_pointer = resspec;
10635   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10636   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10637   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10638
10639   vmscmd->dsc$a_pointer = NULL;
10640   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10641   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10642   vmscmd->dsc$w_length = 0;
10643   if (pvmscmd) *pvmscmd = vmscmd;
10644
10645   if (suggest_quote) *suggest_quote = 0;
10646
10647   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10648     PerlMem_free(cmd);
10649     PerlMem_free(vmsspec);
10650     PerlMem_free(resspec);
10651     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10652   }
10653
10654   s = cmd;
10655
10656   while (*s && isspace(*s)) s++;
10657
10658   if (*s == '@' || *s == '$') {
10659     vmsspec[0] = *s;  rest = s + 1;
10660     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10661   }
10662   else { cp = vmsspec; rest = s; }
10663   if (*rest == '.' || *rest == '/') {
10664     char *cp2;
10665     for (cp2 = resspec;
10666          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10667          rest++, cp2++) *cp2 = *rest;
10668     *cp2 = '\0';
10669     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10670       s = vmsspec;
10671
10672       /* When a UNIX spec with no file type is translated to VMS, */
10673       /* A trailing '.' is appended under ODS-5 rules.            */
10674       /* Here we do not want that trailing "." as it prevents     */
10675       /* Looking for a implied ".exe" type. */
10676       if (decc_efs_charset) {
10677           int i;
10678           i = strlen(vmsspec);
10679           if (vmsspec[i-1] == '.') {
10680               vmsspec[i-1] = '\0';
10681           }
10682       }
10683
10684       if (*rest) {
10685         for (cp2 = vmsspec + strlen(vmsspec);
10686              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10687              rest++, cp2++) *cp2 = *rest;
10688         *cp2 = '\0';
10689       }
10690     }
10691   }
10692   /* Intuit whether verb (first word of cmd) is a DCL command:
10693    *   - if first nonspace char is '@', it's a DCL indirection
10694    * otherwise
10695    *   - if verb contains a filespec separator, it's not a DCL command
10696    *   - if it doesn't, caller tells us whether to default to a DCL
10697    *     command, or to a local image unless told it's DCL (by leading '$')
10698    */
10699   if (*s == '@') {
10700       isdcl = 1;
10701       if (suggest_quote) *suggest_quote = 1;
10702   } else {
10703     register char *filespec = strpbrk(s,":<[.;");
10704     rest = wordbreak = strpbrk(s," \"\t/");
10705     if (!wordbreak) wordbreak = s + strlen(s);
10706     if (*s == '$') check_img = 0;
10707     if (filespec && (filespec < wordbreak)) isdcl = 0;
10708     else isdcl = !check_img;
10709   }
10710
10711   if (!isdcl) {
10712     int rsts;
10713     imgdsc.dsc$a_pointer = s;
10714     imgdsc.dsc$w_length = wordbreak - s;
10715     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10716     if (!(retsts&1)) {
10717         _ckvmssts_noperl(lib$find_file_end(&cxt));
10718         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10719       if (!(retsts & 1) && *s == '$') {
10720         _ckvmssts_noperl(lib$find_file_end(&cxt));
10721         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10722         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10723         if (!(retsts&1)) {
10724           _ckvmssts_noperl(lib$find_file_end(&cxt));
10725           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10726         }
10727       }
10728     }
10729     _ckvmssts_noperl(lib$find_file_end(&cxt));
10730
10731     if (retsts & 1) {
10732       FILE *fp;
10733       s = resspec;
10734       while (*s && !isspace(*s)) s++;
10735       *s = '\0';
10736
10737       /* check that it's really not DCL with no file extension */
10738       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10739       if (fp) {
10740         char b[256] = {0,0,0,0};
10741         read(fileno(fp), b, 256);
10742         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10743         if (isdcl) {
10744           int shebang_len;
10745
10746           /* Check for script */
10747           shebang_len = 0;
10748           if ((b[0] == '#') && (b[1] == '!'))
10749              shebang_len = 2;
10750 #ifdef ALTERNATE_SHEBANG
10751           else {
10752             shebang_len = strlen(ALTERNATE_SHEBANG);
10753             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10754               char * perlstr;
10755                 perlstr = strstr("perl",b);
10756                 if (perlstr == NULL)
10757                   shebang_len = 0;
10758             }
10759             else
10760               shebang_len = 0;
10761           }
10762 #endif
10763
10764           if (shebang_len > 0) {
10765           int i;
10766           int j;
10767           char tmpspec[NAM$C_MAXRSS + 1];
10768
10769             i = shebang_len;
10770              /* Image is following after white space */
10771             /*--------------------------------------*/
10772             while (isprint(b[i]) && isspace(b[i]))
10773                 i++;
10774
10775             j = 0;
10776             while (isprint(b[i]) && !isspace(b[i])) {
10777                 tmpspec[j++] = b[i++];
10778                 if (j >= NAM$C_MAXRSS)
10779                    break;
10780             }
10781             tmpspec[j] = '\0';
10782
10783              /* There may be some default parameters to the image */
10784             /*---------------------------------------------------*/
10785             j = 0;
10786             while (isprint(b[i])) {
10787                 image_argv[j++] = b[i++];
10788                 if (j >= NAM$C_MAXRSS)
10789                    break;
10790             }
10791             while ((j > 0) && !isprint(image_argv[j-1]))
10792                 j--;
10793             image_argv[j] = 0;
10794
10795             /* It will need to be converted to VMS format and validated */
10796             if (tmpspec[0] != '\0') {
10797               char * iname;
10798
10799                /* Try to find the exact program requested to be run */
10800               /*---------------------------------------------------*/
10801               iname = int_rmsexpand
10802                  (tmpspec, image_name, ".exe",
10803                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10804               if (iname != NULL) {
10805                 if (cando_by_name_int
10806                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10807                   /* MCR prefix needed */
10808                   isdcl = 0;
10809                 }
10810                 else {
10811                    /* Try again with a null type */
10812                   /*----------------------------*/
10813                   iname = int_rmsexpand
10814                     (tmpspec, image_name, ".",
10815                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10816                   if (iname != NULL) {
10817                     if (cando_by_name_int
10818                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10819                       /* MCR prefix needed */
10820                       isdcl = 0;
10821                     }
10822                   }
10823                 }
10824
10825                  /* Did we find the image to run the script? */
10826                 /*------------------------------------------*/
10827                 if (isdcl) {
10828                   char *tchr;
10829
10830                    /* Assume DCL or foreign command exists */
10831                   /*--------------------------------------*/
10832                   tchr = strrchr(tmpspec, '/');
10833                   if (tchr != NULL) {
10834                     tchr++;
10835                   }
10836                   else {
10837                     tchr = tmpspec;
10838                   }
10839                   strcpy(image_name, tchr);
10840                 }
10841               }
10842             }
10843           }
10844         }
10845         fclose(fp);
10846       }
10847       if (check_img && isdcl) {
10848           PerlMem_free(cmd);
10849           PerlMem_free(resspec);
10850           PerlMem_free(vmsspec);
10851           return RMS$_FNF;
10852       }
10853
10854       if (cando_by_name(S_IXUSR,0,resspec)) {
10855         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10856         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10857         if (!isdcl) {
10858             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10859             if (image_name[0] != 0) {
10860                 strcat(vmscmd->dsc$a_pointer, image_name);
10861                 strcat(vmscmd->dsc$a_pointer, " ");
10862             }
10863         } else if (image_name[0] != 0) {
10864             strcpy(vmscmd->dsc$a_pointer, image_name);
10865             strcat(vmscmd->dsc$a_pointer, " ");
10866         } else {
10867             strcpy(vmscmd->dsc$a_pointer,"@");
10868         }
10869         if (suggest_quote) *suggest_quote = 1;
10870
10871         /* If there is an image name, use original command */
10872         if (image_name[0] == 0)
10873             strcat(vmscmd->dsc$a_pointer,resspec);
10874         else {
10875             rest = cmd;
10876             while (*rest && isspace(*rest)) rest++;
10877         }
10878
10879         if (image_argv[0] != 0) {
10880           strcat(vmscmd->dsc$a_pointer,image_argv);
10881           strcat(vmscmd->dsc$a_pointer, " ");
10882         }
10883         if (rest) {
10884            int rest_len;
10885            int vmscmd_len;
10886
10887            rest_len = strlen(rest);
10888            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10889            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10890               strcat(vmscmd->dsc$a_pointer,rest);
10891            else
10892              retsts = CLI$_BUFOVF;
10893         }
10894         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10895         PerlMem_free(cmd);
10896         PerlMem_free(vmsspec);
10897         PerlMem_free(resspec);
10898         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10899       }
10900       else
10901         retsts = RMS$_PRV;
10902     }
10903   }
10904   /* It's either a DCL command or we couldn't find a suitable image */
10905   vmscmd->dsc$w_length = strlen(cmd);
10906
10907   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10908   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10909   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10910
10911   PerlMem_free(cmd);
10912   PerlMem_free(resspec);
10913   PerlMem_free(vmsspec);
10914
10915   /* check if it's a symbol (for quoting purposes) */
10916   if (suggest_quote && !*suggest_quote) {
10917     int iss;
10918     char equiv[LNM$C_NAMLENGTH];
10919     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10920     eqvdsc.dsc$a_pointer = equiv;
10921
10922     iss = lib$get_symbol(vmscmd,&eqvdsc);
10923     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10924   }
10925   if (!(retsts & 1)) {
10926     /* just hand off status values likely to be due to user error */
10927     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10928         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10929        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10930     else { _ckvmssts_noperl(retsts); }
10931   }
10932
10933   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10934
10935 }  /* end of setup_cmddsc() */
10936
10937
10938 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10939 bool
10940 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10941 {
10942 bool exec_sts;
10943 char * cmd;
10944
10945   if (sp > mark) {
10946     if (vfork_called) {           /* this follows a vfork - act Unixish */
10947       vfork_called--;
10948       if (vfork_called < 0) {
10949         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10950         vfork_called = 0;
10951       }
10952       else return do_aexec(really,mark,sp);
10953     }
10954                                            /* no vfork - act VMSish */
10955     cmd = setup_argstr(aTHX_ really,mark,sp);
10956     exec_sts = vms_do_exec(cmd);
10957     Safefree(cmd);  /* Clean up from setup_argstr() */
10958     return exec_sts;
10959   }
10960
10961   return FALSE;
10962 }  /* end of vms_do_aexec() */
10963 /*}}}*/
10964
10965 /* {{{bool vms_do_exec(char *cmd) */
10966 bool
10967 Perl_vms_do_exec(pTHX_ const char *cmd)
10968 {
10969   struct dsc$descriptor_s *vmscmd;
10970
10971   if (vfork_called) {             /* this follows a vfork - act Unixish */
10972     vfork_called--;
10973     if (vfork_called < 0) {
10974       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10975       vfork_called = 0;
10976     }
10977     else return do_exec(cmd);
10978   }
10979
10980   {                               /* no vfork - act VMSish */
10981     unsigned long int retsts;
10982
10983     TAINT_ENV();
10984     TAINT_PROPER("exec");
10985     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10986       retsts = lib$do_command(vmscmd);
10987
10988     switch (retsts) {
10989       case RMS$_FNF: case RMS$_DNF:
10990         set_errno(ENOENT); break;
10991       case RMS$_DIR:
10992         set_errno(ENOTDIR); break;
10993       case RMS$_DEV:
10994         set_errno(ENODEV); break;
10995       case RMS$_PRV:
10996         set_errno(EACCES); break;
10997       case RMS$_SYN:
10998         set_errno(EINVAL); break;
10999       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11000         set_errno(E2BIG); break;
11001       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11002         _ckvmssts_noperl(retsts); /* fall through */
11003       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11004         set_errno(EVMSERR);
11005     }
11006     set_vaxc_errno(retsts);
11007     if (ckWARN(WARN_EXEC)) {
11008       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
11009              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
11010     }
11011     vms_execfree(vmscmd);
11012   }
11013
11014   return FALSE;
11015
11016 }  /* end of vms_do_exec() */
11017 /*}}}*/
11018
11019 int do_spawn2(pTHX_ const char *, int);
11020
11021 int
11022 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11023 {
11024 unsigned long int sts;
11025 char * cmd;
11026 int flags = 0;
11027
11028   if (sp > mark) {
11029
11030     /* We'll copy the (undocumented?) Win32 behavior and allow a
11031      * numeric first argument.  But the only value we'll support
11032      * through do_aspawn is a value of 1, which means spawn without
11033      * waiting for completion -- other values are ignored.
11034      */
11035     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11036         ++mark;
11037         flags = SvIVx(*mark);
11038     }
11039
11040     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
11041         flags = CLI$M_NOWAIT;
11042     else
11043         flags = 0;
11044
11045     cmd = setup_argstr(aTHX_ really, mark, sp);
11046     sts = do_spawn2(aTHX_ cmd, flags);
11047     /* pp_sys will clean up cmd */
11048     return sts;
11049   }
11050   return SS$_ABORT;
11051 }  /* end of do_aspawn() */
11052 /*}}}*/
11053
11054
11055 /* {{{int do_spawn(char* cmd) */
11056 int
11057 Perl_do_spawn(pTHX_ char* cmd)
11058 {
11059     PERL_ARGS_ASSERT_DO_SPAWN;
11060
11061     return do_spawn2(aTHX_ cmd, 0);
11062 }
11063 /*}}}*/
11064
11065 /* {{{int do_spawn_nowait(char* cmd) */
11066 int
11067 Perl_do_spawn_nowait(pTHX_ char* cmd)
11068 {
11069     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11070
11071     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11072 }
11073 /*}}}*/
11074
11075 /* {{{int do_spawn2(char *cmd) */
11076 int
11077 do_spawn2(pTHX_ const char *cmd, int flags)
11078 {
11079   unsigned long int sts, substs;
11080
11081   /* The caller of this routine expects to Safefree(PL_Cmd) */
11082   Newx(PL_Cmd,10,char);
11083
11084   TAINT_ENV();
11085   TAINT_PROPER("spawn");
11086   if (!cmd || !*cmd) {
11087     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11088     if (!(sts & 1)) {
11089       switch (sts) {
11090         case RMS$_FNF:  case RMS$_DNF:
11091           set_errno(ENOENT); break;
11092         case RMS$_DIR:
11093           set_errno(ENOTDIR); break;
11094         case RMS$_DEV:
11095           set_errno(ENODEV); break;
11096         case RMS$_PRV:
11097           set_errno(EACCES); break;
11098         case RMS$_SYN:
11099           set_errno(EINVAL); break;
11100         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11101           set_errno(E2BIG); break;
11102         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11103           _ckvmssts_noperl(sts); /* fall through */
11104         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11105           set_errno(EVMSERR);
11106       }
11107       set_vaxc_errno(sts);
11108       if (ckWARN(WARN_EXEC)) {
11109         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11110                     Strerror(errno));
11111       }
11112     }
11113     sts = substs;
11114   }
11115   else {
11116     char mode[3];
11117     PerlIO * fp;
11118     if (flags & CLI$M_NOWAIT)
11119         strcpy(mode, "n");
11120     else
11121         strcpy(mode, "nW");
11122
11123     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11124     if (fp != NULL)
11125       my_pclose(fp);
11126     /* sts will be the pid in the nowait case */
11127   }
11128   return sts;
11129 }  /* end of do_spawn2() */
11130 /*}}}*/
11131
11132
11133 static unsigned int *sockflags, sockflagsize;
11134
11135 /*
11136  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11137  * routines found in some versions of the CRTL can't deal with sockets.
11138  * We don't shim the other file open routines since a socket isn't
11139  * likely to be opened by a name.
11140  */
11141 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11142 FILE *my_fdopen(int fd, const char *mode)
11143 {
11144   FILE *fp = fdopen(fd, mode);
11145
11146   if (fp) {
11147     unsigned int fdoff = fd / sizeof(unsigned int);
11148     Stat_t sbuf; /* native stat; we don't need flex_stat */
11149     if (!sockflagsize || fdoff > sockflagsize) {
11150       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11151       else           Newx  (sockflags,fdoff+2,unsigned int);
11152       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11153       sockflagsize = fdoff + 2;
11154     }
11155     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11156       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11157   }
11158   return fp;
11159
11160 }
11161 /*}}}*/
11162
11163
11164 /*
11165  * Clear the corresponding bit when the (possibly) socket stream is closed.
11166  * There still a small hole: we miss an implicit close which might occur
11167  * via freopen().  >> Todo
11168  */
11169 /*{{{ int my_fclose(FILE *fp)*/
11170 int my_fclose(FILE *fp) {
11171   if (fp) {
11172     unsigned int fd = fileno(fp);
11173     unsigned int fdoff = fd / sizeof(unsigned int);
11174
11175     if (sockflagsize && fdoff < sockflagsize)
11176       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11177   }
11178   return fclose(fp);
11179 }
11180 /*}}}*/
11181
11182
11183 /*
11184  * A simple fwrite replacement which outputs itmsz*nitm chars without
11185  * introducing record boundaries every itmsz chars.
11186  * We are using fputs, which depends on a terminating null.  We may
11187  * well be writing binary data, so we need to accommodate not only
11188  * data with nulls sprinkled in the middle but also data with no null
11189  * byte at the end.
11190  */
11191 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11192 int
11193 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11194 {
11195   register char *cp, *end, *cpd;
11196   char *data;
11197   register unsigned int fd = fileno(dest);
11198   register unsigned int fdoff = fd / sizeof(unsigned int);
11199   int retval;
11200   int bufsize = itmsz * nitm + 1;
11201
11202   if (fdoff < sockflagsize &&
11203       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11204     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11205     return nitm;
11206   }
11207
11208   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11209   memcpy( data, src, itmsz*nitm );
11210   data[itmsz*nitm] = '\0';
11211
11212   end = data + itmsz * nitm;
11213   retval = (int) nitm; /* on success return # items written */
11214
11215   cpd = data;
11216   while (cpd <= end) {
11217     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11218     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11219     if (cp < end)
11220       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11221     cpd = cp + 1;
11222   }
11223
11224   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11225   return retval;
11226
11227 }  /* end of my_fwrite() */
11228 /*}}}*/
11229
11230 /*{{{ int my_flush(FILE *fp)*/
11231 int
11232 Perl_my_flush(pTHX_ FILE *fp)
11233 {
11234     int res;
11235     if ((res = fflush(fp)) == 0 && fp) {
11236 #ifdef VMS_DO_SOCKETS
11237         Stat_t s;
11238         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11239 #endif
11240             res = fsync(fileno(fp));
11241     }
11242 /*
11243  * If the flush succeeded but set end-of-file, we need to clear
11244  * the error because our caller may check ferror().  BTW, this
11245  * probably means we just flushed an empty file.
11246  */
11247     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11248
11249     return res;
11250 }
11251 /*}}}*/
11252
11253 /* fgetname() is not returning the correct file specifications when
11254  * decc_filename_unix_report mode is active.  So we have to have it
11255  * aways return filenames in VMS mode and convert it ourselves.
11256  */
11257
11258 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11259 char *
11260 Perl_my_fgetname(FILE *fp, char * buf) {
11261     char * retname;
11262     char * vms_name;
11263
11264     retname = fgetname(fp, buf, 1);
11265
11266     /* If we are in VMS mode, then we are done */
11267     if (!decc_filename_unix_report || (retname == NULL)) {
11268        return retname;
11269     }
11270
11271     /* Convert this to Unix format */
11272     vms_name = PerlMem_malloc(VMS_MAXRSS + 1);
11273     strcpy(vms_name, retname);
11274     retname = int_tounixspec(vms_name, buf, NULL);
11275     PerlMem_free(vms_name);
11276
11277     return retname;
11278 }
11279 /*}}}*/
11280
11281 /*
11282  * Here are replacements for the following Unix routines in the VMS environment:
11283  *      getpwuid    Get information for a particular UIC or UID
11284  *      getpwnam    Get information for a named user
11285  *      getpwent    Get information for each user in the rights database
11286  *      setpwent    Reset search to the start of the rights database
11287  *      endpwent    Finish searching for users in the rights database
11288  *
11289  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11290  * (defined in pwd.h), which contains the following fields:-
11291  *      struct passwd {
11292  *              char        *pw_name;    Username (in lower case)
11293  *              char        *pw_passwd;  Hashed password
11294  *              unsigned int pw_uid;     UIC
11295  *              unsigned int pw_gid;     UIC group  number
11296  *              char        *pw_unixdir; Default device/directory (VMS-style)
11297  *              char        *pw_gecos;   Owner name
11298  *              char        *pw_dir;     Default device/directory (Unix-style)
11299  *              char        *pw_shell;   Default CLI name (eg. DCL)
11300  *      };
11301  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11302  *
11303  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11304  * not the UIC member number (eg. what's returned by getuid()),
11305  * getpwuid() can accept either as input (if uid is specified, the caller's
11306  * UIC group is used), though it won't recognise gid=0.
11307  *
11308  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11309  * information about other users in your group or in other groups, respectively.
11310  * If the required privilege is not available, then these routines fill only
11311  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11312  * string).
11313  *
11314  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11315  */
11316
11317 /* sizes of various UAF record fields */
11318 #define UAI$S_USERNAME 12
11319 #define UAI$S_IDENT    31
11320 #define UAI$S_OWNER    31
11321 #define UAI$S_DEFDEV   31
11322 #define UAI$S_DEFDIR   63
11323 #define UAI$S_DEFCLI   31
11324 #define UAI$S_PWD       8
11325
11326 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11327                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11328                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11329
11330 static char __empty[]= "";
11331 static struct passwd __passwd_empty=
11332     {(char *) __empty, (char *) __empty, 0, 0,
11333      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11334 static int contxt= 0;
11335 static struct passwd __pwdcache;
11336 static char __pw_namecache[UAI$S_IDENT+1];
11337
11338 /*
11339  * This routine does most of the work extracting the user information.
11340  */
11341 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11342 {
11343     static struct {
11344         unsigned char length;
11345         char pw_gecos[UAI$S_OWNER+1];
11346     } owner;
11347     static union uicdef uic;
11348     static struct {
11349         unsigned char length;
11350         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11351     } defdev;
11352     static struct {
11353         unsigned char length;
11354         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11355     } defdir;
11356     static struct {
11357         unsigned char length;
11358         char pw_shell[UAI$S_DEFCLI+1];
11359     } defcli;
11360     static char pw_passwd[UAI$S_PWD+1];
11361
11362     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11363     struct dsc$descriptor_s name_desc;
11364     unsigned long int sts;
11365
11366     static struct itmlst_3 itmlst[]= {
11367         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11368         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11369         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11370         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11371         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11372         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11373         {0,                0,           NULL,    NULL}};
11374
11375     name_desc.dsc$w_length=  strlen(name);
11376     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11377     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11378     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11379
11380 /*  Note that sys$getuai returns many fields as counted strings. */
11381     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11382     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11383       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11384     }
11385     else { _ckvmssts(sts); }
11386     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11387
11388     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11389     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11390     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11391     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11392     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11393     owner.pw_gecos[lowner]=            '\0';
11394     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11395     defcli.pw_shell[ldefcli]=          '\0';
11396     if (valid_uic(uic)) {
11397         pwd->pw_uid= uic.uic$l_uic;
11398         pwd->pw_gid= uic.uic$v_group;
11399     }
11400     else
11401       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11402     pwd->pw_passwd=  pw_passwd;
11403     pwd->pw_gecos=   owner.pw_gecos;
11404     pwd->pw_dir=     defdev.pw_dir;
11405     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11406     pwd->pw_shell=   defcli.pw_shell;
11407     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11408         int ldir;
11409         ldir= strlen(pwd->pw_unixdir) - 1;
11410         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11411     }
11412     else
11413         strcpy(pwd->pw_unixdir, pwd->pw_dir);
11414     if (!decc_efs_case_preserve)
11415         __mystrtolower(pwd->pw_unixdir);
11416     return 1;
11417 }
11418
11419 /*
11420  * Get information for a named user.
11421 */
11422 /*{{{struct passwd *getpwnam(char *name)*/
11423 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11424 {
11425     struct dsc$descriptor_s name_desc;
11426     union uicdef uic;
11427     unsigned long int sts;
11428
11429     __pwdcache = __passwd_empty;
11430     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11431       /* We still may be able to determine pw_uid and pw_gid */
11432       name_desc.dsc$w_length=  strlen(name);
11433       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11434       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11435       name_desc.dsc$a_pointer= (char *) name;
11436       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11437         __pwdcache.pw_uid= uic.uic$l_uic;
11438         __pwdcache.pw_gid= uic.uic$v_group;
11439       }
11440       else {
11441         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11442           set_vaxc_errno(sts);
11443           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11444           return NULL;
11445         }
11446         else { _ckvmssts(sts); }
11447       }
11448     }
11449     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11450     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11451     __pwdcache.pw_name= __pw_namecache;
11452     return &__pwdcache;
11453 }  /* end of my_getpwnam() */
11454 /*}}}*/
11455
11456 /*
11457  * Get information for a particular UIC or UID.
11458  * Called by my_getpwent with uid=-1 to list all users.
11459 */
11460 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11461 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11462 {
11463     const $DESCRIPTOR(name_desc,__pw_namecache);
11464     unsigned short lname;
11465     union uicdef uic;
11466     unsigned long int status;
11467
11468     if (uid == (unsigned int) -1) {
11469       do {
11470         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11471         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11472           set_vaxc_errno(status);
11473           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11474           my_endpwent();
11475           return NULL;
11476         }
11477         else { _ckvmssts(status); }
11478       } while (!valid_uic (uic));
11479     }
11480     else {
11481       uic.uic$l_uic= uid;
11482       if (!uic.uic$v_group)
11483         uic.uic$v_group= PerlProc_getgid();
11484       if (valid_uic(uic))
11485         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11486       else status = SS$_IVIDENT;
11487       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11488           status == RMS$_PRV) {
11489         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11490         return NULL;
11491       }
11492       else { _ckvmssts(status); }
11493     }
11494     __pw_namecache[lname]= '\0';
11495     __mystrtolower(__pw_namecache);
11496
11497     __pwdcache = __passwd_empty;
11498     __pwdcache.pw_name = __pw_namecache;
11499
11500 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11501     The identifier's value is usually the UIC, but it doesn't have to be,
11502     so if we can, we let fillpasswd update this. */
11503     __pwdcache.pw_uid =  uic.uic$l_uic;
11504     __pwdcache.pw_gid =  uic.uic$v_group;
11505
11506     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11507     return &__pwdcache;
11508
11509 }  /* end of my_getpwuid() */
11510 /*}}}*/
11511
11512 /*
11513  * Get information for next user.
11514 */
11515 /*{{{struct passwd *my_getpwent()*/
11516 struct passwd *Perl_my_getpwent(pTHX)
11517 {
11518     return (my_getpwuid((unsigned int) -1));
11519 }
11520 /*}}}*/
11521
11522 /*
11523  * Finish searching rights database for users.
11524 */
11525 /*{{{void my_endpwent()*/
11526 void Perl_my_endpwent(pTHX)
11527 {
11528     if (contxt) {
11529       _ckvmssts(sys$finish_rdb(&contxt));
11530       contxt= 0;
11531     }
11532 }
11533 /*}}}*/
11534
11535 #ifdef HOMEGROWN_POSIX_SIGNALS
11536   /* Signal handling routines, pulled into the core from POSIX.xs.
11537    *
11538    * We need these for threads, so they've been rolled into the core,
11539    * rather than left in POSIX.xs.
11540    *
11541    * (DRS, Oct 23, 1997)
11542    */
11543
11544   /* sigset_t is atomic under VMS, so these routines are easy */
11545 /*{{{int my_sigemptyset(sigset_t *) */
11546 int my_sigemptyset(sigset_t *set) {
11547     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11548     *set = 0; return 0;
11549 }
11550 /*}}}*/
11551
11552
11553 /*{{{int my_sigfillset(sigset_t *)*/
11554 int my_sigfillset(sigset_t *set) {
11555     int i;
11556     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11557     for (i = 0; i < NSIG; i++) *set |= (1 << i);
11558     return 0;
11559 }
11560 /*}}}*/
11561
11562
11563 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11564 int my_sigaddset(sigset_t *set, int sig) {
11565     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11566     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11567     *set |= (1 << (sig - 1));
11568     return 0;
11569 }
11570 /*}}}*/
11571
11572
11573 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11574 int my_sigdelset(sigset_t *set, int sig) {
11575     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11576     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11577     *set &= ~(1 << (sig - 1));
11578     return 0;
11579 }
11580 /*}}}*/
11581
11582
11583 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11584 int my_sigismember(sigset_t *set, int sig) {
11585     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11586     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11587     return *set & (1 << (sig - 1));
11588 }
11589 /*}}}*/
11590
11591
11592 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11593 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11594     sigset_t tempmask;
11595
11596     /* If set and oset are both null, then things are badly wrong. Bail out. */
11597     if ((oset == NULL) && (set == NULL)) {
11598       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11599       return -1;
11600     }
11601
11602     /* If set's null, then we're just handling a fetch. */
11603     if (set == NULL) {
11604         tempmask = sigblock(0);
11605     }
11606     else {
11607       switch (how) {
11608       case SIG_SETMASK:
11609         tempmask = sigsetmask(*set);
11610         break;
11611       case SIG_BLOCK:
11612         tempmask = sigblock(*set);
11613         break;
11614       case SIG_UNBLOCK:
11615         tempmask = sigblock(0);
11616         sigsetmask(*oset & ~tempmask);
11617         break;
11618       default:
11619         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11620         return -1;
11621       }
11622     }
11623
11624     /* Did they pass us an oset? If so, stick our holding mask into it */
11625     if (oset)
11626       *oset = tempmask;
11627
11628     return 0;
11629 }
11630 /*}}}*/
11631 #endif  /* HOMEGROWN_POSIX_SIGNALS */
11632
11633
11634 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11635  * my_utime(), and flex_stat(), all of which operate on UTC unless
11636  * VMSISH_TIMES is true.
11637  */
11638 /* method used to handle UTC conversions:
11639  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11640  */
11641 static int gmtime_emulation_type;
11642 /* number of secs to add to UTC POSIX-style time to get local time */
11643 static long int utc_offset_secs;
11644
11645 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11646  * in vmsish.h.  #undef them here so we can call the CRTL routines
11647  * directly.
11648  */
11649 #undef gmtime
11650 #undef localtime
11651 #undef time
11652
11653
11654 /*
11655  * DEC C previous to 6.0 corrupts the behavior of the /prefix
11656  * qualifier with the extern prefix pragma.  This provisional
11657  * hack circumvents this prefix pragma problem in previous
11658  * precompilers.
11659  */
11660 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11661 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11662 #    pragma __extern_prefix save
11663 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
11664 #    define gmtime decc$__utctz_gmtime
11665 #    define localtime decc$__utctz_localtime
11666 #    define time decc$__utc_time
11667 #    pragma __extern_prefix restore
11668
11669      struct tm *gmtime(), *localtime();
11670
11671 #  endif
11672 #endif
11673
11674
11675 static time_t toutc_dst(time_t loc) {
11676   struct tm *rsltmp;
11677
11678   if ((rsltmp = localtime(&loc)) == NULL) return -1;
11679   loc -= utc_offset_secs;
11680   if (rsltmp->tm_isdst) loc -= 3600;
11681   return loc;
11682 }
11683 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11684        ((gmtime_emulation_type || my_time(NULL)), \
11685        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11686        ((secs) - utc_offset_secs))))
11687
11688 static time_t toloc_dst(time_t utc) {
11689   struct tm *rsltmp;
11690
11691   utc += utc_offset_secs;
11692   if ((rsltmp = localtime(&utc)) == NULL) return -1;
11693   if (rsltmp->tm_isdst) utc += 3600;
11694   return utc;
11695 }
11696 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11697        ((gmtime_emulation_type || my_time(NULL)), \
11698        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11699        ((secs) + utc_offset_secs))))
11700
11701 #ifndef RTL_USES_UTC
11702 /*
11703
11704     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
11705         DST starts on 1st sun of april      at 02:00  std time
11706             ends on last sun of october     at 02:00  dst time
11707     see the UCX management command reference, SET CONFIG TIMEZONE
11708     for formatting info.
11709
11710     No, it's not as general as it should be, but then again, NOTHING
11711     will handle UK times in a sensible way.
11712 */
11713
11714
11715 /*
11716     parse the DST start/end info:
11717     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11718 */
11719
11720 static char *
11721 tz_parse_startend(char *s, struct tm *w, int *past)
11722 {
11723     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11724     int ly, dozjd, d, m, n, hour, min, sec, j, k;
11725     time_t g;
11726
11727     if (!s)    return 0;
11728     if (!w) return 0;
11729     if (!past) return 0;
11730
11731     ly = 0;
11732     if (w->tm_year % 4        == 0) ly = 1;
11733     if (w->tm_year % 100      == 0) ly = 0;
11734     if (w->tm_year+1900 % 400 == 0) ly = 1;
11735     if (ly) dinm[1]++;
11736
11737     dozjd = isdigit(*s);
11738     if (*s == 'J' || *s == 'j' || dozjd) {
11739         if (!dozjd && !isdigit(*++s)) return 0;
11740         d = *s++ - '0';
11741         if (isdigit(*s)) {
11742             d = d*10 + *s++ - '0';
11743             if (isdigit(*s)) {
11744                 d = d*10 + *s++ - '0';
11745             }
11746         }
11747         if (d == 0) return 0;
11748         if (d > 366) return 0;
11749         d--;
11750         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
11751         g = d * 86400;
11752         dozjd = 1;
11753     } else if (*s == 'M' || *s == 'm') {
11754         if (!isdigit(*++s)) return 0;
11755         m = *s++ - '0';
11756         if (isdigit(*s)) m = 10*m + *s++ - '0';
11757         if (*s != '.') return 0;
11758         if (!isdigit(*++s)) return 0;
11759         n = *s++ - '0';
11760         if (n < 1 || n > 5) return 0;
11761         if (*s != '.') return 0;
11762         if (!isdigit(*++s)) return 0;
11763         d = *s++ - '0';
11764         if (d > 6) return 0;
11765     }
11766
11767     if (*s == '/') {
11768         if (!isdigit(*++s)) return 0;
11769         hour = *s++ - '0';
11770         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11771         if (*s == ':') {
11772             if (!isdigit(*++s)) return 0;
11773             min = *s++ - '0';
11774             if (isdigit(*s)) min = 10*min + *s++ - '0';
11775             if (*s == ':') {
11776                 if (!isdigit(*++s)) return 0;
11777                 sec = *s++ - '0';
11778                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11779             }
11780         }
11781     } else {
11782         hour = 2;
11783         min = 0;
11784         sec = 0;
11785     }
11786
11787     if (dozjd) {
11788         if (w->tm_yday < d) goto before;
11789         if (w->tm_yday > d) goto after;
11790     } else {
11791         if (w->tm_mon+1 < m) goto before;
11792         if (w->tm_mon+1 > m) goto after;
11793
11794         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11795         k = d - j; /* mday of first d */
11796         if (k <= 0) k += 7;
11797         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11798         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11799         if (w->tm_mday < k) goto before;
11800         if (w->tm_mday > k) goto after;
11801     }
11802
11803     if (w->tm_hour < hour) goto before;
11804     if (w->tm_hour > hour) goto after;
11805     if (w->tm_min  < min)  goto before;
11806     if (w->tm_min  > min)  goto after;
11807     if (w->tm_sec  < sec)  goto before;
11808     goto after;
11809
11810 before:
11811     *past = 0;
11812     return s;
11813 after:
11814     *past = 1;
11815     return s;
11816 }
11817
11818
11819
11820
11821 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11822
11823 static char *
11824 tz_parse_offset(char *s, int *offset)
11825 {
11826     int hour = 0, min = 0, sec = 0;
11827     int neg = 0;
11828     if (!s) return 0;
11829     if (!offset) return 0;
11830
11831     if (*s == '-') {neg++; s++;}
11832     if (*s == '+') s++;
11833     if (!isdigit(*s)) return 0;
11834     hour = *s++ - '0';
11835     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11836     if (hour > 24) return 0;
11837     if (*s == ':') {
11838         if (!isdigit(*++s)) return 0;
11839         min = *s++ - '0';
11840         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11841         if (min > 59) return 0;
11842         if (*s == ':') {
11843             if (!isdigit(*++s)) return 0;
11844             sec = *s++ - '0';
11845             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11846             if (sec > 59) return 0;
11847         }
11848     }
11849
11850     *offset = (hour*60+min)*60 + sec;
11851     if (neg) *offset = -*offset;
11852     return s;
11853 }
11854
11855 /*
11856     input time is w, whatever type of time the CRTL localtime() uses.
11857     sets dst, the zone, and the gmtoff (seconds)
11858
11859     caches the value of TZ and UCX$TZ env variables; note that
11860     my_setenv looks for these and sets a flag if they're changed
11861     for efficiency.
11862
11863     We have to watch out for the "australian" case (dst starts in
11864     october, ends in april)...flagged by "reverse" and checked by
11865     scanning through the months of the previous year.
11866
11867 */
11868
11869 static int
11870 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11871 {
11872     time_t when;
11873     struct tm *w2;
11874     char *s,*s2;
11875     char *dstzone, *tz, *s_start, *s_end;
11876     int std_off, dst_off, isdst;
11877     int y, dststart, dstend;
11878     static char envtz[1025];  /* longer than any logical, symbol, ... */
11879     static char ucxtz[1025];
11880     static char reversed = 0;
11881
11882     if (!w) return 0;
11883
11884     if (tz_updated) {
11885         tz_updated = 0;
11886         reversed = -1;  /* flag need to check  */
11887         envtz[0] = ucxtz[0] = '\0';
11888         tz = my_getenv("TZ",0);
11889         if (tz) strcpy(envtz, tz);
11890         tz = my_getenv("UCX$TZ",0);
11891         if (tz) strcpy(ucxtz, tz);
11892         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11893     }
11894     tz = envtz;
11895     if (!*tz) tz = ucxtz;
11896
11897     s = tz;
11898     while (isalpha(*s)) s++;
11899     s = tz_parse_offset(s, &std_off);
11900     if (!s) return 0;
11901     if (!*s) {                  /* no DST, hurray we're done! */
11902         isdst = 0;
11903         goto done;
11904     }
11905
11906     dstzone = s;
11907     while (isalpha(*s)) s++;
11908     s2 = tz_parse_offset(s, &dst_off);
11909     if (s2) {
11910         s = s2;
11911     } else {
11912         dst_off = std_off - 3600;
11913     }
11914
11915     if (!*s) {      /* default dst start/end?? */
11916         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11917             s = strchr(ucxtz,',');
11918         }
11919         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11920     }
11921     if (*s != ',') return 0;
11922
11923     when = *w;
11924     when = _toutc(when);      /* convert to utc */
11925     when = when - std_off;    /* convert to pseudolocal time*/
11926
11927     w2 = localtime(&when);
11928     y = w2->tm_year;
11929     s_start = s+1;
11930     s = tz_parse_startend(s_start,w2,&dststart);
11931     if (!s) return 0;
11932     if (*s != ',') return 0;
11933
11934     when = *w;
11935     when = _toutc(when);      /* convert to utc */
11936     when = when - dst_off;    /* convert to pseudolocal time*/
11937     w2 = localtime(&when);
11938     if (w2->tm_year != y) {   /* spans a year, just check one time */
11939         when += dst_off - std_off;
11940         w2 = localtime(&when);
11941     }
11942     s_end = s+1;
11943     s = tz_parse_startend(s_end,w2,&dstend);
11944     if (!s) return 0;
11945
11946     if (reversed == -1) {  /* need to check if start later than end */
11947         int j, ds, de;
11948
11949         when = *w;
11950         if (when < 2*365*86400) {
11951             when += 2*365*86400;
11952         } else {
11953             when -= 365*86400;
11954         }
11955         w2 =localtime(&when);
11956         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11957
11958         for (j = 0; j < 12; j++) {
11959             w2 =localtime(&when);
11960             tz_parse_startend(s_start,w2,&ds);
11961             tz_parse_startend(s_end,w2,&de);
11962             if (ds != de) break;
11963             when += 30*86400;
11964         }
11965         reversed = 0;
11966         if (de && !ds) reversed = 1;
11967     }
11968
11969     isdst = dststart && !dstend;
11970     if (reversed) isdst = dststart  || !dstend;
11971
11972 done:
11973     if (dst)    *dst = isdst;
11974     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11975     if (isdst)  tz = dstzone;
11976     if (zone) {
11977         while(isalpha(*tz))  *zone++ = *tz++;
11978         *zone = '\0';
11979     }
11980     return 1;
11981 }
11982
11983 #endif /* !RTL_USES_UTC */
11984
11985 /* my_time(), my_localtime(), my_gmtime()
11986  * By default traffic in UTC time values, using CRTL gmtime() or
11987  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11988  * Note: We need to use these functions even when the CRTL has working
11989  * UTC support, since they also handle C<use vmsish qw(times);>
11990  *
11991  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11992  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11993  */
11994
11995 /*{{{time_t my_time(time_t *timep)*/
11996 time_t Perl_my_time(pTHX_ time_t *timep)
11997 {
11998   time_t when;
11999   struct tm *tm_p;
12000
12001   if (gmtime_emulation_type == 0) {
12002     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
12003                               /* results of calls to gmtime() and localtime() */
12004                               /* for same &base */
12005
12006     gmtime_emulation_type++;
12007     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
12008       char off[LNM$C_NAMLENGTH+1];;
12009
12010       gmtime_emulation_type++;
12011       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
12012         gmtime_emulation_type++;
12013         utc_offset_secs = 0;
12014         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
12015       }
12016       else { utc_offset_secs = atol(off); }
12017     }
12018     else { /* We've got a working gmtime() */
12019       struct tm gmt, local;
12020
12021       gmt = *tm_p;
12022       tm_p = localtime(&base);
12023       local = *tm_p;
12024       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
12025       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
12026       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
12027       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
12028     }
12029   }
12030
12031   when = time(NULL);
12032 # ifdef VMSISH_TIME
12033 # ifdef RTL_USES_UTC
12034   if (VMSISH_TIME) when = _toloc(when);
12035 # else
12036   if (!VMSISH_TIME) when = _toutc(when);
12037 # endif
12038 # endif
12039   if (timep != NULL) *timep = when;
12040   return when;
12041
12042 }  /* end of my_time() */
12043 /*}}}*/
12044
12045
12046 /*{{{struct tm *my_gmtime(const time_t *timep)*/
12047 struct tm *
12048 Perl_my_gmtime(pTHX_ const time_t *timep)
12049 {
12050   time_t when;
12051   struct tm *rsltmp;
12052
12053   if (timep == NULL) {
12054     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12055     return NULL;
12056   }
12057   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12058
12059   when = *timep;
12060 # ifdef VMSISH_TIME
12061   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
12062 #  endif
12063 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
12064   return gmtime(&when);
12065 # else
12066   /* CRTL localtime() wants local time as input, so does no tz correction */
12067   rsltmp = localtime(&when);
12068   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
12069   return rsltmp;
12070 #endif
12071 }  /* end of my_gmtime() */
12072 /*}}}*/
12073
12074
12075 /*{{{struct tm *my_localtime(const time_t *timep)*/
12076 struct tm *
12077 Perl_my_localtime(pTHX_ const time_t *timep)
12078 {
12079   time_t when, whenutc;
12080   struct tm *rsltmp;
12081   int dst, offset;
12082
12083   if (timep == NULL) {
12084     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12085     return NULL;
12086   }
12087   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12088   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
12089
12090   when = *timep;
12091 # ifdef RTL_USES_UTC
12092 # ifdef VMSISH_TIME
12093   if (VMSISH_TIME) when = _toutc(when);
12094 # endif
12095   /* CRTL localtime() wants UTC as input, does tz correction itself */
12096   return localtime(&when);
12097
12098 # else /* !RTL_USES_UTC */
12099   whenutc = when;
12100 # ifdef VMSISH_TIME
12101   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
12102   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
12103 # endif
12104   dst = -1;
12105 #ifndef RTL_USES_UTC
12106   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
12107       when = whenutc - offset;                   /* pseudolocal time*/
12108   }
12109 # endif
12110   /* CRTL localtime() wants local time as input, so does no tz correction */
12111   rsltmp = localtime(&when);
12112   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12113   return rsltmp;
12114 # endif
12115
12116 } /*  end of my_localtime() */
12117 /*}}}*/
12118
12119 /* Reset definitions for later calls */
12120 #define gmtime(t)    my_gmtime(t)
12121 #define localtime(t) my_localtime(t)
12122 #define time(t)      my_time(t)
12123
12124
12125 /* my_utime - update modification/access time of a file
12126  *
12127  * VMS 7.3 and later implementation
12128  * Only the UTC translation is home-grown. The rest is handled by the
12129  * CRTL utime(), which will take into account the relevant feature
12130  * logicals and ODS-5 volume characteristics for true access times.
12131  *
12132  * pre VMS 7.3 implementation:
12133  * The calling sequence is identical to POSIX utime(), but under
12134  * VMS with ODS-2, only the modification time is changed; ODS-2 does
12135  * not maintain access times.  Restrictions differ from the POSIX
12136  * definition in that the time can be changed as long as the
12137  * caller has permission to execute the necessary IO$_MODIFY $QIO;
12138  * no separate checks are made to insure that the caller is the
12139  * owner of the file or has special privs enabled.
12140  * Code here is based on Joe Meadows' FILE utility.
12141  *
12142  */
12143
12144 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12145  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
12146  * in 100 ns intervals.
12147  */
12148 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12149
12150 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12151 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12152 {
12153 #if __CRTL_VER >= 70300000
12154   struct utimbuf utc_utimes, *utc_utimesp;
12155
12156   if (utimes != NULL) {
12157     utc_utimes.actime = utimes->actime;
12158     utc_utimes.modtime = utimes->modtime;
12159 # ifdef VMSISH_TIME
12160     /* If input was local; convert to UTC for sys svc */
12161     if (VMSISH_TIME) {
12162       utc_utimes.actime = _toutc(utimes->actime);
12163       utc_utimes.modtime = _toutc(utimes->modtime);
12164     }
12165 # endif
12166     utc_utimesp = &utc_utimes;
12167   }
12168   else {
12169     utc_utimesp = NULL;
12170   }
12171
12172   return utime(file, utc_utimesp);
12173
12174 #else /* __CRTL_VER < 70300000 */
12175
12176   register int i;
12177   int sts;
12178   long int bintime[2], len = 2, lowbit, unixtime,
12179            secscale = 10000000; /* seconds --> 100 ns intervals */
12180   unsigned long int chan, iosb[2], retsts;
12181   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12182   struct FAB myfab = cc$rms_fab;
12183   struct NAM mynam = cc$rms_nam;
12184 #if defined (__DECC) && defined (__VAX)
12185   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12186    * at least through VMS V6.1, which causes a type-conversion warning.
12187    */
12188 #  pragma message save
12189 #  pragma message disable cvtdiftypes
12190 #endif
12191   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12192   struct fibdef myfib;
12193 #if defined (__DECC) && defined (__VAX)
12194   /* This should be right after the declaration of myatr, but due
12195    * to a bug in VAX DEC C, this takes effect a statement early.
12196    */
12197 #  pragma message restore
12198 #endif
12199   /* cast ok for read only parameter */
12200   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12201                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12202                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12203
12204   if (file == NULL || *file == '\0') {
12205     SETERRNO(ENOENT, LIB$_INVARG);
12206     return -1;
12207   }
12208
12209   /* Convert to VMS format ensuring that it will fit in 255 characters */
12210   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12211       SETERRNO(ENOENT, LIB$_INVARG);
12212       return -1;
12213   }
12214   if (utimes != NULL) {
12215     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
12216      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12217      * Since time_t is unsigned long int, and lib$emul takes a signed long int
12218      * as input, we force the sign bit to be clear by shifting unixtime right
12219      * one bit, then multiplying by an extra factor of 2 in lib$emul().
12220      */
12221     lowbit = (utimes->modtime & 1) ? secscale : 0;
12222     unixtime = (long int) utimes->modtime;
12223 #   ifdef VMSISH_TIME
12224     /* If input was UTC; convert to local for sys svc */
12225     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12226 #   endif
12227     unixtime >>= 1;  secscale <<= 1;
12228     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12229     if (!(retsts & 1)) {
12230       SETERRNO(EVMSERR, retsts);
12231       return -1;
12232     }
12233     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12234     if (!(retsts & 1)) {
12235       SETERRNO(EVMSERR, retsts);
12236       return -1;
12237     }
12238   }
12239   else {
12240     /* Just get the current time in VMS format directly */
12241     retsts = sys$gettim(bintime);
12242     if (!(retsts & 1)) {
12243       SETERRNO(EVMSERR, retsts);
12244       return -1;
12245     }
12246   }
12247
12248   myfab.fab$l_fna = vmsspec;
12249   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12250   myfab.fab$l_nam = &mynam;
12251   mynam.nam$l_esa = esa;
12252   mynam.nam$b_ess = (unsigned char) sizeof esa;
12253   mynam.nam$l_rsa = rsa;
12254   mynam.nam$b_rss = (unsigned char) sizeof rsa;
12255   if (decc_efs_case_preserve)
12256       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12257
12258   /* Look for the file to be affected, letting RMS parse the file
12259    * specification for us as well.  I have set errno using only
12260    * values documented in the utime() man page for VMS POSIX.
12261    */
12262   retsts = sys$parse(&myfab,0,0);
12263   if (!(retsts & 1)) {
12264     set_vaxc_errno(retsts);
12265     if      (retsts == RMS$_PRV) set_errno(EACCES);
12266     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12267     else                         set_errno(EVMSERR);
12268     return -1;
12269   }
12270   retsts = sys$search(&myfab,0,0);
12271   if (!(retsts & 1)) {
12272     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12273     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12274     set_vaxc_errno(retsts);
12275     if      (retsts == RMS$_PRV) set_errno(EACCES);
12276     else if (retsts == RMS$_FNF) set_errno(ENOENT);
12277     else                         set_errno(EVMSERR);
12278     return -1;
12279   }
12280
12281   devdsc.dsc$w_length = mynam.nam$b_dev;
12282   /* cast ok for read only parameter */
12283   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12284
12285   retsts = sys$assign(&devdsc,&chan,0,0);
12286   if (!(retsts & 1)) {
12287     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12288     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12289     set_vaxc_errno(retsts);
12290     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
12291     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
12292     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
12293     else                               set_errno(EVMSERR);
12294     return -1;
12295   }
12296
12297   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12298   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12299
12300   memset((void *) &myfib, 0, sizeof myfib);
12301 #if defined(__DECC) || defined(__DECCXX)
12302   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12303   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12304   /* This prevents the revision time of the file being reset to the current
12305    * time as a result of our IO$_MODIFY $QIO. */
12306   myfib.fib$l_acctl = FIB$M_NORECORD;
12307 #else
12308   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12309   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12310   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12311 #endif
12312   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12313   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12314   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12315   _ckvmssts(sys$dassgn(chan));
12316   if (retsts & 1) retsts = iosb[0];
12317   if (!(retsts & 1)) {
12318     set_vaxc_errno(retsts);
12319     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12320     else                      set_errno(EVMSERR);
12321     return -1;
12322   }
12323
12324   return 0;
12325
12326 #endif /* #if __CRTL_VER >= 70300000 */
12327
12328 }  /* end of my_utime() */
12329 /*}}}*/
12330
12331 /*
12332  * flex_stat, flex_lstat, flex_fstat
12333  * basic stat, but gets it right when asked to stat
12334  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12335  */
12336
12337 #ifndef _USE_STD_STAT
12338 /* encode_dev packs a VMS device name string into an integer to allow
12339  * simple comparisons. This can be used, for example, to check whether two
12340  * files are located on the same device, by comparing their encoded device
12341  * names. Even a string comparison would not do, because stat() reuses the
12342  * device name buffer for each call; so without encode_dev, it would be
12343  * necessary to save the buffer and use strcmp (this would mean a number of
12344  * changes to the standard Perl code, to say nothing of what a Perl script
12345  * would have to do.
12346  *
12347  * The device lock id, if it exists, should be unique (unless perhaps compared
12348  * with lock ids transferred from other nodes). We have a lock id if the disk is
12349  * mounted cluster-wide, which is when we tend to get long (host-qualified)
12350  * device names. Thus we use the lock id in preference, and only if that isn't
12351  * available, do we try to pack the device name into an integer (flagged by
12352  * the sign bit (LOCKID_MASK) being set).
12353  *
12354  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12355  * name and its encoded form, but it seems very unlikely that we will find
12356  * two files on different disks that share the same encoded device names,
12357  * and even more remote that they will share the same file id (if the test
12358  * is to check for the same file).
12359  *
12360  * A better method might be to use sys$device_scan on the first call, and to
12361  * search for the device, returning an index into the cached array.
12362  * The number returned would be more intelligible.
12363  * This is probably not worth it, and anyway would take quite a bit longer
12364  * on the first call.
12365  */
12366 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
12367 static mydev_t encode_dev (pTHX_ const char *dev)
12368 {
12369   int i;
12370   unsigned long int f;
12371   mydev_t enc;
12372   char c;
12373   const char *q;
12374
12375   if (!dev || !dev[0]) return 0;
12376
12377 #if LOCKID_MASK
12378   {
12379     struct dsc$descriptor_s dev_desc;
12380     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12381
12382     /* For cluster-mounted disks, the disk lock identifier is unique, so we
12383        can try that first. */
12384     dev_desc.dsc$w_length =  strlen (dev);
12385     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
12386     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
12387     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
12388     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12389     if (!$VMS_STATUS_SUCCESS(status)) {
12390       switch (status) {
12391         case SS$_NOSUCHDEV:
12392           SETERRNO(ENODEV, status);
12393           return 0;
12394         default:
12395           _ckvmssts(status);
12396       }
12397     }
12398     if (lockid) return (lockid & ~LOCKID_MASK);
12399   }
12400 #endif
12401
12402   /* Otherwise we try to encode the device name */
12403   enc = 0;
12404   f = 1;
12405   i = 0;
12406   for (q = dev + strlen(dev); q--; q >= dev) {
12407     if (*q == ':')
12408         break;
12409     if (isdigit (*q))
12410       c= (*q) - '0';
12411     else if (isalpha (toupper (*q)))
12412       c= toupper (*q) - 'A' + (char)10;
12413     else
12414       continue; /* Skip '$'s */
12415     i++;
12416     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
12417     if (i>1) f *= 36;
12418     enc += f * (unsigned long int) c;
12419   }
12420   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
12421
12422 }  /* end of encode_dev() */
12423 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12424         device_no = encode_dev(aTHX_ devname)
12425 #else
12426 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12427         device_no = new_dev_no
12428 #endif
12429
12430 static int
12431 is_null_device(const char *name)
12432 {
12433   if (decc_bug_devnull != 0) {
12434     if (strncmp("/dev/null", name, 9) == 0)
12435       return 1;
12436   }
12437     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12438        The underscore prefix, controller letter, and unit number are
12439        independently optional; for our purposes, the colon punctuation
12440        is not.  The colon can be trailed by optional directory and/or
12441        filename, but two consecutive colons indicates a nodename rather
12442        than a device.  [pr]  */
12443   if (*name == '_') ++name;
12444   if (tolower(*name++) != 'n') return 0;
12445   if (tolower(*name++) != 'l') return 0;
12446   if (tolower(*name) == 'a') ++name;
12447   if (*name == '0') ++name;
12448   return (*name++ == ':') && (*name != ':');
12449 }
12450
12451 static int
12452 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
12453
12454 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
12455
12456 static I32
12457 Perl_cando_by_name_int
12458    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12459 {
12460   char usrname[L_cuserid];
12461   struct dsc$descriptor_s usrdsc =
12462          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12463   char *vmsname = NULL, *fileified = NULL;
12464   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12465   unsigned short int retlen, trnlnm_iter_count;
12466   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12467   union prvdef curprv;
12468   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12469          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12470          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12471   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12472          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12473          {0,0,0,0}};
12474   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12475          {0,0,0,0}};
12476   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12477   Stat_t st;
12478   static int profile_context = -1;
12479
12480   if (!fname || !*fname) return FALSE;
12481
12482   /* Make sure we expand logical names, since sys$check_access doesn't */
12483   fileified = PerlMem_malloc(VMS_MAXRSS);
12484   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12485   if (!strpbrk(fname,"/]>:")) {
12486       strcpy(fileified,fname);
12487       trnlnm_iter_count = 0;
12488       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12489         trnlnm_iter_count++;
12490         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12491       }
12492       fname = fileified;
12493   }
12494
12495   vmsname = PerlMem_malloc(VMS_MAXRSS);
12496   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12497   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12498     /* Don't know if already in VMS format, so make sure */
12499     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12500       PerlMem_free(fileified);
12501       PerlMem_free(vmsname);
12502       return FALSE;
12503     }
12504   }
12505   else {
12506     strcpy(vmsname,fname);
12507   }
12508
12509   /* sys$check_access needs a file spec, not a directory spec.
12510    * flex_stat now will handle a null thread context during startup.
12511    */
12512
12513   retlen = namdsc.dsc$w_length = strlen(vmsname);
12514   if (vmsname[retlen-1] == ']'
12515       || vmsname[retlen-1] == '>'
12516       || vmsname[retlen-1] == ':'
12517       || (!flex_stat_int(vmsname, &st, 1) &&
12518           S_ISDIR(st.st_mode))) {
12519
12520       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12521         PerlMem_free(fileified);
12522         PerlMem_free(vmsname);
12523         return FALSE;
12524       }
12525       fname = fileified;
12526   }
12527   else {
12528       fname = vmsname;
12529   }
12530
12531   retlen = namdsc.dsc$w_length = strlen(fname);
12532   namdsc.dsc$a_pointer = (char *)fname;
12533
12534   switch (bit) {
12535     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12536       access = ARM$M_EXECUTE;
12537       flags = CHP$M_READ;
12538       break;
12539     case S_IRUSR: case S_IRGRP: case S_IROTH:
12540       access = ARM$M_READ;
12541       flags = CHP$M_READ | CHP$M_USEREADALL;
12542       break;
12543     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12544       access = ARM$M_WRITE;
12545       flags = CHP$M_READ | CHP$M_WRITE;
12546       break;
12547     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12548       access = ARM$M_DELETE;
12549       flags = CHP$M_READ | CHP$M_WRITE;
12550       break;
12551     default:
12552       if (fileified != NULL)
12553         PerlMem_free(fileified);
12554       if (vmsname != NULL)
12555         PerlMem_free(vmsname);
12556       return FALSE;
12557   }
12558
12559   /* Before we call $check_access, create a user profile with the current
12560    * process privs since otherwise it just uses the default privs from the
12561    * UAF and might give false positives or negatives.  This only works on
12562    * VMS versions v6.0 and later since that's when sys$create_user_profile
12563    * became available.
12564    */
12565
12566   /* get current process privs and username */
12567   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12568   _ckvmssts_noperl(iosb[0]);
12569
12570 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12571
12572   /* find out the space required for the profile */
12573   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12574                                     &usrprodsc.dsc$w_length,&profile_context));
12575
12576   /* allocate space for the profile and get it filled in */
12577   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12578   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12579   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12580                                     &usrprodsc.dsc$w_length,&profile_context));
12581
12582   /* use the profile to check access to the file; free profile & analyze results */
12583   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12584   PerlMem_free(usrprodsc.dsc$a_pointer);
12585   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12586
12587 #else
12588
12589   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12590
12591 #endif
12592
12593   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12594       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12595       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12596     set_vaxc_errno(retsts);
12597     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12598     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12599     else set_errno(ENOENT);
12600     if (fileified != NULL)
12601       PerlMem_free(fileified);
12602     if (vmsname != NULL)
12603       PerlMem_free(vmsname);
12604     return FALSE;
12605   }
12606   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12607     if (fileified != NULL)
12608       PerlMem_free(fileified);
12609     if (vmsname != NULL)
12610       PerlMem_free(vmsname);
12611     return TRUE;
12612   }
12613   _ckvmssts_noperl(retsts);
12614
12615   if (fileified != NULL)
12616     PerlMem_free(fileified);
12617   if (vmsname != NULL)
12618     PerlMem_free(vmsname);
12619   return FALSE;  /* Should never get here */
12620
12621 }
12622
12623 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12624 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12625  * subset of the applicable information.
12626  */
12627 bool
12628 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12629 {
12630   return cando_by_name_int
12631         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12632 }  /* end of cando() */
12633 /*}}}*/
12634
12635
12636 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12637 I32
12638 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12639 {
12640    return cando_by_name_int(bit, effective, fname, 0);
12641
12642 }  /* end of cando_by_name() */
12643 /*}}}*/
12644
12645
12646 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12647 int
12648 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12649 {
12650   if (!fstat(fd, &statbufp->crtl_stat)) {
12651     char *cptr;
12652     char *vms_filename;
12653     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12654     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12655
12656     /* Save name for cando by name in VMS format */
12657     cptr = getname(fd, vms_filename, 1);
12658
12659     /* This should not happen, but just in case */
12660     if (cptr == NULL) {
12661         statbufp->st_devnam[0] = 0;
12662     }
12663     else {
12664         /* Make sure that the saved name fits in 255 characters */
12665         cptr = int_rmsexpand_vms
12666                        (vms_filename,
12667                         statbufp->st_devnam,
12668                         0);
12669         if (cptr == NULL)
12670             statbufp->st_devnam[0] = 0;
12671     }
12672     PerlMem_free(vms_filename);
12673
12674     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12675     VMS_DEVICE_ENCODE
12676         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12677
12678 #   ifdef RTL_USES_UTC
12679 #   ifdef VMSISH_TIME
12680     if (VMSISH_TIME) {
12681       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12682       statbufp->st_atime = _toloc(statbufp->st_atime);
12683       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12684     }
12685 #   endif
12686 #   else
12687 #   ifdef VMSISH_TIME
12688     if (!VMSISH_TIME) { /* Return UTC instead of local time */
12689 #   else
12690     if (1) {
12691 #   endif
12692       statbufp->st_mtime = _toutc(statbufp->st_mtime);
12693       statbufp->st_atime = _toutc(statbufp->st_atime);
12694       statbufp->st_ctime = _toutc(statbufp->st_ctime);
12695     }
12696 #endif
12697     return 0;
12698   }
12699   return -1;
12700
12701 }  /* end of flex_fstat() */
12702 /*}}}*/
12703
12704 static int
12705 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12706 {
12707     char *fileified;
12708     char *temp_fspec;
12709     const char *save_spec;
12710     char *ret_spec;
12711     int retval = -1;
12712     int efs_hack = 0;
12713     dSAVEDERRNO;
12714
12715     if (!fspec) {
12716         errno = EINVAL;
12717         return retval;
12718     }
12719
12720     if (decc_bug_devnull != 0) {
12721       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12722         memset(statbufp,0,sizeof *statbufp);
12723         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12724         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12725         statbufp->st_uid = 0x00010001;
12726         statbufp->st_gid = 0x0001;
12727         time((time_t *)&statbufp->st_mtime);
12728         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12729         return 0;
12730       }
12731     }
12732
12733     /* Try for a directory name first.  If fspec contains a filename without
12734      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12735      * and sea:[wine.dark]water. exist, we prefer the directory here.
12736      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12737      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12738      * the file with null type, specify this by calling flex_stat() with
12739      * a '.' at the end of fspec.
12740      *
12741      * If we are in Posix filespec mode, accept the filename as is.
12742      */
12743
12744
12745     fileified = PerlMem_malloc(VMS_MAXRSS);
12746     if (fileified == NULL)
12747         _ckvmssts_noperl(SS$_INSFMEM);
12748
12749     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
12750     if (temp_fspec == NULL)
12751         _ckvmssts_noperl(SS$_INSFMEM);
12752
12753     strcpy(temp_fspec, fspec);
12754
12755     SAVE_ERRNO;
12756
12757 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12758   if (decc_posix_compliant_pathnames == 0) {
12759 #endif
12760
12761     /* We may be able to optimize this, but in order for fileify_dirspec to
12762      * always return a usuable answer, we have to call vmspath first to
12763      * make sure that it is in VMS directory format, as stat/lstat on 8.3
12764      * can not handle directories in unix format that it does not have read
12765      * access to.  Vmspath handles the case where a bare name which could be
12766      * a logical name gets passed.
12767      */
12768     ret_spec = int_tovmspath(fspec, temp_fspec, NULL);
12769     if (ret_spec != NULL) {
12770         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
12771         if (ret_spec != NULL) {
12772             if (lstat_flag == 0)
12773                 retval = stat(fileified, &statbufp->crtl_stat);
12774             else
12775                 retval = lstat(fileified, &statbufp->crtl_stat);
12776             save_spec = fileified;
12777         }
12778     }
12779
12780     if (retval && vms_bug_stat_filename) {
12781
12782         /* We should try again as a vmsified file specification */
12783         /* However Perl traditionally has not done this, which  */
12784         /* causes problems with existing tests */
12785
12786         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12787         if (ret_spec != NULL) {
12788             if (lstat_flag == 0)
12789                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12790             else
12791                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12792             save_spec = temp_fspec;
12793         }
12794     }
12795
12796     if (retval) {
12797         /* Last chance - allow multiple dots with out EFS CHARSET */
12798         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12799          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12800          * enable it if it isn't already.
12801          */
12802 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12803         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12804             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12805 #endif
12806         if (lstat_flag == 0)
12807             retval = stat(fspec, &statbufp->crtl_stat);
12808         else
12809             retval = lstat(fspec, &statbufp->crtl_stat);
12810         save_spec = fspec;
12811 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12812         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12813             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12814             efs_hack = 1;
12815         }
12816 #endif
12817     }
12818
12819 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12820   } else {
12821     if (lstat_flag == 0)
12822       retval = stat(temp_fspec, &statbufp->crtl_stat);
12823     else
12824       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12825       save_spec = temp_fspec;
12826   }
12827 #endif
12828
12829 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12830   /* As you were... */
12831   if (!decc_efs_charset)
12832     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12833 #endif
12834
12835     if (!retval) {
12836     char * cptr;
12837     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12838
12839       /* If this is an lstat, do not follow the link */
12840       if (lstat_flag)
12841         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12842
12843 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12844       /* If we used the efs_hack above, we must also use it here for */
12845       /* perl_cando to work */
12846       if (efs_hack && (decc_efs_charset_index > 0)) {
12847           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12848       }
12849 #endif
12850       cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12851 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12852       if (efs_hack && (decc_efs_charset_index > 0)) {
12853           decc$feature_set_value(decc_efs_charset, 1, 0);
12854       }
12855 #endif
12856
12857       /* Fix me: If this is NULL then stat found a file, and we could */
12858       /* not convert the specification to VMS - Should never happen */
12859       if (cptr == NULL)
12860         statbufp->st_devnam[0] = 0;
12861
12862       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12863       VMS_DEVICE_ENCODE
12864         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12865 #     ifdef RTL_USES_UTC
12866 #     ifdef VMSISH_TIME
12867       if (VMSISH_TIME) {
12868         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12869         statbufp->st_atime = _toloc(statbufp->st_atime);
12870         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12871       }
12872 #     endif
12873 #     else
12874 #     ifdef VMSISH_TIME
12875       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12876 #     else
12877       if (1) {
12878 #     endif
12879         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12880         statbufp->st_atime = _toutc(statbufp->st_atime);
12881         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12882       }
12883 #     endif
12884     }
12885     /* If we were successful, leave errno where we found it */
12886     if (retval == 0) RESTORE_ERRNO;
12887     PerlMem_free(temp_fspec);
12888     PerlMem_free(fileified);
12889     return retval;
12890
12891 }  /* end of flex_stat_int() */
12892
12893
12894 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12895 int
12896 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12897 {
12898    return flex_stat_int(fspec, statbufp, 0);
12899 }
12900 /*}}}*/
12901
12902 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12903 int
12904 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12905 {
12906    return flex_stat_int(fspec, statbufp, 1);
12907 }
12908 /*}}}*/
12909
12910
12911 /*{{{char *my_getlogin()*/
12912 /* VMS cuserid == Unix getlogin, except calling sequence */
12913 char *
12914 my_getlogin(void)
12915 {
12916     static char user[L_cuserid];
12917     return cuserid(user);
12918 }
12919 /*}}}*/
12920
12921
12922 /*  rmscopy - copy a file using VMS RMS routines
12923  *
12924  *  Copies contents and attributes of spec_in to spec_out, except owner
12925  *  and protection information.  Name and type of spec_in are used as
12926  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12927  *  should try to propagate timestamps from the input file to the output file.
12928  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12929  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12930  *  propagated to the output file at creation iff the output file specification
12931  *  did not contain an explicit name or type, and the revision date is always
12932  *  updated at the end of the copy operation.  If it is greater than 0, then
12933  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12934  *  other than the revision date should be propagated, and bit 1 indicates
12935  *  that the revision date should be propagated.
12936  *
12937  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12938  *
12939  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12940  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12941  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12942  * as part of the Perl standard distribution under the terms of the
12943  * GNU General Public License or the Perl Artistic License.  Copies
12944  * of each may be found in the Perl standard distribution.
12945  */ /* FIXME */
12946 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12947 int
12948 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12949 {
12950     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12951          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12952     unsigned long int sts;
12953     int dna_len;
12954     struct FAB fab_in, fab_out;
12955     struct RAB rab_in, rab_out;
12956     rms_setup_nam(nam);
12957     rms_setup_nam(nam_out);
12958     struct XABDAT xabdat;
12959     struct XABFHC xabfhc;
12960     struct XABRDT xabrdt;
12961     struct XABSUM xabsum;
12962
12963     vmsin = PerlMem_malloc(VMS_MAXRSS);
12964     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12965     vmsout = PerlMem_malloc(VMS_MAXRSS);
12966     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12967     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12968         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12969       PerlMem_free(vmsin);
12970       PerlMem_free(vmsout);
12971       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12972       return 0;
12973     }
12974
12975     esa = PerlMem_malloc(VMS_MAXRSS);
12976     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12977     esal = NULL;
12978 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12979     esal = PerlMem_malloc(VMS_MAXRSS);
12980     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12981 #endif
12982     fab_in = cc$rms_fab;
12983     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12984     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12985     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12986     fab_in.fab$l_fop = FAB$M_SQO;
12987     rms_bind_fab_nam(fab_in, nam);
12988     fab_in.fab$l_xab = (void *) &xabdat;
12989
12990     rsa = PerlMem_malloc(VMS_MAXRSS);
12991     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12992     rsal = NULL;
12993 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12994     rsal = PerlMem_malloc(VMS_MAXRSS);
12995     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12996 #endif
12997     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12998     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12999     rms_nam_esl(nam) = 0;
13000     rms_nam_rsl(nam) = 0;
13001     rms_nam_esll(nam) = 0;
13002     rms_nam_rsll(nam) = 0;
13003 #ifdef NAM$M_NO_SHORT_UPCASE
13004     if (decc_efs_case_preserve)
13005         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
13006 #endif
13007
13008     xabdat = cc$rms_xabdat;        /* To get creation date */
13009     xabdat.xab$l_nxt = (void *) &xabfhc;
13010
13011     xabfhc = cc$rms_xabfhc;        /* To get record length */
13012     xabfhc.xab$l_nxt = (void *) &xabsum;
13013
13014     xabsum = cc$rms_xabsum;        /* To get key and area information */
13015
13016     if (!((sts = sys$open(&fab_in)) & 1)) {
13017       PerlMem_free(vmsin);
13018       PerlMem_free(vmsout);
13019       PerlMem_free(esa);
13020       if (esal != NULL)
13021         PerlMem_free(esal);
13022       PerlMem_free(rsa);
13023       if (rsal != NULL)
13024         PerlMem_free(rsal);
13025       set_vaxc_errno(sts);
13026       switch (sts) {
13027         case RMS$_FNF: case RMS$_DNF:
13028           set_errno(ENOENT); break;
13029         case RMS$_DIR:
13030           set_errno(ENOTDIR); break;
13031         case RMS$_DEV:
13032           set_errno(ENODEV); break;
13033         case RMS$_SYN:
13034           set_errno(EINVAL); break;
13035         case RMS$_PRV:
13036           set_errno(EACCES); break;
13037         default:
13038           set_errno(EVMSERR);
13039       }
13040       return 0;
13041     }
13042
13043     nam_out = nam;
13044     fab_out = fab_in;
13045     fab_out.fab$w_ifi = 0;
13046     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
13047     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
13048     fab_out.fab$l_fop = FAB$M_SQO;
13049     rms_bind_fab_nam(fab_out, nam_out);
13050     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
13051     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
13052     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
13053     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13054     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13055     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13056     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13057     esal_out = NULL;
13058     rsal_out = NULL;
13059 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13060     esal_out = PerlMem_malloc(VMS_MAXRSS);
13061     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13062     rsal_out = PerlMem_malloc(VMS_MAXRSS);
13063     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13064 #endif
13065     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
13066     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
13067
13068     if (preserve_dates == 0) {  /* Act like DCL COPY */
13069       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
13070       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
13071       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
13072         PerlMem_free(vmsin);
13073         PerlMem_free(vmsout);
13074         PerlMem_free(esa);
13075         if (esal != NULL)
13076             PerlMem_free(esal);
13077         PerlMem_free(rsa);
13078         if (rsal != NULL)
13079             PerlMem_free(rsal);
13080         PerlMem_free(esa_out);
13081         if (esal_out != NULL)
13082             PerlMem_free(esal_out);
13083         PerlMem_free(rsa_out);
13084         if (rsal_out != NULL)
13085             PerlMem_free(rsal_out);
13086         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
13087         set_vaxc_errno(sts);
13088         return 0;
13089       }
13090       fab_out.fab$l_xab = (void *) &xabdat;
13091       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
13092         preserve_dates = 1;
13093     }
13094     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
13095       preserve_dates =0;      /* bitmask from this point forward   */
13096
13097     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
13098     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
13099       PerlMem_free(vmsin);
13100       PerlMem_free(vmsout);
13101       PerlMem_free(esa);
13102       if (esal != NULL)
13103           PerlMem_free(esal);
13104       PerlMem_free(rsa);
13105       if (rsal != NULL)
13106           PerlMem_free(rsal);
13107       PerlMem_free(esa_out);
13108       if (esal_out != NULL)
13109           PerlMem_free(esal_out);
13110       PerlMem_free(rsa_out);
13111       if (rsal_out != NULL)
13112           PerlMem_free(rsal_out);
13113       set_vaxc_errno(sts);
13114       switch (sts) {
13115         case RMS$_DNF:
13116           set_errno(ENOENT); break;
13117         case RMS$_DIR:
13118           set_errno(ENOTDIR); break;
13119         case RMS$_DEV:
13120           set_errno(ENODEV); break;
13121         case RMS$_SYN:
13122           set_errno(EINVAL); break;
13123         case RMS$_PRV:
13124           set_errno(EACCES); break;
13125         default:
13126           set_errno(EVMSERR);
13127       }
13128       return 0;
13129     }
13130     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
13131     if (preserve_dates & 2) {
13132       /* sys$close() will process xabrdt, not xabdat */
13133       xabrdt = cc$rms_xabrdt;
13134 #ifndef __GNUC__
13135       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
13136 #else
13137       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
13138        * is unsigned long[2], while DECC & VAXC use a struct */
13139       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
13140 #endif
13141       fab_out.fab$l_xab = (void *) &xabrdt;
13142     }
13143
13144     ubf = PerlMem_malloc(32256);
13145     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13146     rab_in = cc$rms_rab;
13147     rab_in.rab$l_fab = &fab_in;
13148     rab_in.rab$l_rop = RAB$M_BIO;
13149     rab_in.rab$l_ubf = ubf;
13150     rab_in.rab$w_usz = 32256;
13151     if (!((sts = sys$connect(&rab_in)) & 1)) {
13152       sys$close(&fab_in); sys$close(&fab_out);
13153       PerlMem_free(vmsin);
13154       PerlMem_free(vmsout);
13155       PerlMem_free(ubf);
13156       PerlMem_free(esa);
13157       if (esal != NULL)
13158           PerlMem_free(esal);
13159       PerlMem_free(rsa);
13160       if (rsal != NULL)
13161           PerlMem_free(rsal);
13162       PerlMem_free(esa_out);
13163       if (esal_out != NULL)
13164           PerlMem_free(esal_out);
13165       PerlMem_free(rsa_out);
13166       if (rsal_out != NULL)
13167           PerlMem_free(rsal_out);
13168       set_errno(EVMSERR); set_vaxc_errno(sts);
13169       return 0;
13170     }
13171
13172     rab_out = cc$rms_rab;
13173     rab_out.rab$l_fab = &fab_out;
13174     rab_out.rab$l_rbf = ubf;
13175     if (!((sts = sys$connect(&rab_out)) & 1)) {
13176       sys$close(&fab_in); sys$close(&fab_out);
13177       PerlMem_free(vmsin);
13178       PerlMem_free(vmsout);
13179       PerlMem_free(ubf);
13180       PerlMem_free(esa);
13181       if (esal != NULL)
13182           PerlMem_free(esal);
13183       PerlMem_free(rsa);
13184       if (rsal != NULL)
13185           PerlMem_free(rsal);
13186       PerlMem_free(esa_out);
13187       if (esal_out != NULL)
13188           PerlMem_free(esal_out);
13189       PerlMem_free(rsa_out);
13190       if (rsal_out != NULL)
13191           PerlMem_free(rsal_out);
13192       set_errno(EVMSERR); set_vaxc_errno(sts);
13193       return 0;
13194     }
13195
13196     while ((sts = sys$read(&rab_in))) {  /* always true  */
13197       if (sts == RMS$_EOF) break;
13198       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13199       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13200         sys$close(&fab_in); sys$close(&fab_out);
13201         PerlMem_free(vmsin);
13202         PerlMem_free(vmsout);
13203         PerlMem_free(ubf);
13204         PerlMem_free(esa);
13205         if (esal != NULL)
13206             PerlMem_free(esal);
13207         PerlMem_free(rsa);
13208         if (rsal != NULL)
13209             PerlMem_free(rsal);
13210         PerlMem_free(esa_out);
13211         if (esal_out != NULL)
13212             PerlMem_free(esal_out);
13213         PerlMem_free(rsa_out);
13214         if (rsal_out != NULL)
13215             PerlMem_free(rsal_out);
13216         set_errno(EVMSERR); set_vaxc_errno(sts);
13217         return 0;
13218       }
13219     }
13220
13221
13222     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
13223     sys$close(&fab_in);  sys$close(&fab_out);
13224     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13225
13226     PerlMem_free(vmsin);
13227     PerlMem_free(vmsout);
13228     PerlMem_free(ubf);
13229     PerlMem_free(esa);
13230     if (esal != NULL)
13231         PerlMem_free(esal);
13232     PerlMem_free(rsa);
13233     if (rsal != NULL)
13234         PerlMem_free(rsal);
13235     PerlMem_free(esa_out);
13236     if (esal_out != NULL)
13237         PerlMem_free(esal_out);
13238     PerlMem_free(rsa_out);
13239     if (rsal_out != NULL)
13240         PerlMem_free(rsal_out);
13241
13242     if (!(sts & 1)) {
13243       set_errno(EVMSERR); set_vaxc_errno(sts);
13244       return 0;
13245     }
13246
13247     return 1;
13248
13249 }  /* end of rmscopy() */
13250 /*}}}*/
13251
13252
13253 /***  The following glue provides 'hooks' to make some of the routines
13254  * from this file available from Perl.  These routines are sufficiently
13255  * basic, and are required sufficiently early in the build process,
13256  * that's it's nice to have them available to miniperl as well as the
13257  * full Perl, so they're set up here instead of in an extension.  The
13258  * Perl code which handles importation of these names into a given
13259  * package lives in [.VMS]Filespec.pm in @INC.
13260  */
13261
13262 void
13263 rmsexpand_fromperl(pTHX_ CV *cv)
13264 {
13265   dXSARGS;
13266   char *fspec, *defspec = NULL, *rslt;
13267   STRLEN n_a;
13268   int fs_utf8, dfs_utf8;
13269
13270   fs_utf8 = 0;
13271   dfs_utf8 = 0;
13272   if (!items || items > 2)
13273     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13274   fspec = SvPV(ST(0),n_a);
13275   fs_utf8 = SvUTF8(ST(0));
13276   if (!fspec || !*fspec) XSRETURN_UNDEF;
13277   if (items == 2) {
13278     defspec = SvPV(ST(1),n_a);
13279     dfs_utf8 = SvUTF8(ST(1));
13280   }
13281   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13282   ST(0) = sv_newmortal();
13283   if (rslt != NULL) {
13284     sv_usepvn(ST(0),rslt,strlen(rslt));
13285     if (fs_utf8) {
13286         SvUTF8_on(ST(0));
13287     }
13288   }
13289   XSRETURN(1);
13290 }
13291
13292 void
13293 vmsify_fromperl(pTHX_ CV *cv)
13294 {
13295   dXSARGS;
13296   char *vmsified;
13297   STRLEN n_a;
13298   int utf8_fl;
13299
13300   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13301   utf8_fl = SvUTF8(ST(0));
13302   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13303   ST(0) = sv_newmortal();
13304   if (vmsified != NULL) {
13305     sv_usepvn(ST(0),vmsified,strlen(vmsified));
13306     if (utf8_fl) {
13307         SvUTF8_on(ST(0));
13308     }
13309   }
13310   XSRETURN(1);
13311 }
13312
13313 void
13314 unixify_fromperl(pTHX_ CV *cv)
13315 {
13316   dXSARGS;
13317   char *unixified;
13318   STRLEN n_a;
13319   int utf8_fl;
13320
13321   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13322   utf8_fl = SvUTF8(ST(0));
13323   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13324   ST(0) = sv_newmortal();
13325   if (unixified != NULL) {
13326     sv_usepvn(ST(0),unixified,strlen(unixified));
13327     if (utf8_fl) {
13328         SvUTF8_on(ST(0));
13329     }
13330   }
13331   XSRETURN(1);
13332 }
13333
13334 void
13335 fileify_fromperl(pTHX_ CV *cv)
13336 {
13337   dXSARGS;
13338   char *fileified;
13339   STRLEN n_a;
13340   int utf8_fl;
13341
13342   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13343   utf8_fl = SvUTF8(ST(0));
13344   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13345   ST(0) = sv_newmortal();
13346   if (fileified != NULL) {
13347     sv_usepvn(ST(0),fileified,strlen(fileified));
13348     if (utf8_fl) {
13349         SvUTF8_on(ST(0));
13350     }
13351   }
13352   XSRETURN(1);
13353 }
13354
13355 void
13356 pathify_fromperl(pTHX_ CV *cv)
13357 {
13358   dXSARGS;
13359   char *pathified;
13360   STRLEN n_a;
13361   int utf8_fl;
13362
13363   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13364   utf8_fl = SvUTF8(ST(0));
13365   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13366   ST(0) = sv_newmortal();
13367   if (pathified != NULL) {
13368     sv_usepvn(ST(0),pathified,strlen(pathified));
13369     if (utf8_fl) {
13370         SvUTF8_on(ST(0));
13371     }
13372   }
13373   XSRETURN(1);
13374 }
13375
13376 void
13377 vmspath_fromperl(pTHX_ CV *cv)
13378 {
13379   dXSARGS;
13380   char *vmspath;
13381   STRLEN n_a;
13382   int utf8_fl;
13383
13384   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13385   utf8_fl = SvUTF8(ST(0));
13386   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13387   ST(0) = sv_newmortal();
13388   if (vmspath != NULL) {
13389     sv_usepvn(ST(0),vmspath,strlen(vmspath));
13390     if (utf8_fl) {
13391         SvUTF8_on(ST(0));
13392     }
13393   }
13394   XSRETURN(1);
13395 }
13396
13397 void
13398 unixpath_fromperl(pTHX_ CV *cv)
13399 {
13400   dXSARGS;
13401   char *unixpath;
13402   STRLEN n_a;
13403   int utf8_fl;
13404
13405   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13406   utf8_fl = SvUTF8(ST(0));
13407   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13408   ST(0) = sv_newmortal();
13409   if (unixpath != NULL) {
13410     sv_usepvn(ST(0),unixpath,strlen(unixpath));
13411     if (utf8_fl) {
13412         SvUTF8_on(ST(0));
13413     }
13414   }
13415   XSRETURN(1);
13416 }
13417
13418 void
13419 candelete_fromperl(pTHX_ CV *cv)
13420 {
13421   dXSARGS;
13422   char *fspec, *fsp;
13423   SV *mysv;
13424   IO *io;
13425   STRLEN n_a;
13426
13427   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13428
13429   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13430   Newx(fspec, VMS_MAXRSS, char);
13431   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13432   if (isGV_with_GP(mysv)) {
13433     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13434       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13435       ST(0) = &PL_sv_no;
13436       Safefree(fspec);
13437       XSRETURN(1);
13438     }
13439     fsp = fspec;
13440   }
13441   else {
13442     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13443       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13444       ST(0) = &PL_sv_no;
13445       Safefree(fspec);
13446       XSRETURN(1);
13447     }
13448   }
13449
13450   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13451   Safefree(fspec);
13452   XSRETURN(1);
13453 }
13454
13455 void
13456 rmscopy_fromperl(pTHX_ CV *cv)
13457 {
13458   dXSARGS;
13459   char *inspec, *outspec, *inp, *outp;
13460   int date_flag;
13461   SV *mysv;
13462   IO *io;
13463   STRLEN n_a;
13464
13465   if (items < 2 || items > 3)
13466     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13467
13468   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13469   Newx(inspec, VMS_MAXRSS, char);
13470   if (isGV_with_GP(mysv)) {
13471     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13472       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13473       ST(0) = sv_2mortal(newSViv(0));
13474       Safefree(inspec);
13475       XSRETURN(1);
13476     }
13477     inp = inspec;
13478   }
13479   else {
13480     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13481       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13482       ST(0) = sv_2mortal(newSViv(0));
13483       Safefree(inspec);
13484       XSRETURN(1);
13485     }
13486   }
13487   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13488   Newx(outspec, VMS_MAXRSS, char);
13489   if (isGV_with_GP(mysv)) {
13490     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13491       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13492       ST(0) = sv_2mortal(newSViv(0));
13493       Safefree(inspec);
13494       Safefree(outspec);
13495       XSRETURN(1);
13496     }
13497     outp = outspec;
13498   }
13499   else {
13500     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13501       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13502       ST(0) = sv_2mortal(newSViv(0));
13503       Safefree(inspec);
13504       Safefree(outspec);
13505       XSRETURN(1);
13506     }
13507   }
13508   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13509
13510   ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
13511   Safefree(inspec);
13512   Safefree(outspec);
13513   XSRETURN(1);
13514 }
13515
13516 /* The mod2fname is limited to shorter filenames by design, so it should
13517  * not be modified to support longer EFS pathnames
13518  */
13519 void
13520 mod2fname(pTHX_ CV *cv)
13521 {
13522   dXSARGS;
13523   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13524        workbuff[NAM$C_MAXRSS*1 + 1];
13525   int counter, num_entries;
13526   /* ODS-5 ups this, but we want to be consistent, so... */
13527   int max_name_len = 39;
13528   AV *in_array = (AV *)SvRV(ST(0));
13529
13530   num_entries = av_len(in_array);
13531
13532   /* All the names start with PL_. */
13533   strcpy(ultimate_name, "PL_");
13534
13535   /* Clean up our working buffer */
13536   Zero(work_name, sizeof(work_name), char);
13537
13538   /* Run through the entries and build up a working name */
13539   for(counter = 0; counter <= num_entries; counter++) {
13540     /* If it's not the first name then tack on a __ */
13541     if (counter) {
13542       strcat(work_name, "__");
13543     }
13544     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13545   }
13546
13547   /* Check to see if we actually have to bother...*/
13548   if (strlen(work_name) + 3 <= max_name_len) {
13549     strcat(ultimate_name, work_name);
13550   } else {
13551     /* It's too darned big, so we need to go strip. We use the same */
13552     /* algorithm as xsubpp does. First, strip out doubled __ */
13553     char *source, *dest, last;
13554     dest = workbuff;
13555     last = 0;
13556     for (source = work_name; *source; source++) {
13557       if (last == *source && last == '_') {
13558         continue;
13559       }
13560       *dest++ = *source;
13561       last = *source;
13562     }
13563     /* Go put it back */
13564     strcpy(work_name, workbuff);
13565     /* Is it still too big? */
13566     if (strlen(work_name) + 3 > max_name_len) {
13567       /* Strip duplicate letters */
13568       last = 0;
13569       dest = workbuff;
13570       for (source = work_name; *source; source++) {
13571         if (last == toupper(*source)) {
13572         continue;
13573         }
13574         *dest++ = *source;
13575         last = toupper(*source);
13576       }
13577       strcpy(work_name, workbuff);
13578     }
13579
13580     /* Is it *still* too big? */
13581     if (strlen(work_name) + 3 > max_name_len) {
13582       /* Too bad, we truncate */
13583       work_name[max_name_len - 2] = 0;
13584     }
13585     strcat(ultimate_name, work_name);
13586   }
13587
13588   /* Okay, return it */
13589   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13590   XSRETURN(1);
13591 }
13592
13593 void
13594 hushexit_fromperl(pTHX_ CV *cv)
13595 {
13596     dXSARGS;
13597
13598     if (items > 0) {
13599         VMSISH_HUSHED = SvTRUE(ST(0));
13600     }
13601     ST(0) = boolSV(VMSISH_HUSHED);
13602     XSRETURN(1);
13603 }
13604
13605
13606 PerlIO *
13607 Perl_vms_start_glob
13608    (pTHX_ SV *tmpglob,
13609     IO *io)
13610 {
13611     PerlIO *fp;
13612     struct vs_str_st *rslt;
13613     char *vmsspec;
13614     char *rstr;
13615     char *begin, *cp;
13616     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13617     PerlIO *tmpfp;
13618     STRLEN i;
13619     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13620     struct dsc$descriptor_vs rsdsc;
13621     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13622     unsigned long hasver = 0, isunix = 0;
13623     unsigned long int lff_flags = 0;
13624     int rms_sts;
13625     int vms_old_glob = 1;
13626
13627     if (!SvOK(tmpglob)) {
13628         SETERRNO(ENOENT,RMS$_FNF);
13629         return NULL;
13630     }
13631
13632     vms_old_glob = !decc_filename_unix_report;
13633
13634 #ifdef VMS_LONGNAME_SUPPORT
13635     lff_flags = LIB$M_FIL_LONG_NAMES;
13636 #endif
13637     /* The Newx macro will not allow me to assign a smaller array
13638      * to the rslt pointer, so we will assign it to the begin char pointer
13639      * and then copy the value into the rslt pointer.
13640      */
13641     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13642     rslt = (struct vs_str_st *)begin;
13643     rslt->length = 0;
13644     rstr = &rslt->str[0];
13645     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13646     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13647     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13648     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13649
13650     Newx(vmsspec, VMS_MAXRSS, char);
13651
13652         /* We could find out if there's an explicit dev/dir or version
13653            by peeking into lib$find_file's internal context at
13654            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13655            but that's unsupported, so I don't want to do it now and
13656            have it bite someone in the future. */
13657         /* Fix-me: vms_split_path() is the only way to do this, the
13658            existing method will fail with many legal EFS or UNIX specifications
13659          */
13660
13661     cp = SvPV(tmpglob,i);
13662
13663     for (; i; i--) {
13664         if (cp[i] == ';') hasver = 1;
13665         if (cp[i] == '.') {
13666             if (sts) hasver = 1;
13667             else sts = 1;
13668         }
13669         if (cp[i] == '/') {
13670             hasdir = isunix = 1;
13671             break;
13672         }
13673         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13674             hasdir = 1;
13675             break;
13676         }
13677     }
13678
13679     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13680     if ((hasdir == 0) && decc_filename_unix_report) {
13681         isunix = 1;
13682     }
13683
13684     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13685         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13686         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13687         int wildstar = 0;
13688         int wildquery = 0;
13689         int found = 0;
13690         Stat_t st;
13691         int stat_sts;
13692         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13693         if (!stat_sts && S_ISDIR(st.st_mode)) {
13694             char * vms_dir;
13695             const char * fname;
13696             STRLEN fname_len;
13697
13698             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13699             /* path delimiter of ':>]', if so, then the old behavior has */
13700             /* obviously been specifically requested */
13701
13702             fname = SvPVX_const(tmpglob);
13703             fname_len = strlen(fname);
13704             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13705             if (vms_old_glob || (vms_dir != NULL)) {
13706                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13707                                             SvPVX(tmpglob),vmsspec,NULL);
13708                 ok = (wilddsc.dsc$a_pointer != NULL);
13709                 /* maybe passed 'foo' rather than '[.foo]', thus not
13710                    detected above */
13711                 hasdir = 1;
13712             } else {
13713                 /* Operate just on the directory, the special stat/fstat for */
13714                 /* leaves the fileified  specification in the st_devnam */
13715                 /* member. */
13716                 wilddsc.dsc$a_pointer = st.st_devnam;
13717                 ok = 1;
13718             }
13719         }
13720         else {
13721             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13722             ok = (wilddsc.dsc$a_pointer != NULL);
13723         }
13724         if (ok)
13725             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13726
13727         /* If not extended character set, replace ? with % */
13728         /* With extended character set, ? is a wildcard single character */
13729         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13730             if (*cp == '?') {
13731                 wildquery = 1;
13732                 if (!decc_efs_case_preserve)
13733                     *cp = '%';
13734             } else if (*cp == '%') {
13735                 wildquery = 1;
13736             } else if (*cp == '*') {
13737                 wildstar = 1;
13738             }
13739         }
13740
13741         if (ok) {
13742             wv_sts = vms_split_path(
13743                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13744                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13745                 &wvs_spec, &wvs_len);
13746         } else {
13747             wn_spec = NULL;
13748             wn_len = 0;
13749             we_spec = NULL;
13750             we_len = 0;
13751         }
13752
13753         sts = SS$_NORMAL;
13754         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13755          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13756          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13757          int valid_find;
13758
13759             valid_find = 0;
13760             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13761                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13762             if (!$VMS_STATUS_SUCCESS(sts))
13763                 break;
13764
13765             /* with varying string, 1st word of buffer contains result length */
13766             rstr[rslt->length] = '\0';
13767
13768              /* Find where all the components are */
13769              v_sts = vms_split_path
13770                        (rstr,
13771                         &v_spec,
13772                         &v_len,
13773                         &r_spec,
13774                         &r_len,
13775                         &d_spec,
13776                         &d_len,
13777                         &n_spec,
13778                         &n_len,
13779                         &e_spec,
13780                         &e_len,
13781                         &vs_spec,
13782                         &vs_len);
13783
13784             /* If no version on input, truncate the version on output */
13785             if (!hasver && (vs_len > 0)) {
13786                 *vs_spec = '\0';
13787                 vs_len = 0;
13788             }
13789
13790             if (isunix) {
13791
13792                 /* In Unix report mode, remove the ".dir;1" from the name */
13793                 /* if it is a real directory */
13794                 if (decc_filename_unix_report || decc_efs_charset) {
13795                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13796                         Stat_t statbuf;
13797                         int ret_sts;
13798
13799                         ret_sts = flex_lstat(rstr, &statbuf);
13800                         if ((ret_sts == 0) &&
13801                             S_ISDIR(statbuf.st_mode)) {
13802                             e_len = 0;
13803                             e_spec[0] = 0;
13804                         }
13805                     }
13806                 }
13807
13808                 /* No version & a null extension on UNIX handling */
13809                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13810                     e_len = 0;
13811                     *e_spec = '\0';
13812                 }
13813             }
13814
13815             if (!decc_efs_case_preserve) {
13816                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13817             }
13818
13819             /* Find File treats a Null extension as return all extensions */
13820             /* This is contrary to Perl expectations */
13821
13822             if (wildstar || wildquery || vms_old_glob) {
13823                 /* really need to see if the returned file name matched */
13824                 /* but for now will assume that it matches */
13825                 valid_find = 1;
13826             } else {
13827                 /* Exact Match requested */
13828                 /* How are directories handled? - like a file */
13829                 if ((e_len == we_len) && (n_len == wn_len)) {
13830                     int t1;
13831                     t1 = e_len;
13832                     if (t1 > 0)
13833                         t1 = strncmp(e_spec, we_spec, e_len);
13834                     if (t1 == 0) {
13835                        t1 = n_len;
13836                        if (t1 > 0)
13837                            t1 = strncmp(n_spec, we_spec, n_len);
13838                        if (t1 == 0)
13839                            valid_find = 1;
13840                     }
13841                 }
13842             }
13843
13844             if (valid_find) {
13845                 found++;
13846
13847                 if (hasdir) {
13848                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13849                     begin = rstr;
13850                 }
13851                 else {
13852                     /* Start with the name */
13853                     begin = n_spec;
13854                 }
13855                 strcat(begin,"\n");
13856                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13857             }
13858         }
13859         if (cxt) (void)lib$find_file_end(&cxt);
13860
13861         if (!found) {
13862             /* Be POSIXish: return the input pattern when no matches */
13863             strcpy(rstr,SvPVX(tmpglob));
13864             strcat(rstr,"\n");
13865             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13866         }
13867
13868         if (ok && sts != RMS$_NMF &&
13869             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13870         if (!ok) {
13871             if (!(sts & 1)) {
13872                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13873             }
13874             PerlIO_close(tmpfp);
13875             fp = NULL;
13876         }
13877         else {
13878             PerlIO_rewind(tmpfp);
13879             IoTYPE(io) = IoTYPE_RDONLY;
13880             IoIFP(io) = fp = tmpfp;
13881             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13882         }
13883     }
13884     Safefree(vmsspec);
13885     Safefree(rslt);
13886     return fp;
13887 }
13888
13889
13890 static char *
13891 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13892                    int *utf8_fl);
13893
13894 void
13895 unixrealpath_fromperl(pTHX_ CV *cv)
13896 {
13897     dXSARGS;
13898     char *fspec, *rslt_spec, *rslt;
13899     STRLEN n_a;
13900
13901     if (!items || items != 1)
13902         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13903
13904     fspec = SvPV(ST(0),n_a);
13905     if (!fspec || !*fspec) XSRETURN_UNDEF;
13906
13907     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13908     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13909
13910     ST(0) = sv_newmortal();
13911     if (rslt != NULL)
13912         sv_usepvn(ST(0),rslt,strlen(rslt));
13913     else
13914         Safefree(rslt_spec);
13915         XSRETURN(1);
13916 }
13917
13918 static char *
13919 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13920                    int *utf8_fl);
13921
13922 void
13923 vmsrealpath_fromperl(pTHX_ CV *cv)
13924 {
13925     dXSARGS;
13926     char *fspec, *rslt_spec, *rslt;
13927     STRLEN n_a;
13928
13929     if (!items || items != 1)
13930         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13931
13932     fspec = SvPV(ST(0),n_a);
13933     if (!fspec || !*fspec) XSRETURN_UNDEF;
13934
13935     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13936     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13937
13938     ST(0) = sv_newmortal();
13939     if (rslt != NULL)
13940         sv_usepvn(ST(0),rslt,strlen(rslt));
13941     else
13942         Safefree(rslt_spec);
13943         XSRETURN(1);
13944 }
13945
13946 #ifdef HAS_SYMLINK
13947 /*
13948  * A thin wrapper around decc$symlink to make sure we follow the
13949  * standard and do not create a symlink with a zero-length name.
13950  *
13951  * Also in ODS-2 mode, existing tests assume that the link target
13952  * will be converted to UNIX format.
13953  */
13954 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13955 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13956   if (!link_name || !*link_name) {
13957     SETERRNO(ENOENT, SS$_NOSUCHFILE);
13958     return -1;
13959   }
13960
13961   if (decc_efs_charset) {
13962       return symlink(contents, link_name);
13963   } else {
13964       int sts;
13965       char * utarget;
13966
13967       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13968       /* because in order to work, the symlink target must be in UNIX format */
13969
13970       /* As symbolic links can hold things other than files, we will only do */
13971       /* the conversion in in ODS-2 mode */
13972
13973       utarget = PerlMem_malloc(VMS_MAXRSS + 1);
13974       if (int_tounixspec(contents, utarget, NULL) == NULL) {
13975
13976           /* This should not fail, as an untranslatable filename */
13977           /* should be passed through */
13978           utarget = (char *)contents;
13979       }
13980       sts = symlink(utarget, link_name);
13981       PerlMem_free(utarget);
13982       return sts;
13983   }
13984
13985 }
13986 /*}}}*/
13987
13988 #endif /* HAS_SYMLINK */
13989
13990 int do_vms_case_tolerant(void);
13991
13992 void
13993 case_tolerant_process_fromperl(pTHX_ CV *cv)
13994 {
13995   dXSARGS;
13996   ST(0) = boolSV(do_vms_case_tolerant());
13997   XSRETURN(1);
13998 }
13999
14000 #ifdef USE_ITHREADS
14001
14002 void
14003 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
14004                           struct interp_intern *dst)
14005 {
14006     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
14007
14008     memcpy(dst,src,sizeof(struct interp_intern));
14009 }
14010
14011 #endif
14012
14013 void
14014 Perl_sys_intern_clear(pTHX)
14015 {
14016 }
14017
14018 void
14019 Perl_sys_intern_init(pTHX)
14020 {
14021     unsigned int ix = RAND_MAX;
14022     double x;
14023
14024     VMSISH_HUSHED = 0;
14025
14026     MY_POSIX_EXIT = vms_posix_exit;
14027
14028     x = (float)ix;
14029     MY_INV_RAND_MAX = 1./x;
14030 }
14031
14032 void
14033 init_os_extras(void)
14034 {
14035   dTHX;
14036   char* file = __FILE__;
14037   if (decc_disable_to_vms_logname_translation) {
14038     no_translate_barewords = TRUE;
14039   } else {
14040     no_translate_barewords = FALSE;
14041   }
14042
14043   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
14044   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
14045   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
14046   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
14047   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
14048   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
14049   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
14050   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
14051   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
14052   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
14053   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
14054   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
14055   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
14056   newXSproto("VMS::Filespec::case_tolerant_process",
14057       case_tolerant_process_fromperl,file,"");
14058
14059   store_pipelocs(aTHX);         /* will redo any earlier attempts */
14060
14061   return;
14062 }
14063
14064 #if __CRTL_VER == 80200000
14065 /* This missed getting in to the DECC SDK for 8.2 */
14066 char *realpath(const char *file_name, char * resolved_name, ...);
14067 #endif
14068
14069 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
14070 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
14071  * The perl fallback routine to provide realpath() is not as efficient
14072  * on OpenVMS.
14073  */
14074
14075 /* Hack, use old stat() as fastest way of getting ino_t and device */
14076 int decc$stat(const char *name, void * statbuf);
14077 #if !defined(__VAX) && __CRTL_VER >= 80200000
14078 int decc$lstat(const char *name, void * statbuf);
14079 #else
14080 #define decc$lstat decc$stat
14081 #endif
14082
14083
14084 /* Realpath is fragile.  In 8.3 it does not work if the feature
14085  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
14086  * links are implemented in RMS, not the CRTL. It also can fail if the
14087  * user does not have read/execute access to some of the directories.
14088  * So in order for Do What I Mean mode to work, if realpath() fails,
14089  * fall back to looking up the filename by the device name and FID.
14090  */
14091
14092 int vms_fid_to_name(char * outname, int outlen,
14093                     const char * name, int lstat_flag, mode_t * mode)
14094 {
14095 #pragma message save
14096 #pragma message disable MISALGNDSTRCT
14097 #pragma message disable MISALGNDMEM
14098 #pragma member_alignment save
14099 #pragma nomember_alignment
14100 struct statbuf_t {
14101     char           * st_dev;
14102     unsigned short st_ino[3];
14103     unsigned short old_st_mode;
14104     unsigned long  padl[30];  /* plenty of room */
14105 } statbuf;
14106 #pragma message restore
14107 #pragma member_alignment restore
14108
14109     int sts;
14110     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14111     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14112     char *fileified;
14113     char *temp_fspec;
14114     char *ret_spec;
14115
14116     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
14117      * unexpected answers
14118      */
14119
14120     fileified = PerlMem_malloc(VMS_MAXRSS);
14121     if (fileified == NULL)
14122         _ckvmssts_noperl(SS$_INSFMEM);
14123
14124     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
14125     if (temp_fspec == NULL)
14126         _ckvmssts_noperl(SS$_INSFMEM);
14127
14128     sts = -1;
14129     /* First need to try as a directory */
14130     ret_spec = int_tovmspath(name, temp_fspec, NULL);
14131     if (ret_spec != NULL) {
14132         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
14133         if (ret_spec != NULL) {
14134             if (lstat_flag == 0)
14135                 sts = decc$stat(fileified, &statbuf);
14136             else
14137                 sts = decc$lstat(fileified, &statbuf);
14138         }
14139     }
14140
14141     /* Then as a VMS file spec */
14142     if (sts != 0) {
14143         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
14144         if (ret_spec != NULL) {
14145             if (lstat_flag == 0) {
14146                 sts = decc$stat(temp_fspec, &statbuf);
14147             } else {
14148                 sts = decc$lstat(temp_fspec, &statbuf);
14149             }
14150         }
14151     }
14152
14153     if (sts) {
14154         /* Next try - allow multiple dots with out EFS CHARSET */
14155         /* The CRTL stat() falls down hard on multi-dot filenames in unix
14156          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
14157          * enable it if it isn't already.
14158          */
14159 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14160         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14161             decc$feature_set_value(decc_efs_charset_index, 1, 1);
14162 #endif
14163         ret_spec = int_tovmspath(name, temp_fspec, NULL);
14164         if (lstat_flag == 0) {
14165             sts = decc$stat(name, &statbuf);
14166         } else {
14167             sts = decc$lstat(name, &statbuf);
14168         }
14169 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14170         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14171             decc$feature_set_value(decc_efs_charset_index, 1, 0);
14172 #endif
14173     }
14174
14175
14176     /* and then because the Perl Unix to VMS conversion is not perfect */
14177     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
14178     /* characters from filenames so we need to try it as-is */
14179     if (sts) {
14180         if (lstat_flag == 0) {
14181             sts = decc$stat(name, &statbuf);
14182         } else {
14183             sts = decc$lstat(name, &statbuf);
14184         }
14185     }
14186
14187     if (sts == 0) {
14188         int vms_sts;
14189
14190         dvidsc.dsc$a_pointer=statbuf.st_dev;
14191         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
14192
14193         specdsc.dsc$a_pointer = outname;
14194         specdsc.dsc$w_length = outlen-1;
14195
14196         vms_sts = lib$fid_to_name
14197             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
14198         if ($VMS_STATUS_SUCCESS(vms_sts)) {
14199             outname[specdsc.dsc$w_length] = 0;
14200
14201             /* Return the mode */
14202             if (mode) {
14203                 *mode = statbuf.old_st_mode;
14204             }
14205         }
14206     }
14207     PerlMem_free(temp_fspec);
14208     PerlMem_free(fileified);
14209     return sts;
14210 }
14211
14212
14213
14214 static char *
14215 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
14216                    int *utf8_fl)
14217 {
14218     char * rslt = NULL;
14219
14220 #ifdef HAS_SYMLINK
14221     if (decc_posix_compliant_pathnames > 0 ) {
14222         /* realpath currently only works if posix compliant pathnames are
14223          * enabled.  It may start working when they are not, but in that
14224          * case we still want the fallback behavior for backwards compatibility
14225          */
14226         rslt = realpath(filespec, outbuf);
14227     }
14228 #endif
14229
14230     if (rslt == NULL) {
14231         char * vms_spec;
14232         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14233         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14234         mode_t my_mode;
14235
14236         /* Fall back to fid_to_name */
14237
14238         Newx(vms_spec, VMS_MAXRSS + 1, char);
14239
14240         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
14241         if (sts == 0) {
14242
14243
14244             /* Now need to trim the version off */
14245             sts = vms_split_path
14246                   (vms_spec,
14247                    &v_spec,
14248                    &v_len,
14249                    &r_spec,
14250                    &r_len,
14251                    &d_spec,
14252                    &d_len,
14253                    &n_spec,
14254                    &n_len,
14255                    &e_spec,
14256                    &e_len,
14257                    &vs_spec,
14258                    &vs_len);
14259
14260
14261                 if (sts == 0) {
14262                     int haslower = 0;
14263                     const char *cp;
14264
14265                     /* Trim off the version */
14266                     int file_len = v_len + r_len + d_len + n_len + e_len;
14267                     vms_spec[file_len] = 0;
14268
14269                     /* Trim off the .DIR if this is a directory */
14270                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
14271                         if (S_ISDIR(my_mode)) {
14272                             e_len = 0;
14273                             e_spec[0] = 0;
14274                         }
14275                     }
14276
14277                     /* Drop NULL extensions on UNIX file specification */
14278                     if ((e_len == 1) && decc_readdir_dropdotnotype) {
14279                         e_len = 0;
14280                         e_spec[0] = '\0';
14281                     }
14282
14283                     /* The result is expected to be in UNIX format */
14284                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14285
14286                     /* Downcase if input had any lower case letters and
14287                      * case preservation is not in effect.
14288                      */
14289                     if (!decc_efs_case_preserve) {
14290                         for (cp = filespec; *cp; cp++)
14291                             if (islower(*cp)) { haslower = 1; break; }
14292
14293                         if (haslower) __mystrtolower(rslt);
14294                     }
14295                 }
14296         } else {
14297
14298             /* Now for some hacks to deal with backwards and forward */
14299             /* compatibility */
14300             if (!decc_efs_charset) {
14301
14302                 /* 1. ODS-2 mode wants to do a syntax only translation */
14303                 rslt = int_rmsexpand(filespec, outbuf,
14304                                     NULL, 0, NULL, utf8_fl);
14305
14306             } else {
14307                 if (decc_filename_unix_report) {
14308                     char * dir_name;
14309                     char * vms_dir_name;
14310                     char * file_name;
14311
14312                     /* 2. ODS-5 / UNIX report mode should return a failure */
14313                     /*    if the parent directory also does not exist */
14314                     /*    Otherwise, get the real path for the parent */
14315                     /*    and add the child to it.
14316
14317                     /* basename / dirname only available for VMS 7.0+ */
14318                     /* So we may need to implement them as common routines */
14319
14320                     Newx(dir_name, VMS_MAXRSS + 1, char);
14321                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14322                     dir_name[0] = '\0';
14323                     file_name = NULL;
14324
14325                     /* First try a VMS parse */
14326                     sts = vms_split_path
14327                           (filespec,
14328                            &v_spec,
14329                            &v_len,
14330                            &r_spec,
14331                            &r_len,
14332                            &d_spec,
14333                            &d_len,
14334                            &n_spec,
14335                            &n_len,
14336                            &e_spec,
14337                            &e_len,
14338                            &vs_spec,
14339                            &vs_len);
14340
14341                     if (sts == 0) {
14342                         /* This is VMS */
14343
14344                         int dir_len = v_len + r_len + d_len + n_len;
14345                         if (dir_len > 0) {
14346                            strncpy(dir_name, filespec, dir_len);
14347                            dir_name[dir_len] = '\0';
14348                            file_name = (char *)&filespec[dir_len + 1];
14349                         }
14350                     } else {
14351                         /* This must be UNIX */
14352                         char * tchar;
14353
14354                         tchar = strrchr(filespec, '/');
14355
14356                         if (tchar != NULL) {
14357                             int dir_len = tchar - filespec;
14358                             strncpy(dir_name, filespec, dir_len);
14359                             dir_name[dir_len] = '\0';
14360                             file_name = (char *) &filespec[dir_len + 1];
14361                         }
14362                     }
14363
14364                     /* Dir name is defaulted */
14365                     if (dir_name[0] == 0) {
14366                         dir_name[0] = '.';
14367                         dir_name[1] = '\0';
14368                     }
14369
14370                     /* Need realpath for the directory */
14371                     sts = vms_fid_to_name(vms_dir_name,
14372                                           VMS_MAXRSS + 1,
14373                                           dir_name, 0, NULL);
14374
14375                     if (sts == 0) {
14376                         /* Now need to pathify it.
14377                         char *tdir = int_pathify_dirspec(vms_dir_name,
14378                                                          outbuf);
14379
14380                         /* And now add the original filespec to it */
14381                         if (file_name != NULL) {
14382                             strcat(outbuf, file_name);
14383                         }
14384                         return outbuf;
14385                     }
14386                     Safefree(vms_dir_name);
14387                     Safefree(dir_name);
14388                 }
14389             }
14390         }
14391         Safefree(vms_spec);
14392     }
14393     return rslt;
14394 }
14395
14396 static char *
14397 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14398                    int *utf8_fl)
14399 {
14400     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14401     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14402
14403     /* Fall back to fid_to_name */
14404
14405     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
14406     if (sts != 0) {
14407         return NULL;
14408     }
14409     else {
14410
14411
14412         /* Now need to trim the version off */
14413         sts = vms_split_path
14414                   (outbuf,
14415                    &v_spec,
14416                    &v_len,
14417                    &r_spec,
14418                    &r_len,
14419                    &d_spec,
14420                    &d_len,
14421                    &n_spec,
14422                    &n_len,
14423                    &e_spec,
14424                    &e_len,
14425                    &vs_spec,
14426                    &vs_len);
14427
14428
14429         if (sts == 0) {
14430             int haslower = 0;
14431             const char *cp;
14432
14433             /* Trim off the version */
14434             int file_len = v_len + r_len + d_len + n_len + e_len;
14435             outbuf[file_len] = 0;
14436
14437             /* Downcase if input had any lower case letters and
14438              * case preservation is not in effect.
14439              */
14440             if (!decc_efs_case_preserve) {
14441                 for (cp = filespec; *cp; cp++)
14442                     if (islower(*cp)) { haslower = 1; break; }
14443
14444                 if (haslower) __mystrtolower(outbuf);
14445             }
14446         }
14447     }
14448     return outbuf;
14449 }
14450
14451
14452 /*}}}*/
14453 /* External entry points */
14454 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14455 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14456
14457 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14458 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14459
14460 /* case_tolerant */
14461
14462 /*{{{int do_vms_case_tolerant(void)*/
14463 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14464  * controlled by a process setting.
14465  */
14466 int do_vms_case_tolerant(void)
14467 {
14468     return vms_process_case_tolerant;
14469 }
14470 /*}}}*/
14471 /* External entry points */
14472 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14473 int Perl_vms_case_tolerant(void)
14474 { return do_vms_case_tolerant(); }
14475 #else
14476 int Perl_vms_case_tolerant(void)
14477 { return vms_process_case_tolerant; }
14478 #endif
14479
14480
14481  /* Start of DECC RTL Feature handling */
14482
14483 static int sys_trnlnm
14484    (const char * logname,
14485     char * value,
14486     int value_len)
14487 {
14488     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14489     const unsigned long attr = LNM$M_CASE_BLIND;
14490     struct dsc$descriptor_s name_dsc;
14491     int status;
14492     unsigned short result;
14493     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14494                                 {0, 0, 0, 0}};
14495
14496     name_dsc.dsc$w_length = strlen(logname);
14497     name_dsc.dsc$a_pointer = (char *)logname;
14498     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14499     name_dsc.dsc$b_class = DSC$K_CLASS_S;
14500
14501     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14502
14503     if ($VMS_STATUS_SUCCESS(status)) {
14504
14505          /* Null terminate and return the string */
14506         /*--------------------------------------*/
14507         value[result] = 0;
14508     }
14509
14510     return status;
14511 }
14512
14513 static int sys_crelnm
14514    (const char * logname,
14515     const char * value)
14516 {
14517     int ret_val;
14518     const char * proc_table = "LNM$PROCESS_TABLE";
14519     struct dsc$descriptor_s proc_table_dsc;
14520     struct dsc$descriptor_s logname_dsc;
14521     struct itmlst_3 item_list[2];
14522
14523     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14524     proc_table_dsc.dsc$w_length = strlen(proc_table);
14525     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14526     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14527
14528     logname_dsc.dsc$a_pointer = (char *) logname;
14529     logname_dsc.dsc$w_length = strlen(logname);
14530     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14531     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14532
14533     item_list[0].buflen = strlen(value);
14534     item_list[0].itmcode = LNM$_STRING;
14535     item_list[0].bufadr = (char *)value;
14536     item_list[0].retlen = NULL;
14537
14538     item_list[1].buflen = 0;
14539     item_list[1].itmcode = 0;
14540
14541     ret_val = sys$crelnm
14542                        (NULL,
14543                         (const struct dsc$descriptor_s *)&proc_table_dsc,
14544                         (const struct dsc$descriptor_s *)&logname_dsc,
14545                         NULL,
14546                         (const struct item_list_3 *) item_list);
14547
14548     return ret_val;
14549 }
14550
14551 /* C RTL Feature settings */
14552
14553 static int set_features
14554    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
14555     int (* cli_routine)(void),  /* Not documented */
14556     void *image_info)           /* Not documented */
14557 {
14558     int status;
14559     int s;
14560     char val_str[10];
14561 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14562     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14563     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14564     unsigned long case_perm;
14565     unsigned long case_image;
14566 #endif
14567
14568     /* Allow an exception to bring Perl into the VMS debugger */
14569     vms_debug_on_exception = 0;
14570     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14571     if ($VMS_STATUS_SUCCESS(status)) {
14572        val_str[0] = _toupper(val_str[0]);
14573        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14574          vms_debug_on_exception = 1;
14575        else
14576          vms_debug_on_exception = 0;
14577     }
14578
14579     /* Debug unix/vms file translation routines */
14580     vms_debug_fileify = 0;
14581     status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14582     if ($VMS_STATUS_SUCCESS(status)) {
14583         val_str[0] = _toupper(val_str[0]);
14584         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14585             vms_debug_fileify = 1;
14586         else
14587             vms_debug_fileify = 0;
14588     }
14589
14590
14591     /* Historically PERL has been doing vmsify / stat differently than */
14592     /* the CRTL.  In particular, under some conditions the CRTL will   */
14593     /* remove some illegal characters like spaces from filenames       */
14594     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14595     /* been reporting such file names as invalid and fails to stat them */
14596     /* fixing this bug so that stat()/lstat() accept these like the     */
14597     /* CRTL does will result in several tests failing.                  */
14598     /* This should really be fixed, but for now, set up a feature to    */
14599     /* enable it so that the impact can be studied.                     */
14600     vms_bug_stat_filename = 0;
14601     status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14602     if ($VMS_STATUS_SUCCESS(status)) {
14603         val_str[0] = _toupper(val_str[0]);
14604         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14605             vms_bug_stat_filename = 1;
14606         else
14607             vms_bug_stat_filename = 0;
14608     }
14609
14610
14611     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14612     vms_vtf7_filenames = 0;
14613     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14614     if ($VMS_STATUS_SUCCESS(status)) {
14615        val_str[0] = _toupper(val_str[0]);
14616        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14617          vms_vtf7_filenames = 1;
14618        else
14619          vms_vtf7_filenames = 0;
14620     }
14621
14622     /* unlink all versions on unlink() or rename() */
14623     vms_unlink_all_versions = 0;
14624     status = sys_trnlnm
14625         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14626     if ($VMS_STATUS_SUCCESS(status)) {
14627        val_str[0] = _toupper(val_str[0]);
14628        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14629          vms_unlink_all_versions = 1;
14630        else
14631          vms_unlink_all_versions = 0;
14632     }
14633
14634     /* Dectect running under GNV Bash or other UNIX like shell */
14635 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14636     gnv_unix_shell = 0;
14637     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14638     if ($VMS_STATUS_SUCCESS(status)) {
14639          gnv_unix_shell = 1;
14640          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14641          set_feature_default("DECC$EFS_CHARSET", 1);
14642          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14643          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14644          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14645          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14646          vms_unlink_all_versions = 1;
14647          vms_posix_exit = 1;
14648     }
14649 #endif
14650
14651     /* hacks to see if known bugs are still present for testing */
14652
14653     /* PCP mode requires creating /dev/null special device file */
14654     decc_bug_devnull = 0;
14655     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14656     if ($VMS_STATUS_SUCCESS(status)) {
14657        val_str[0] = _toupper(val_str[0]);
14658        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14659           decc_bug_devnull = 1;
14660        else
14661           decc_bug_devnull = 0;
14662     }
14663
14664     /* UNIX directory names with no paths are broken in a lot of places */
14665     decc_dir_barename = 1;
14666     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14667     if ($VMS_STATUS_SUCCESS(status)) {
14668       val_str[0] = _toupper(val_str[0]);
14669       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14670         decc_dir_barename = 1;
14671       else
14672         decc_dir_barename = 0;
14673     }
14674
14675 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14676     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14677     if (s >= 0) {
14678         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14679         if (decc_disable_to_vms_logname_translation < 0)
14680             decc_disable_to_vms_logname_translation = 0;
14681     }
14682
14683     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14684     if (s >= 0) {
14685         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14686         if (decc_efs_case_preserve < 0)
14687             decc_efs_case_preserve = 0;
14688     }
14689
14690     s = decc$feature_get_index("DECC$EFS_CHARSET");
14691     decc_efs_charset_index = s;
14692     if (s >= 0) {
14693         decc_efs_charset = decc$feature_get_value(s, 1);
14694         if (decc_efs_charset < 0)
14695             decc_efs_charset = 0;
14696     }
14697
14698     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14699     if (s >= 0) {
14700         decc_filename_unix_report = decc$feature_get_value(s, 1);
14701         if (decc_filename_unix_report > 0) {
14702             decc_filename_unix_report = 1;
14703             vms_posix_exit = 1;
14704         }
14705         else
14706             decc_filename_unix_report = 0;
14707     }
14708
14709     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14710     if (s >= 0) {
14711         decc_filename_unix_only = decc$feature_get_value(s, 1);
14712         if (decc_filename_unix_only > 0) {
14713             decc_filename_unix_only = 1;
14714         }
14715         else {
14716             decc_filename_unix_only = 0;
14717         }
14718     }
14719
14720     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14721     if (s >= 0) {
14722         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14723         if (decc_filename_unix_no_version < 0)
14724             decc_filename_unix_no_version = 0;
14725     }
14726
14727     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14728     if (s >= 0) {
14729         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14730         if (decc_readdir_dropdotnotype < 0)
14731             decc_readdir_dropdotnotype = 0;
14732     }
14733
14734 #if __CRTL_VER >= 80200000
14735     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14736     if (s >= 0) {
14737         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14738         if (decc_posix_compliant_pathnames < 0)
14739             decc_posix_compliant_pathnames = 0;
14740         if (decc_posix_compliant_pathnames > 4)
14741             decc_posix_compliant_pathnames = 0;
14742     }
14743
14744 #endif
14745 #else
14746     status = sys_trnlnm
14747         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14748     if ($VMS_STATUS_SUCCESS(status)) {
14749         val_str[0] = _toupper(val_str[0]);
14750         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14751            decc_disable_to_vms_logname_translation = 1;
14752         }
14753     }
14754
14755 #ifndef __VAX
14756     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14757     if ($VMS_STATUS_SUCCESS(status)) {
14758         val_str[0] = _toupper(val_str[0]);
14759         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14760            decc_efs_case_preserve = 1;
14761         }
14762     }
14763 #endif
14764
14765     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14766     if ($VMS_STATUS_SUCCESS(status)) {
14767         val_str[0] = _toupper(val_str[0]);
14768         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14769            decc_filename_unix_report = 1;
14770         }
14771     }
14772     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14773     if ($VMS_STATUS_SUCCESS(status)) {
14774         val_str[0] = _toupper(val_str[0]);
14775         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14776            decc_filename_unix_only = 1;
14777            decc_filename_unix_report = 1;
14778         }
14779     }
14780     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14781     if ($VMS_STATUS_SUCCESS(status)) {
14782         val_str[0] = _toupper(val_str[0]);
14783         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14784            decc_filename_unix_no_version = 1;
14785         }
14786     }
14787     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14788     if ($VMS_STATUS_SUCCESS(status)) {
14789         val_str[0] = _toupper(val_str[0]);
14790         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14791            decc_readdir_dropdotnotype = 1;
14792         }
14793     }
14794 #endif
14795
14796 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14797
14798      /* Report true case tolerance */
14799     /*----------------------------*/
14800     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14801     if (!$VMS_STATUS_SUCCESS(status))
14802         case_perm = PPROP$K_CASE_BLIND;
14803     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14804     if (!$VMS_STATUS_SUCCESS(status))
14805         case_image = PPROP$K_CASE_BLIND;
14806     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14807         (case_image == PPROP$K_CASE_SENSITIVE))
14808         vms_process_case_tolerant = 0;
14809
14810 #endif
14811
14812     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14813     /* for strict backward compatibility */
14814     status = sys_trnlnm
14815         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14816     if ($VMS_STATUS_SUCCESS(status)) {
14817        val_str[0] = _toupper(val_str[0]);
14818        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14819          vms_posix_exit = 1;
14820        else
14821          vms_posix_exit = 0;
14822     }
14823
14824
14825     /* CRTL can be initialized past this point, but not before. */
14826 /*    DECC$CRTL_INIT(); */
14827
14828     return SS$_NORMAL;
14829 }
14830
14831 #ifdef __DECC
14832 #pragma nostandard
14833 #pragma extern_model save
14834 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14835         const __align (LONGWORD) int spare[8] = {0};
14836
14837 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14838 #if __DECC_VER >= 60560002
14839 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14840 #else
14841 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14842 #endif
14843 #endif /* __DECC */
14844
14845 const long vms_cc_features = (const long)set_features;
14846
14847 /*
14848 ** Force a reference to LIB$INITIALIZE to ensure it
14849 ** exists in the image.
14850 */
14851 #define lib$initialize LIB$INITIALIZE
14852 int lib$initialize(void);
14853 #ifdef __DECC
14854 #pragma extern_model strict_refdef
14855 #endif
14856     int lib_init_ref = (int) lib$initialize;
14857
14858 #ifdef __DECC
14859 #pragma extern_model restore
14860 #pragma standard
14861 #endif
14862
14863 /*  End of vms.c */